Update draft release notes to 1.6.3
[git/git.git] / perl / Git.pm
CommitLineData
b1edc53d
PB
1=head1 NAME
2
3Git - Perl interface to the Git version control system
4
5=cut
6
7
8package Git;
9
10use strict;
11
12
13BEGIN {
14
15our ($VERSION, @ISA, @EXPORT, @EXPORT_OK);
16
17# Totally unstable API.
18$VERSION = '0.01';
19
20
21=head1 SYNOPSIS
22
23 use Git;
24
25 my $version = Git::command_oneline('version');
26
8b9150e3
PB
27 git_cmd_try { Git::command_noisy('update-server-info') }
28 '%s failed w/ code %d';
b1edc53d
PB
29
30 my $repo = Git->repository (Directory => '/srv/git/cogito.git');
31
32
33 my @revs = $repo->command('rev-list', '--since=last monday', '--all');
34
d79850e1 35 my ($fh, $c) = $repo->command_output_pipe('rev-list', '--since=last monday', '--all');
b1edc53d 36 my $lastrev = <$fh>; chomp $lastrev;
8b9150e3 37 $repo->command_close_pipe($fh, $c);
b1edc53d 38
d43ba468
PB
39 my $lastrev = $repo->command_oneline( [ 'rev-list', '--all' ],
40 STDERR => 0 );
b1edc53d 41
7182530d
AR
42 my $sha1 = $repo->hash_and_insert_object('file.txt');
43 my $tempfile = tempfile();
44 my $size = $repo->cat_blob($sha1, $tempfile);
45
b1edc53d
PB
46=cut
47
48
49require Exporter;
50
51@ISA = qw(Exporter);
52
8b9150e3 53@EXPORT = qw(git_cmd_try);
b1edc53d
PB
54
55# Methods which can be called as standalone functions as well:
d79850e1
PB
56@EXPORT_OK = qw(command command_oneline command_noisy
57 command_output_pipe command_input_pipe command_close_pipe
d1a29af9 58 command_bidi_pipe command_close_bidi_pipe
31a92f6a 59 version exec_path hash_object git_cmd_try
e41352b2 60 remote_refs
836ff95d 61 temp_acquire temp_release temp_reset temp_path);
b1edc53d
PB
62
63
64=head1 DESCRIPTION
65
66This module provides Perl scripts easy way to interface the Git version control
67system. The modules have an easy and well-tested way to call arbitrary Git
68commands; in the future, the interface will also provide specialized methods
69for doing easily operations which are not totally trivial to do over
70the generic command interface.
71
72While some commands can be executed outside of any context (e.g. 'version'
5c94f87e 73or 'init'), most operations require a repository context, which in practice
b1edc53d
PB
74means getting an instance of the Git object using the repository() constructor.
75(In the future, we will also get a new_repository() constructor.) All commands
76called as methods of the object are then executed in the context of the
77repository.
78
d5c7721d
PB
79Part of the "repository state" is also information about path to the attached
80working copy (unless you work with a bare repository). You can also navigate
81inside of the working copy using the C<wc_chdir()> method. (Note that
82the repository object is self-contained and will not change working directory
83of your process.)
b1edc53d 84
d5c7721d 85TODO: In the future, we might also do
b1edc53d
PB
86
87 my $remoterepo = $repo->remote_repository (Name => 'cogito', Branch => 'master');
88 $remoterepo ||= Git->remote_repository ('http://git.or.cz/cogito.git/');
89 my @refs = $remoterepo->refs();
90
b1edc53d
PB
91Currently, the module merely wraps calls to external Git tools. In the future,
92it will provide a much faster way to interact with Git by linking directly
93to libgit. This should be completely opaque to the user, though (performance
9751a32a 94increase notwithstanding).
b1edc53d
PB
95
96=cut
97
98
8b9150e3 99use Carp qw(carp croak); # but croak is bad - throw instead
97b16c06 100use Error qw(:try);
d5c7721d 101use Cwd qw(abs_path);
d1a29af9 102use IPC::Open2 qw(open2);
e41352b2 103use Fcntl qw(SEEK_SET SEEK_CUR);
b1edc53d
PB
104}
105
106
107=head1 CONSTRUCTORS
108
109=over 4
110
111=item repository ( OPTIONS )
112
113=item repository ( DIRECTORY )
114
115=item repository ()
116
117Construct a new repository object.
118C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
119Possible options are:
120
121B<Repository> - Path to the Git repository.
122
123B<WorkingCopy> - Path to the associated working copy; not strictly required
124as many commands will happily crunch on a bare repository.
125
d5c7721d
PB
126B<WorkingSubdir> - Subdirectory in the working copy to work inside.
127Just left undefined if you do not want to limit the scope of operations.
128
129B<Directory> - Path to the Git working directory in its usual setup.
130The C<.git> directory is searched in the directory and all the parent
131directories; if found, C<WorkingCopy> is set to the directory containing
132it and C<Repository> to the C<.git> directory itself. If no C<.git>
133directory was found, the C<Directory> is assumed to be a bare repository,
134C<Repository> is set to point at it and C<WorkingCopy> is left undefined.
135If the C<$GIT_DIR> environment variable is set, things behave as expected
136as well.
b1edc53d 137
b1edc53d
PB
138You should not use both C<Directory> and either of C<Repository> and
139C<WorkingCopy> - the results of that are undefined.
140
141Alternatively, a directory path may be passed as a single scalar argument
142to the constructor; it is equivalent to setting only the C<Directory> option
143field.
144
145Calling the constructor with no options whatsoever is equivalent to
d5c7721d
PB
146calling it with C<< Directory => '.' >>. In general, if you are building
147a standard porcelain command, simply doing C<< Git->repository() >> should
148do the right thing and setup the object to reflect exactly where the user
149is right now.
b1edc53d
PB
150
151=cut
152
153sub repository {
154 my $class = shift;
155 my @args = @_;
156 my %opts = ();
157 my $self;
158
159 if (defined $args[0]) {
160 if ($#args % 2 != 1) {
161 # Not a hash.
97b16c06
PB
162 $#args == 0 or throw Error::Simple("bad usage");
163 %opts = ( Directory => $args[0] );
b1edc53d
PB
164 } else {
165 %opts = @args;
166 }
d5c7721d
PB
167 }
168
11b8a41c
PB
169 if (not defined $opts{Repository} and not defined $opts{WorkingCopy}
170 and not defined $opts{Directory}) {
171 $opts{Directory} = '.';
d5c7721d
PB
172 }
173
11b8a41c 174 if (defined $opts{Directory}) {
d5c7721d
PB
175 -d $opts{Directory} or throw Error::Simple("Directory not found: $!");
176
177 my $search = Git->repository(WorkingCopy => $opts{Directory});
178 my $dir;
179 try {
180 $dir = $search->command_oneline(['rev-parse', '--git-dir'],
181 STDERR => 0);
182 } catch Git::Error::Command with {
183 $dir = undef;
184 };
b1edc53d 185
d5c7721d 186 if ($dir) {
71efe0ca
PB
187 $dir =~ m#^/# or $dir = $opts{Directory} . '/' . $dir;
188 $opts{Repository} = $dir;
d5c7721d
PB
189
190 # If --git-dir went ok, this shouldn't die either.
191 my $prefix = $search->command_oneline('rev-parse', '--show-prefix');
192 $dir = abs_path($opts{Directory}) . '/';
193 if ($prefix) {
194 if (substr($dir, -length($prefix)) ne $prefix) {
195 throw Error::Simple("rev-parse confused me - $dir does not have trailing $prefix");
196 }
197 substr($dir, -length($prefix)) = '';
b1edc53d 198 }
d5c7721d
PB
199 $opts{WorkingCopy} = $dir;
200 $opts{WorkingSubdir} = $prefix;
201
202 } else {
203 # A bare repository? Let's see...
204 $dir = $opts{Directory};
205
206 unless (-d "$dir/refs" and -d "$dir/objects" and -e "$dir/HEAD") {
207 # Mimick git-rev-parse --git-dir error message:
f66bc5f9 208 throw Error::Simple("fatal: Not a git repository: $dir");
d5c7721d
PB
209 }
210 my $search = Git->repository(Repository => $dir);
211 try {
212 $search->command('symbolic-ref', 'HEAD');
213 } catch Git::Error::Command with {
214 # Mimick git-rev-parse --git-dir error message:
f66bc5f9 215 throw Error::Simple("fatal: Not a git repository: $dir");
d5c7721d
PB
216 }
217
218 $opts{Repository} = abs_path($dir);
b1edc53d 219 }
d5c7721d
PB
220
221 delete $opts{Directory};
b1edc53d
PB
222 }
223
81a71734 224 $self = { opts => \%opts };
b1edc53d
PB
225 bless $self, $class;
226}
227
b1edc53d
PB
228=back
229
230=head1 METHODS
231
232=over 4
233
234=item command ( COMMAND [, ARGUMENTS... ] )
235
d43ba468
PB
236=item command ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } )
237
b1edc53d
PB
238Execute the given Git C<COMMAND> (specify it without the 'git-'
239prefix), optionally with the specified extra C<ARGUMENTS>.
240
d43ba468
PB
241The second more elaborate form can be used if you want to further adjust
242the command execution. Currently, only one option is supported:
243
244B<STDERR> - How to deal with the command's error output. By default (C<undef>)
245it is delivered to the caller's C<STDERR>. A false value (0 or '') will cause
246it to be thrown away. If you want to process it, you can get it in a filehandle
247you specify, but you must be extremely careful; if the error output is not
248very short and you want to read it in the same process as where you called
249C<command()>, you are set up for a nice deadlock!
250
b1edc53d
PB
251The method can be called without any instance or on a specified Git repository
252(in that case the command will be run in the repository context).
253
254In scalar context, it returns all the command output in a single string
255(verbatim).
256
257In array context, it returns an array containing lines printed to the
258command's stdout (without trailing newlines).
259
260In both cases, the command's stdin and stderr are the same as the caller's.
261
262=cut
263
264sub command {
d79850e1 265 my ($fh, $ctx) = command_output_pipe(@_);
b1edc53d
PB
266
267 if (not defined wantarray) {
8b9150e3
PB
268 # Nothing to pepper the possible exception with.
269 _cmd_close($fh, $ctx);
b1edc53d
PB
270
271 } elsif (not wantarray) {
272 local $/;
273 my $text = <$fh>;
8b9150e3
PB
274 try {
275 _cmd_close($fh, $ctx);
276 } catch Git::Error::Command with {
277 # Pepper with the output:
278 my $E = shift;
279 $E->{'-outputref'} = \$text;
280 throw $E;
281 };
b1edc53d
PB
282 return $text;
283
284 } else {
285 my @lines = <$fh>;
67e4baf8 286 defined and chomp for @lines;
8b9150e3
PB
287 try {
288 _cmd_close($fh, $ctx);
289 } catch Git::Error::Command with {
290 my $E = shift;
291 $E->{'-outputref'} = \@lines;
292 throw $E;
293 };
b1edc53d
PB
294 return @lines;
295 }
296}
297
298
299=item command_oneline ( COMMAND [, ARGUMENTS... ] )
300
d43ba468
PB
301=item command_oneline ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } )
302
b1edc53d
PB
303Execute the given C<COMMAND> in the same way as command()
304does but always return a scalar string containing the first line
305of the command's standard output.
306
307=cut
308
309sub command_oneline {
d79850e1 310 my ($fh, $ctx) = command_output_pipe(@_);
b1edc53d
PB
311
312 my $line = <$fh>;
d5c7721d 313 defined $line and chomp $line;
8b9150e3
PB
314 try {
315 _cmd_close($fh, $ctx);
316 } catch Git::Error::Command with {
317 # Pepper with the output:
318 my $E = shift;
319 $E->{'-outputref'} = \$line;
320 throw $E;
321 };
b1edc53d
PB
322 return $line;
323}
324
325
d79850e1 326=item command_output_pipe ( COMMAND [, ARGUMENTS... ] )
b1edc53d 327
d43ba468
PB
328=item command_output_pipe ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } )
329
b1edc53d
PB
330Execute the given C<COMMAND> in the same way as command()
331does but return a pipe filehandle from which the command output can be
332read.
333
d79850e1
PB
334The function can return C<($pipe, $ctx)> in array context.
335See C<command_close_pipe()> for details.
336
b1edc53d
PB
337=cut
338
d79850e1
PB
339sub command_output_pipe {
340 _command_common_pipe('-|', @_);
341}
b1edc53d 342
b1edc53d 343
d79850e1
PB
344=item command_input_pipe ( COMMAND [, ARGUMENTS... ] )
345
d43ba468
PB
346=item command_input_pipe ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } )
347
d79850e1
PB
348Execute the given C<COMMAND> in the same way as command_output_pipe()
349does but return an input pipe filehandle instead; the command output
350is not captured.
351
352The function can return C<($pipe, $ctx)> in array context.
353See C<command_close_pipe()> for details.
354
355=cut
356
357sub command_input_pipe {
358 _command_common_pipe('|-', @_);
8b9150e3
PB
359}
360
361
362=item command_close_pipe ( PIPE [, CTX ] )
363
d79850e1 364Close the C<PIPE> as returned from C<command_*_pipe()>, checking
3dff5379 365whether the command finished successfully. The optional C<CTX> argument
8b9150e3 366is required if you want to see the command name in the error message,
d79850e1 367and it is the second value returned by C<command_*_pipe()> when
8b9150e3
PB
368called in array context. The call idiom is:
369
d79850e1
PB
370 my ($fh, $ctx) = $r->command_output_pipe('status');
371 while (<$fh>) { ... }
372 $r->command_close_pipe($fh, $ctx);
8b9150e3
PB
373
374Note that you should not rely on whatever actually is in C<CTX>;
375currently it is simply the command name but in future the context might
376have more complicated structure.
377
378=cut
379
380sub command_close_pipe {
381 my ($self, $fh, $ctx) = _maybe_self(@_);
382 $ctx ||= '<unknown>';
383 _cmd_close($fh, $ctx);
b1edc53d
PB
384}
385
d1a29af9
AR
386=item command_bidi_pipe ( COMMAND [, ARGUMENTS... ] )
387
388Execute the given C<COMMAND> in the same way as command_output_pipe()
389does but return both an input pipe filehandle and an output pipe filehandle.
390
391The function will return return C<($pid, $pipe_in, $pipe_out, $ctx)>.
392See C<command_close_bidi_pipe()> for details.
393
394=cut
395
396sub command_bidi_pipe {
397 my ($pid, $in, $out);
398 $pid = open2($in, $out, 'git', @_);
399 return ($pid, $in, $out, join(' ', @_));
400}
401
402=item command_close_bidi_pipe ( PID, PIPE_IN, PIPE_OUT [, CTX] )
403
404Close the C<PIPE_IN> and C<PIPE_OUT> as returned from C<command_bidi_pipe()>,
405checking whether the command finished successfully. The optional C<CTX>
406argument is required if you want to see the command name in the error message,
407and it is the fourth value returned by C<command_bidi_pipe()>. The call idiom
408is:
409
410 my ($pid, $in, $out, $ctx) = $r->command_bidi_pipe('cat-file --batch-check');
411 print "000000000\n" $out;
412 while (<$in>) { ... }
413 $r->command_close_bidi_pipe($pid, $in, $out, $ctx);
414
415Note that you should not rely on whatever actually is in C<CTX>;
416currently it is simply the command name but in future the context might
417have more complicated structure.
418
419=cut
420
421sub command_close_bidi_pipe {
108c2aaf 422 local $?;
d1a29af9
AR
423 my ($pid, $in, $out, $ctx) = @_;
424 foreach my $fh ($in, $out) {
425 unless (close $fh) {
426 if ($!) {
427 carp "error closing pipe: $!";
428 } elsif ($? >> 8) {
429 throw Git::Error::Command($ctx, $? >>8);
430 }
431 }
432 }
433
434 waitpid $pid, 0;
435
436 if ($? >> 8) {
437 throw Git::Error::Command($ctx, $? >>8);
438 }
439}
440
b1edc53d
PB
441
442=item command_noisy ( COMMAND [, ARGUMENTS... ] )
443
444Execute the given C<COMMAND> in the same way as command() does but do not
445capture the command output - the standard output is not redirected and goes
446to the standard output of the caller application.
447
448While the method is called command_noisy(), you might want to as well use
449it for the most silent Git commands which you know will never pollute your
450stdout but you want to avoid the overhead of the pipe setup when calling them.
451
452The function returns only after the command has finished running.
453
454=cut
455
456sub command_noisy {
457 my ($self, $cmd, @args) = _maybe_self(@_);
d79850e1 458 _check_valid_cmd($cmd);
b1edc53d
PB
459
460 my $pid = fork;
461 if (not defined $pid) {
97b16c06 462 throw Error::Simple("fork failed: $!");
b1edc53d
PB
463 } elsif ($pid == 0) {
464 _cmd_exec($self, $cmd, @args);
465 }
8b9150e3
PB
466 if (waitpid($pid, 0) > 0 and $?>>8 != 0) {
467 throw Git::Error::Command(join(' ', $cmd, @args), $? >> 8);
b1edc53d
PB
468 }
469}
470
471
63df97ae
PB
472=item version ()
473
474Return the Git version in use.
475
63df97ae
PB
476=cut
477
18b0fc1c
PB
478sub version {
479 my $verstr = command_oneline('--version');
480 $verstr =~ s/^git version //;
481 $verstr;
482}
63df97ae
PB
483
484
eca1f6fd
PB
485=item exec_path ()
486
d5c7721d 487Return path to the Git sub-command executables (the same as
eca1f6fd
PB
488C<git --exec-path>). Useful mostly only internally.
489
eca1f6fd
PB
490=cut
491
18b0fc1c 492sub exec_path { command_oneline('--exec-path') }
eca1f6fd
PB
493
494
d5c7721d
PB
495=item repo_path ()
496
497Return path to the git repository. Must be called on a repository instance.
498
499=cut
500
501sub repo_path { $_[0]->{opts}->{Repository} }
502
503
504=item wc_path ()
505
506Return path to the working copy. Must be called on a repository instance.
507
508=cut
509
510sub wc_path { $_[0]->{opts}->{WorkingCopy} }
511
512
513=item wc_subdir ()
514
515Return path to the subdirectory inside of a working copy. Must be called
516on a repository instance.
517
518=cut
519
520sub wc_subdir { $_[0]->{opts}->{WorkingSubdir} ||= '' }
521
522
523=item wc_chdir ( SUBDIR )
524
525Change the working copy subdirectory to work within. The C<SUBDIR> is
526relative to the working copy root directory (not the current subdirectory).
527Must be called on a repository instance attached to a working copy
528and the directory must exist.
529
530=cut
531
532sub wc_chdir {
533 my ($self, $subdir) = @_;
d5c7721d
PB
534 $self->wc_path()
535 or throw Error::Simple("bare repository");
536
537 -d $self->wc_path().'/'.$subdir
538 or throw Error::Simple("subdir not found: $!");
539 # Of course we will not "hold" the subdirectory so anyone
540 # can delete it now and we will never know. But at least we tried.
541
542 $self->{opts}->{WorkingSubdir} = $subdir;
543}
544
545
dc2613de
PB
546=item config ( VARIABLE )
547
e0d10e1c 548Retrieve the configuration C<VARIABLE> in the same manner as C<config>
dc2613de
PB
549does. In scalar context requires the variable to be set only one time
550(exception is thrown otherwise), in array context returns allows the
551variable to be set multiple times and returns all the values.
552
e0d10e1c 553This currently wraps command('config') so it is not so fast.
dc2613de
PB
554
555=cut
556
557sub config {
c2e357c2 558 my ($self, $var) = _maybe_self(@_);
dc2613de
PB
559
560 try {
c2e357c2
FL
561 my @cmd = ('config');
562 unshift @cmd, $self if $self;
dc2613de 563 if (wantarray) {
c2e357c2 564 return command(@cmd, '--get-all', $var);
dc2613de 565 } else {
c2e357c2 566 return command_oneline(@cmd, '--get', $var);
dc2613de
PB
567 }
568 } catch Git::Error::Command with {
569 my $E = shift;
570 if ($E->value() == 1) {
571 # Key not found.
32d8050a 572 return;
dc2613de
PB
573 } else {
574 throw $E;
575 }
576 };
577}
578
579
35c49eea 580=item config_bool ( VARIABLE )
7b9a13ec 581
35c49eea
PB
582Retrieve the bool configuration C<VARIABLE>. The return value
583is usable as a boolean in perl (and C<undef> if it's not defined,
584of course).
7b9a13ec 585
7b9a13ec
TT
586This currently wraps command('config') so it is not so fast.
587
588=cut
589
35c49eea 590sub config_bool {
c2e357c2 591 my ($self, $var) = _maybe_self(@_);
7b9a13ec
TT
592
593 try {
c2e357c2
FL
594 my @cmd = ('config', '--bool', '--get', $var);
595 unshift @cmd, $self if $self;
596 my $val = command_oneline(@cmd);
35c49eea
PB
597 return undef unless defined $val;
598 return $val eq 'true';
7b9a13ec
TT
599 } catch Git::Error::Command with {
600 my $E = shift;
601 if ($E->value() == 1) {
602 # Key not found.
603 return undef;
604 } else {
605 throw $E;
606 }
607 };
608}
609
346d203b
JN
610=item config_int ( VARIABLE )
611
612Retrieve the integer configuration C<VARIABLE>. The return value
613is simple decimal number. An optional value suffix of 'k', 'm',
614or 'g' in the config file will cause the value to be multiplied
615by 1024, 1048576 (1024^2), or 1073741824 (1024^3) prior to output.
616It would return C<undef> if configuration variable is not defined,
617
346d203b
JN
618This currently wraps command('config') so it is not so fast.
619
620=cut
621
622sub config_int {
c2e357c2 623 my ($self, $var) = _maybe_self(@_);
346d203b
JN
624
625 try {
c2e357c2
FL
626 my @cmd = ('config', '--int', '--get', $var);
627 unshift @cmd, $self if $self;
628 return command_oneline(@cmd);
346d203b
JN
629 } catch Git::Error::Command with {
630 my $E = shift;
631 if ($E->value() == 1) {
632 # Key not found.
633 return undef;
634 } else {
635 throw $E;
636 }
637 };
638}
7b9a13ec 639
b4c61ed6
JH
640=item get_colorbool ( NAME )
641
642Finds if color should be used for NAMEd operation from the configuration,
643and returns boolean (true for "use color", false for "do not use color").
644
645=cut
646
647sub get_colorbool {
648 my ($self, $var) = @_;
649 my $stdout_to_tty = (-t STDOUT) ? "true" : "false";
650 my $use_color = $self->command_oneline('config', '--get-colorbool',
651 $var, $stdout_to_tty);
652 return ($use_color eq 'true');
653}
654
655=item get_color ( SLOT, COLOR )
656
657Finds color for SLOT from the configuration, while defaulting to COLOR,
658and returns the ANSI color escape sequence:
659
660 print $repo->get_color("color.interactive.prompt", "underline blue white");
661 print "some text";
662 print $repo->get_color("", "normal");
663
664=cut
665
666sub get_color {
667 my ($self, $slot, $default) = @_;
668 my $color = $self->command_oneline('config', '--get-color', $slot, $default);
669 if (!defined $color) {
670 $color = "";
671 }
672 return $color;
673}
674
31a92f6a
PB
675=item remote_refs ( REPOSITORY [, GROUPS [, REFGLOBS ] ] )
676
677This function returns a hashref of refs stored in a given remote repository.
678The hash is in the format C<refname =\> hash>. For tags, the C<refname> entry
679contains the tag object while a C<refname^{}> entry gives the tagged objects.
680
681C<REPOSITORY> has the same meaning as the appropriate C<git-ls-remote>
682argument; either an URL or a remote name (if called on a repository instance).
683C<GROUPS> is an optional arrayref that can contain 'tags' to return all the
684tags and/or 'heads' to return all the heads. C<REFGLOB> is an optional array
685of strings containing a shell-like glob to further limit the refs returned in
686the hash; the meaning is again the same as the appropriate C<git-ls-remote>
687argument.
688
689This function may or may not be called on a repository instance. In the former
690case, remote names as defined in the repository are recognized as repository
691specifiers.
692
693=cut
694
695sub remote_refs {
696 my ($self, $repo, $groups, $refglobs) = _maybe_self(@_);
697 my @args;
698 if (ref $groups eq 'ARRAY') {
699 foreach (@$groups) {
700 if ($_ eq 'heads') {
701 push (@args, '--heads');
702 } elsif ($_ eq 'tags') {
703 push (@args, '--tags');
704 } else {
705 # Ignore unknown groups for future
706 # compatibility
707 }
708 }
709 }
710 push (@args, $repo);
711 if (ref $refglobs eq 'ARRAY') {
712 push (@args, @$refglobs);
713 }
714
715 my @self = $self ? ($self) : (); # Ultra trickery
716 my ($fh, $ctx) = Git::command_output_pipe(@self, 'ls-remote', @args);
717 my %refs;
718 while (<$fh>) {
719 chomp;
720 my ($hash, $ref) = split(/\t/, $_, 2);
721 $refs{$ref} = $hash;
722 }
723 Git::command_close_pipe(@self, $fh, $ctx);
724 return \%refs;
725}
726
727
c7a30e56
PB
728=item ident ( TYPE | IDENTSTR )
729
730=item ident_person ( TYPE | IDENTSTR | IDENTARRAY )
731
732This suite of functions retrieves and parses ident information, as stored
733in the commit and tag objects or produced by C<var GIT_type_IDENT> (thus
734C<TYPE> can be either I<author> or I<committer>; case is insignificant).
735
5354a56f 736The C<ident> method retrieves the ident information from C<git var>
c7a30e56
PB
737and either returns it as a scalar string or as an array with the fields parsed.
738Alternatively, it can take a prepared ident string (e.g. from the commit
739object) and just parse it.
740
741C<ident_person> returns the person part of the ident - name and email;
742it can take the same arguments as C<ident> or the array returned by C<ident>.
743
744The synopsis is like:
745
746 my ($name, $email, $time_tz) = ident('author');
747 "$name <$email>" eq ident_person('author');
748 "$name <$email>" eq ident_person($name);
749 $time_tz =~ /^\d+ [+-]\d{4}$/;
750
c7a30e56
PB
751=cut
752
753sub ident {
44617928 754 my ($self, $type) = _maybe_self(@_);
c7a30e56
PB
755 my $identstr;
756 if (lc $type eq lc 'committer' or lc $type eq lc 'author') {
44617928
FL
757 my @cmd = ('var', 'GIT_'.uc($type).'_IDENT');
758 unshift @cmd, $self if $self;
759 $identstr = command_oneline(@cmd);
c7a30e56
PB
760 } else {
761 $identstr = $type;
762 }
763 if (wantarray) {
764 return $identstr =~ /^(.*) <(.*)> (\d+ [+-]\d{4})$/;
765 } else {
766 return $identstr;
767 }
768}
769
770sub ident_person {
44617928
FL
771 my ($self, @ident) = _maybe_self(@_);
772 $#ident == 0 and @ident = $self ? $self->ident($ident[0]) : ident($ident[0]);
c7a30e56
PB
773 return "$ident[0] <$ident[1]>";
774}
775
776
24c4b714 777=item hash_object ( TYPE, FILENAME )
b1edc53d 778
58c8dd21
LW
779Compute the SHA1 object id of the given C<FILENAME> considering it is
780of the C<TYPE> object type (C<blob>, C<commit>, C<tree>).
b1edc53d 781
b1edc53d
PB
782The method can be called without any instance or on a specified Git repository,
783it makes zero difference.
784
785The function returns the SHA1 hash.
786
b1edc53d
PB
787=cut
788
18b0fc1c 789# TODO: Support for passing FILEHANDLE instead of FILENAME
e6634ac9
PB
790sub hash_object {
791 my ($self, $type, $file) = _maybe_self(@_);
18b0fc1c 792 command_oneline('hash-object', '-t', $type, $file);
e6634ac9 793}
b1edc53d
PB
794
795
7182530d
AR
796=item hash_and_insert_object ( FILENAME )
797
798Compute the SHA1 object id of the given C<FILENAME> and add the object to the
799object database.
800
801The function returns the SHA1 hash.
802
803=cut
804
805# TODO: Support for passing FILEHANDLE instead of FILENAME
806sub hash_and_insert_object {
807 my ($self, $filename) = @_;
808
809 carp "Bad filename \"$filename\"" if $filename =~ /[\r\n]/;
810
811 $self->_open_hash_and_insert_object_if_needed();
812 my ($in, $out) = ($self->{hash_object_in}, $self->{hash_object_out});
813
814 unless (print $out $filename, "\n") {
815 $self->_close_hash_and_insert_object();
816 throw Error::Simple("out pipe went bad");
817 }
818
819 chomp(my $hash = <$in>);
820 unless (defined($hash)) {
821 $self->_close_hash_and_insert_object();
822 throw Error::Simple("in pipe went bad");
823 }
824
825 return $hash;
826}
827
828sub _open_hash_and_insert_object_if_needed {
829 my ($self) = @_;
830
831 return if defined($self->{hash_object_pid});
832
833 ($self->{hash_object_pid}, $self->{hash_object_in},
834 $self->{hash_object_out}, $self->{hash_object_ctx}) =
835 command_bidi_pipe(qw(hash-object -w --stdin-paths));
836}
837
838sub _close_hash_and_insert_object {
839 my ($self) = @_;
840
841 return unless defined($self->{hash_object_pid});
842
843 my @vars = map { 'hash_object_' . $_ } qw(pid in out ctx);
844
452d36b1
AMS
845 command_close_bidi_pipe(@$self{@vars});
846 delete @$self{@vars};
7182530d
AR
847}
848
849=item cat_blob ( SHA1, FILEHANDLE )
850
851Prints the contents of the blob identified by C<SHA1> to C<FILEHANDLE> and
852returns the number of bytes printed.
853
854=cut
855
856sub cat_blob {
857 my ($self, $sha1, $fh) = @_;
858
859 $self->_open_cat_blob_if_needed();
860 my ($in, $out) = ($self->{cat_blob_in}, $self->{cat_blob_out});
861
862 unless (print $out $sha1, "\n") {
863 $self->_close_cat_blob();
864 throw Error::Simple("out pipe went bad");
865 }
866
867 my $description = <$in>;
868 if ($description =~ / missing$/) {
869 carp "$sha1 doesn't exist in the repository";
d683a0e0 870 return -1;
7182530d
AR
871 }
872
873 if ($description !~ /^[0-9a-fA-F]{40} \S+ (\d+)$/) {
874 carp "Unexpected result returned from git cat-file";
d683a0e0 875 return -1;
7182530d
AR
876 }
877
878 my $size = $1;
879
880 my $blob;
881 my $bytesRead = 0;
882
883 while (1) {
884 my $bytesLeft = $size - $bytesRead;
885 last unless $bytesLeft;
886
887 my $bytesToRead = $bytesLeft < 1024 ? $bytesLeft : 1024;
888 my $read = read($in, $blob, $bytesToRead, $bytesRead);
889 unless (defined($read)) {
890 $self->_close_cat_blob();
891 throw Error::Simple("in pipe went bad");
892 }
893
894 $bytesRead += $read;
895 }
896
897 # Skip past the trailing newline.
898 my $newline;
899 my $read = read($in, $newline, 1);
900 unless (defined($read)) {
901 $self->_close_cat_blob();
902 throw Error::Simple("in pipe went bad");
903 }
904 unless ($read == 1 && $newline eq "\n") {
905 $self->_close_cat_blob();
906 throw Error::Simple("didn't find newline after blob");
907 }
908
909 unless (print $fh $blob) {
910 $self->_close_cat_blob();
911 throw Error::Simple("couldn't write to passed in filehandle");
912 }
913
914 return $size;
915}
916
917sub _open_cat_blob_if_needed {
918 my ($self) = @_;
919
920 return if defined($self->{cat_blob_pid});
921
922 ($self->{cat_blob_pid}, $self->{cat_blob_in},
923 $self->{cat_blob_out}, $self->{cat_blob_ctx}) =
924 command_bidi_pipe(qw(cat-file --batch));
925}
926
927sub _close_cat_blob {
928 my ($self) = @_;
929
930 return unless defined($self->{cat_blob_pid});
931
932 my @vars = map { 'cat_blob_' . $_ } qw(pid in out ctx);
933
452d36b1
AMS
934 command_close_bidi_pipe(@$self{@vars});
935 delete @$self{@vars};
7182530d 936}
8b9150e3 937
e41352b2
MG
938
939{ # %TEMP_* Lexical Context
940
836ff95d 941my (%TEMP_FILEMAP, %TEMP_FILES);
e41352b2
MG
942
943=item temp_acquire ( NAME )
944
945Attempts to retreive the temporary file mapped to the string C<NAME>. If an
946associated temp file has not been created this session or was closed, it is
947created, cached, and set for autoflush and binmode.
948
949Internally locks the file mapped to C<NAME>. This lock must be released with
950C<temp_release()> when the temp file is no longer needed. Subsequent attempts
951to retrieve temporary files mapped to the same C<NAME> while still locked will
952cause an error. This locking mechanism provides a weak guarantee and is not
953threadsafe. It does provide some error checking to help prevent temp file refs
954writing over one another.
955
956In general, the L<File::Handle> returned should not be closed by consumers as
957it defeats the purpose of this caching mechanism. If you need to close the temp
958file handle, then you should use L<File::Temp> or another temp file faculty
959directly. If a handle is closed and then requested again, then a warning will
960issue.
961
962=cut
963
964sub temp_acquire {
bcdd1b44 965 my $temp_fd = _temp_cache(@_);
e41352b2 966
836ff95d 967 $TEMP_FILES{$temp_fd}{locked} = 1;
e41352b2
MG
968 $temp_fd;
969}
970
971=item temp_release ( NAME )
972
973=item temp_release ( FILEHANDLE )
974
975Releases a lock acquired through C<temp_acquire()>. Can be called either with
976the C<NAME> mapping used when acquiring the temp file or with the C<FILEHANDLE>
977referencing a locked temp file.
978
979Warns if an attempt is made to release a file that is not locked.
980
981The temp file will be truncated before being released. This can help to reduce
982disk I/O where the system is smart enough to detect the truncation while data
983is in the output buffers. Beware that after the temp file is released and
984truncated, any operations on that file may fail miserably until it is
985re-acquired. All contents are lost between each release and acquire mapped to
986the same string.
987
988=cut
989
990sub temp_release {
991 my ($self, $temp_fd, $trunc) = _maybe_self(@_);
992
836ff95d 993 if (exists $TEMP_FILEMAP{$temp_fd}) {
e41352b2
MG
994 $temp_fd = $TEMP_FILES{$temp_fd};
995 }
836ff95d 996 unless ($TEMP_FILES{$temp_fd}{locked}) {
e41352b2
MG
997 carp "Attempt to release temp file '",
998 $temp_fd, "' that has not been locked";
999 }
1000 temp_reset($temp_fd) if $trunc and $temp_fd->opened;
1001
836ff95d 1002 $TEMP_FILES{$temp_fd}{locked} = 0;
e41352b2
MG
1003 undef;
1004}
1005
1006sub _temp_cache {
bcdd1b44 1007 my ($self, $name) = _maybe_self(@_);
e41352b2 1008
c14c8ceb
MG
1009 _verify_require();
1010
836ff95d 1011 my $temp_fd = \$TEMP_FILEMAP{$name};
e41352b2 1012 if (defined $$temp_fd and $$temp_fd->opened) {
836ff95d 1013 if ($TEMP_FILES{$$temp_fd}{locked}) {
8faea4f3
JS
1014 throw Error::Simple("Temp file with moniker '" .
1015 $name . "' already in use");
e41352b2
MG
1016 }
1017 } else {
1018 if (defined $$temp_fd) {
1019 # then we're here because of a closed handle.
1020 carp "Temp file '", $name,
1021 "' was closed. Opening replacement.";
1022 }
836ff95d 1023 my $fname;
bcdd1b44
MS
1024
1025 my $tmpdir;
1026 if (defined $self) {
1027 $tmpdir = $self->repo_path();
1028 }
1029
836ff95d 1030 ($$temp_fd, $fname) = File::Temp->tempfile(
bcdd1b44 1031 'Git_XXXXXX', UNLINK => 1, DIR => $tmpdir,
e41352b2 1032 ) or throw Error::Simple("couldn't open new temp file");
bcdd1b44 1033
e41352b2
MG
1034 $$temp_fd->autoflush;
1035 binmode $$temp_fd;
836ff95d 1036 $TEMP_FILES{$$temp_fd}{fname} = $fname;
e41352b2
MG
1037 }
1038 $$temp_fd;
1039}
1040
c14c8ceb
MG
1041sub _verify_require {
1042 eval { require File::Temp; require File::Spec; };
1043 $@ and throw Error::Simple($@);
1044}
1045
e41352b2
MG
1046=item temp_reset ( FILEHANDLE )
1047
1048Truncates and resets the position of the C<FILEHANDLE>.
1049
1050=cut
1051
1052sub temp_reset {
1053 my ($self, $temp_fd) = _maybe_self(@_);
1054
1055 truncate $temp_fd, 0
1056 or throw Error::Simple("couldn't truncate file");
1057 sysseek($temp_fd, 0, SEEK_SET) and seek($temp_fd, 0, SEEK_SET)
1058 or throw Error::Simple("couldn't seek to beginning of file");
1059 sysseek($temp_fd, 0, SEEK_CUR) == 0 and tell($temp_fd) == 0
1060 or throw Error::Simple("expected file position to be reset");
1061}
1062
836ff95d
MG
1063=item temp_path ( NAME )
1064
1065=item temp_path ( FILEHANDLE )
1066
1067Returns the filename associated with the given tempfile.
1068
1069=cut
1070
1071sub temp_path {
1072 my ($self, $temp_fd) = _maybe_self(@_);
1073
1074 if (exists $TEMP_FILEMAP{$temp_fd}) {
1075 $temp_fd = $TEMP_FILEMAP{$temp_fd};
1076 }
1077 $TEMP_FILES{$temp_fd}{fname};
1078}
1079
e41352b2 1080sub END {
836ff95d 1081 unlink values %TEMP_FILEMAP if %TEMP_FILEMAP;
e41352b2
MG
1082}
1083
1084} # %TEMP_* Lexical Context
1085
b1edc53d
PB
1086=back
1087
97b16c06 1088=head1 ERROR HANDLING
b1edc53d 1089
97b16c06 1090All functions are supposed to throw Perl exceptions in case of errors.
8b9150e3
PB
1091See the L<Error> module on how to catch those. Most exceptions are mere
1092L<Error::Simple> instances.
1093
1094However, the C<command()>, C<command_oneline()> and C<command_noisy()>
1095functions suite can throw C<Git::Error::Command> exceptions as well: those are
1096thrown when the external command returns an error code and contain the error
1097code as well as access to the captured command's output. The exception class
1098provides the usual C<stringify> and C<value> (command's exit code) methods and
1099in addition also a C<cmd_output> method that returns either an array or a
1100string with the captured command output (depending on the original function
1101call context; C<command_noisy()> returns C<undef>) and $<cmdline> which
1102returns the command and its arguments (but without proper quoting).
1103
d79850e1 1104Note that the C<command_*_pipe()> functions cannot throw this exception since
8b9150e3
PB
1105it has no idea whether the command failed or not. You will only find out
1106at the time you C<close> the pipe; if you want to have that automated,
1107use C<command_close_pipe()>, which can throw the exception.
1108
1109=cut
1110
1111{
1112 package Git::Error::Command;
1113
1114 @Git::Error::Command::ISA = qw(Error);
1115
1116 sub new {
1117 my $self = shift;
1118 my $cmdline = '' . shift;
1119 my $value = 0 + shift;
1120 my $outputref = shift;
1121 my(@args) = ();
1122
1123 local $Error::Depth = $Error::Depth + 1;
1124
1125 push(@args, '-cmdline', $cmdline);
1126 push(@args, '-value', $value);
1127 push(@args, '-outputref', $outputref);
1128
1129 $self->SUPER::new(-text => 'command returned error', @args);
1130 }
1131
1132 sub stringify {
1133 my $self = shift;
1134 my $text = $self->SUPER::stringify;
1135 $self->cmdline() . ': ' . $text . ': ' . $self->value() . "\n";
1136 }
1137
1138 sub cmdline {
1139 my $self = shift;
1140 $self->{'-cmdline'};
1141 }
1142
1143 sub cmd_output {
1144 my $self = shift;
1145 my $ref = $self->{'-outputref'};
1146 defined $ref or undef;
1147 if (ref $ref eq 'ARRAY') {
1148 return @$ref;
1149 } else { # SCALAR
1150 return $$ref;
1151 }
1152 }
1153}
1154
1155=over 4
1156
1157=item git_cmd_try { CODE } ERRMSG
1158
1159This magical statement will automatically catch any C<Git::Error::Command>
1160exceptions thrown by C<CODE> and make your program die with C<ERRMSG>
1161on its lips; the message will have %s substituted for the command line
1162and %d for the exit status. This statement is useful mostly for producing
1163more user-friendly error messages.
1164
1165In case of no exception caught the statement returns C<CODE>'s return value.
1166
1167Note that this is the only auto-exported function.
1168
1169=cut
1170
1171sub git_cmd_try(&$) {
1172 my ($code, $errmsg) = @_;
1173 my @result;
1174 my $err;
1175 my $array = wantarray;
1176 try {
1177 if ($array) {
1178 @result = &$code;
1179 } else {
1180 $result[0] = &$code;
1181 }
1182 } catch Git::Error::Command with {
1183 my $E = shift;
1184 $err = $errmsg;
1185 $err =~ s/\%s/$E->cmdline()/ge;
1186 $err =~ s/\%d/$E->value()/ge;
1187 # We can't croak here since Error.pm would mangle
1188 # that to Error::Simple.
1189 };
1190 $err and croak $err;
1191 return $array ? @result : $result[0];
1192}
1193
1194
1195=back
b1edc53d
PB
1196
1197=head1 COPYRIGHT
1198
1199Copyright 2006 by Petr Baudis E<lt>pasky@suse.czE<gt>.
1200
1201This module is free software; it may be used, copied, modified
1202and distributed under the terms of the GNU General Public Licence,
1203either version 2, or (at your option) any later version.
1204
1205=cut
1206
1207
1208# Take raw method argument list and return ($obj, @args) in case
1209# the method was called upon an instance and (undef, @args) if
1210# it was called directly.
1211sub _maybe_self {
d8b24b93 1212 UNIVERSAL::isa($_[0], 'Git') ? @_ : (undef, @_);
b1edc53d
PB
1213}
1214
d79850e1
PB
1215# Check if the command id is something reasonable.
1216sub _check_valid_cmd {
1217 my ($cmd) = @_;
1218 $cmd =~ /^[a-z0-9A-Z_-]+$/ or throw Error::Simple("bad command: $cmd");
1219}
1220
1221# Common backend for the pipe creators.
1222sub _command_common_pipe {
1223 my $direction = shift;
d43ba468
PB
1224 my ($self, @p) = _maybe_self(@_);
1225 my (%opts, $cmd, @args);
1226 if (ref $p[0]) {
1227 ($cmd, @args) = @{shift @p};
1228 %opts = ref $p[0] ? %{$p[0]} : @p;
1229 } else {
1230 ($cmd, @args) = @p;
1231 }
d79850e1
PB
1232 _check_valid_cmd($cmd);
1233
a6065b54 1234 my $fh;
d3b1785f 1235 if ($^O eq 'MSWin32') {
a6065b54
PB
1236 # ActiveState Perl
1237 #defined $opts{STDERR} and
1238 # warn 'ignoring STDERR option - running w/ ActiveState';
1239 $direction eq '-|' or
1240 die 'input pipe for ActiveState not implemented';
bed118d6
AR
1241 # the strange construction with *ACPIPE is just to
1242 # explain the tie below that we want to bind to
1243 # a handle class, not scalar. It is not known if
1244 # it is something specific to ActiveState Perl or
1245 # just a Perl quirk.
1246 tie (*ACPIPE, 'Git::activestate_pipe', $cmd, @args);
1247 $fh = *ACPIPE;
a6065b54
PB
1248
1249 } else {
1250 my $pid = open($fh, $direction);
1251 if (not defined $pid) {
1252 throw Error::Simple("open failed: $!");
1253 } elsif ($pid == 0) {
1254 if (defined $opts{STDERR}) {
1255 close STDERR;
1256 }
1257 if ($opts{STDERR}) {
1258 open (STDERR, '>&', $opts{STDERR})
1259 or die "dup failed: $!";
1260 }
1261 _cmd_exec($self, $cmd, @args);
d43ba468 1262 }
d79850e1
PB
1263 }
1264 return wantarray ? ($fh, join(' ', $cmd, @args)) : $fh;
1265}
1266
b1edc53d
PB
1267# When already in the subprocess, set up the appropriate state
1268# for the given repository and execute the git command.
1269sub _cmd_exec {
1270 my ($self, @args) = @_;
1271 if ($self) {
d5c7721d
PB
1272 $self->repo_path() and $ENV{'GIT_DIR'} = $self->repo_path();
1273 $self->wc_path() and chdir($self->wc_path());
1274 $self->wc_subdir() and chdir($self->wc_subdir());
b1edc53d 1275 }
97b16c06 1276 _execv_git_cmd(@args);
6aaa65da 1277 die qq[exec "@args" failed: $!];
b1edc53d
PB
1278}
1279
8062f81c
PB
1280# Execute the given Git command ($_[0]) with arguments ($_[1..])
1281# by searching for it at proper places.
18b0fc1c 1282sub _execv_git_cmd { exec('git', @_); }
8062f81c 1283
b1edc53d
PB
1284# Close pipe to a subprocess.
1285sub _cmd_close {
8b9150e3 1286 my ($fh, $ctx) = @_;
b1edc53d
PB
1287 if (not close $fh) {
1288 if ($!) {
1289 # It's just close, no point in fatalities
1290 carp "error closing pipe: $!";
1291 } elsif ($? >> 8) {
8b9150e3
PB
1292 # The caller should pepper this.
1293 throw Git::Error::Command($ctx, $? >> 8);
b1edc53d
PB
1294 }
1295 # else we might e.g. closed a live stream; the command
1296 # dying of SIGPIPE would drive us here.
1297 }
1298}
1299
1300
7182530d
AR
1301sub DESTROY {
1302 my ($self) = @_;
1303 $self->_close_hash_and_insert_object();
1304 $self->_close_cat_blob();
1305}
b1edc53d
PB
1306
1307
a6065b54
PB
1308# Pipe implementation for ActiveState Perl.
1309
1310package Git::activestate_pipe;
1311use strict;
1312
1313sub TIEHANDLE {
1314 my ($class, @params) = @_;
1315 # FIXME: This is probably horrible idea and the thing will explode
1316 # at the moment you give it arguments that require some quoting,
1317 # but I have no ActiveState clue... --pasky
d3b1785f
AR
1318 # Let's just hope ActiveState Perl does at least the quoting
1319 # correctly.
1320 my @data = qx{git @params};
a6065b54
PB
1321 bless { i => 0, data => \@data }, $class;
1322}
1323
1324sub READLINE {
1325 my $self = shift;
1326 if ($self->{i} >= scalar @{$self->{data}}) {
1327 return undef;
1328 }
2f5b3980
AR
1329 my $i = $self->{i};
1330 if (wantarray) {
1331 $self->{i} = $#{$self->{'data'}} + 1;
1332 return splice(@{$self->{'data'}}, $i);
1333 }
1334 $self->{i} = $i + 1;
1335 return $self->{'data'}->[ $i ];
a6065b54
PB
1336}
1337
1338sub CLOSE {
1339 my $self = shift;
1340 delete $self->{data};
1341 delete $self->{i};
1342}
1343
1344sub EOF {
1345 my $self = shift;
1346 return ($self->{i} >= scalar @{$self->{data}});
1347}
1348
1349
b1edc53d 13501; # Famous last words