Merge branch 'nd/init-relative-template-fix' into maint
[git] / perl / Git.pm
1 =head1 NAME
2
3 Git - Perl interface to the Git version control system
4
5 =cut
6
7
8 package Git;
9
10 use 5.008;
11 use strict;
12 use warnings;
13
14 use File::Temp ();
15 use File::Spec ();
16
17 BEGIN {
18
19 our ($VERSION, @ISA, @EXPORT, @EXPORT_OK);
20
21 # Totally unstable API.
22 $VERSION = '0.01';
23
24
25 =head1 SYNOPSIS
26
27   use Git;
28
29   my $version = Git::command_oneline('version');
30
31   git_cmd_try { Git::command_noisy('update-server-info') }
32               '%s failed w/ code %d';
33
34   my $repo = Git->repository (Directory => '/srv/git/cogito.git');
35
36
37   my @revs = $repo->command('rev-list', '--since=last monday', '--all');
38
39   my ($fh, $c) = $repo->command_output_pipe('rev-list', '--since=last monday', '--all');
40   my $lastrev = <$fh>; chomp $lastrev;
41   $repo->command_close_pipe($fh, $c);
42
43   my $lastrev = $repo->command_oneline( [ 'rev-list', '--all' ],
44                                         STDERR => 0 );
45
46   my $sha1 = $repo->hash_and_insert_object('file.txt');
47   my $tempfile = tempfile();
48   my $size = $repo->cat_blob($sha1, $tempfile);
49
50 =cut
51
52
53 require Exporter;
54
55 @ISA = qw(Exporter);
56
57 @EXPORT = qw(git_cmd_try);
58
59 # Methods which can be called as standalone functions as well:
60 @EXPORT_OK = qw(command command_oneline command_noisy
61                 command_output_pipe command_input_pipe command_close_pipe
62                 command_bidi_pipe command_close_bidi_pipe
63                 version exec_path html_path hash_object git_cmd_try
64                 remote_refs prompt
65                 get_tz_offset get_record
66                 credential credential_read credential_write
67                 temp_acquire temp_is_locked temp_release temp_reset temp_path
68                 unquote_path);
69
70
71 =head1 DESCRIPTION
72
73 This module provides Perl scripts easy way to interface the Git version control
74 system. The modules have an easy and well-tested way to call arbitrary Git
75 commands; in the future, the interface will also provide specialized methods
76 for doing easily operations which are not totally trivial to do over
77 the generic command interface.
78
79 While some commands can be executed outside of any context (e.g. 'version'
80 or 'init'), most operations require a repository context, which in practice
81 means getting an instance of the Git object using the repository() constructor.
82 (In the future, we will also get a new_repository() constructor.) All commands
83 called as methods of the object are then executed in the context of the
84 repository.
85
86 Part of the "repository state" is also information about path to the attached
87 working copy (unless you work with a bare repository). You can also navigate
88 inside of the working copy using the C<wc_chdir()> method. (Note that
89 the repository object is self-contained and will not change working directory
90 of your process.)
91
92 TODO: In the future, we might also do
93
94         my $remoterepo = $repo->remote_repository (Name => 'cogito', Branch => 'master');
95         $remoterepo ||= Git->remote_repository ('http://git.or.cz/cogito.git/');
96         my @refs = $remoterepo->refs();
97
98 Currently, the module merely wraps calls to external Git tools. In the future,
99 it will provide a much faster way to interact with Git by linking directly
100 to libgit. This should be completely opaque to the user, though (performance
101 increase notwithstanding).
102
103 =cut
104
105
106 use Carp qw(carp croak); # but croak is bad - throw instead
107 use Git::LoadCPAN::Error qw(:try);
108 use Cwd qw(abs_path cwd);
109 use IPC::Open2 qw(open2);
110 use Fcntl qw(SEEK_SET SEEK_CUR);
111 use Time::Local qw(timegm);
112 }
113
114
115 =head1 CONSTRUCTORS
116
117 =over 4
118
119 =item repository ( OPTIONS )
120
121 =item repository ( DIRECTORY )
122
123 =item repository ()
124
125 Construct a new repository object.
126 C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
127 Possible options are:
128
129 B<Repository> - Path to the Git repository.
130
131 B<WorkingCopy> - Path to the associated working copy; not strictly required
132 as many commands will happily crunch on a bare repository.
133
134 B<WorkingSubdir> - Subdirectory in the working copy to work inside.
135 Just left undefined if you do not want to limit the scope of operations.
136
137 B<Directory> - Path to the Git working directory in its usual setup.
138 The C<.git> directory is searched in the directory and all the parent
139 directories; if found, C<WorkingCopy> is set to the directory containing
140 it and C<Repository> to the C<.git> directory itself. If no C<.git>
141 directory was found, the C<Directory> is assumed to be a bare repository,
142 C<Repository> is set to point at it and C<WorkingCopy> is left undefined.
143 If the C<$GIT_DIR> environment variable is set, things behave as expected
144 as well.
145
146 You should not use both C<Directory> and either of C<Repository> and
147 C<WorkingCopy> - the results of that are undefined.
148
149 Alternatively, a directory path may be passed as a single scalar argument
150 to the constructor; it is equivalent to setting only the C<Directory> option
151 field.
152
153 Calling the constructor with no options whatsoever is equivalent to
154 calling it with C<< Directory => '.' >>. In general, if you are building
155 a standard porcelain command, simply doing C<< Git->repository() >> should
156 do the right thing and setup the object to reflect exactly where the user
157 is right now.
158
159 =cut
160
161 sub repository {
162         my $class = shift;
163         my @args = @_;
164         my %opts = ();
165         my $self;
166
167         if (defined $args[0]) {
168                 if ($#args % 2 != 1) {
169                         # Not a hash.
170                         $#args == 0 or throw Error::Simple("bad usage");
171                         %opts = ( Directory => $args[0] );
172                 } else {
173                         %opts = @args;
174                 }
175         }
176
177         if (not defined $opts{Repository} and not defined $opts{WorkingCopy}
178                 and not defined $opts{Directory}) {
179                 $opts{Directory} = '.';
180         }
181
182         if (defined $opts{Directory}) {
183                 -d $opts{Directory} or throw Error::Simple("Directory not found: $opts{Directory} $!");
184
185                 my $search = Git->repository(WorkingCopy => $opts{Directory});
186                 my $dir;
187                 try {
188                         $dir = $search->command_oneline(['rev-parse', '--git-dir'],
189                                                         STDERR => 0);
190                 } catch Git::Error::Command with {
191                         $dir = undef;
192                 };
193
194                 if ($dir) {
195                         File::Spec->file_name_is_absolute($dir) or $dir = $opts{Directory} . '/' . $dir;
196                         $opts{Repository} = abs_path($dir);
197
198                         # If --git-dir went ok, this shouldn't die either.
199                         my $prefix = $search->command_oneline('rev-parse', '--show-prefix');
200                         $dir = abs_path($opts{Directory}) . '/';
201                         if ($prefix) {
202                                 if (substr($dir, -length($prefix)) ne $prefix) {
203                                         throw Error::Simple("rev-parse confused me - $dir does not have trailing $prefix");
204                                 }
205                                 substr($dir, -length($prefix)) = '';
206                         }
207                         $opts{WorkingCopy} = $dir;
208                         $opts{WorkingSubdir} = $prefix;
209
210                 } else {
211                         # A bare repository? Let's see...
212                         $dir = $opts{Directory};
213
214                         unless (-d "$dir/refs" and -d "$dir/objects" and -e "$dir/HEAD") {
215                                 # Mimic git-rev-parse --git-dir error message:
216                                 throw Error::Simple("fatal: Not a git repository: $dir");
217                         }
218                         my $search = Git->repository(Repository => $dir);
219                         try {
220                                 $search->command('symbolic-ref', 'HEAD');
221                         } catch Git::Error::Command with {
222                                 # Mimic git-rev-parse --git-dir error message:
223                                 throw Error::Simple("fatal: Not a git repository: $dir");
224                         }
225
226                         $opts{Repository} = abs_path($dir);
227                 }
228
229                 delete $opts{Directory};
230         }
231
232         $self = { opts => \%opts };
233         bless $self, $class;
234 }
235
236 =back
237
238 =head1 METHODS
239
240 =over 4
241
242 =item command ( COMMAND [, ARGUMENTS... ] )
243
244 =item command ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } )
245
246 Execute the given Git C<COMMAND> (specify it without the 'git-'
247 prefix), optionally with the specified extra C<ARGUMENTS>.
248
249 The second more elaborate form can be used if you want to further adjust
250 the command execution. Currently, only one option is supported:
251
252 B<STDERR> - How to deal with the command's error output. By default (C<undef>)
253 it is delivered to the caller's C<STDERR>. A false value (0 or '') will cause
254 it to be thrown away. If you want to process it, you can get it in a filehandle
255 you specify, but you must be extremely careful; if the error output is not
256 very short and you want to read it in the same process as where you called
257 C<command()>, you are set up for a nice deadlock!
258
259 The method can be called without any instance or on a specified Git repository
260 (in that case the command will be run in the repository context).
261
262 In scalar context, it returns all the command output in a single string
263 (verbatim).
264
265 In array context, it returns an array containing lines printed to the
266 command's stdout (without trailing newlines).
267
268 In both cases, the command's stdin and stderr are the same as the caller's.
269
270 =cut
271
272 sub command {
273         my ($fh, $ctx) = command_output_pipe(@_);
274
275         if (not defined wantarray) {
276                 # Nothing to pepper the possible exception with.
277                 _cmd_close($ctx, $fh);
278
279         } elsif (not wantarray) {
280                 local $/;
281                 my $text = <$fh>;
282                 try {
283                         _cmd_close($ctx, $fh);
284                 } catch Git::Error::Command with {
285                         # Pepper with the output:
286                         my $E = shift;
287                         $E->{'-outputref'} = \$text;
288                         throw $E;
289                 };
290                 return $text;
291
292         } else {
293                 my @lines = <$fh>;
294                 defined and chomp for @lines;
295                 try {
296                         _cmd_close($ctx, $fh);
297                 } catch Git::Error::Command with {
298                         my $E = shift;
299                         $E->{'-outputref'} = \@lines;
300                         throw $E;
301                 };
302                 return @lines;
303         }
304 }
305
306
307 =item command_oneline ( COMMAND [, ARGUMENTS... ] )
308
309 =item command_oneline ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } )
310
311 Execute the given C<COMMAND> in the same way as command()
312 does but always return a scalar string containing the first line
313 of the command's standard output.
314
315 =cut
316
317 sub command_oneline {
318         my ($fh, $ctx) = command_output_pipe(@_);
319
320         my $line = <$fh>;
321         defined $line and chomp $line;
322         try {
323                 _cmd_close($ctx, $fh);
324         } catch Git::Error::Command with {
325                 # Pepper with the output:
326                 my $E = shift;
327                 $E->{'-outputref'} = \$line;
328                 throw $E;
329         };
330         return $line;
331 }
332
333
334 =item command_output_pipe ( COMMAND [, ARGUMENTS... ] )
335
336 =item command_output_pipe ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } )
337
338 Execute the given C<COMMAND> in the same way as command()
339 does but return a pipe filehandle from which the command output can be
340 read.
341
342 The function can return C<($pipe, $ctx)> in array context.
343 See C<command_close_pipe()> for details.
344
345 =cut
346
347 sub command_output_pipe {
348         _command_common_pipe('-|', @_);
349 }
350
351
352 =item command_input_pipe ( COMMAND [, ARGUMENTS... ] )
353
354 =item command_input_pipe ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } )
355
356 Execute the given C<COMMAND> in the same way as command_output_pipe()
357 does but return an input pipe filehandle instead; the command output
358 is not captured.
359
360 The function can return C<($pipe, $ctx)> in array context.
361 See C<command_close_pipe()> for details.
362
363 =cut
364
365 sub command_input_pipe {
366         _command_common_pipe('|-', @_);
367 }
368
369
370 =item command_close_pipe ( PIPE [, CTX ] )
371
372 Close the C<PIPE> as returned from C<command_*_pipe()>, checking
373 whether the command finished successfully. The optional C<CTX> argument
374 is required if you want to see the command name in the error message,
375 and it is the second value returned by C<command_*_pipe()> when
376 called in array context. The call idiom is:
377
378         my ($fh, $ctx) = $r->command_output_pipe('status');
379         while (<$fh>) { ... }
380         $r->command_close_pipe($fh, $ctx);
381
382 Note that you should not rely on whatever actually is in C<CTX>;
383 currently it is simply the command name but in future the context might
384 have more complicated structure.
385
386 =cut
387
388 sub command_close_pipe {
389         my ($self, $fh, $ctx) = _maybe_self(@_);
390         $ctx ||= '<unknown>';
391         _cmd_close($ctx, $fh);
392 }
393
394 =item command_bidi_pipe ( COMMAND [, ARGUMENTS... ] )
395
396 Execute the given C<COMMAND> in the same way as command_output_pipe()
397 does but return both an input pipe filehandle and an output pipe filehandle.
398
399 The function will return C<($pid, $pipe_in, $pipe_out, $ctx)>.
400 See C<command_close_bidi_pipe()> for details.
401
402 =cut
403
404 sub command_bidi_pipe {
405         my ($pid, $in, $out);
406         my ($self) = _maybe_self(@_);
407         local %ENV = %ENV;
408         my $cwd_save = undef;
409         if ($self) {
410                 shift;
411                 $cwd_save = cwd();
412                 _setup_git_cmd_env($self);
413         }
414         $pid = open2($in, $out, 'git', @_);
415         chdir($cwd_save) if $cwd_save;
416         return ($pid, $in, $out, join(' ', @_));
417 }
418
419 =item command_close_bidi_pipe ( PID, PIPE_IN, PIPE_OUT [, CTX] )
420
421 Close the C<PIPE_IN> and C<PIPE_OUT> as returned from C<command_bidi_pipe()>,
422 checking whether the command finished successfully. The optional C<CTX>
423 argument is required if you want to see the command name in the error message,
424 and it is the fourth value returned by C<command_bidi_pipe()>.  The call idiom
425 is:
426
427         my ($pid, $in, $out, $ctx) = $r->command_bidi_pipe('cat-file --batch-check');
428         print $out "000000000\n";
429         while (<$in>) { ... }
430         $r->command_close_bidi_pipe($pid, $in, $out, $ctx);
431
432 Note that you should not rely on whatever actually is in C<CTX>;
433 currently it is simply the command name but in future the context might
434 have more complicated structure.
435
436 C<PIPE_IN> and C<PIPE_OUT> may be C<undef> if they have been closed prior to
437 calling this function.  This may be useful in a query-response type of
438 commands where caller first writes a query and later reads response, eg:
439
440         my ($pid, $in, $out, $ctx) = $r->command_bidi_pipe('cat-file --batch-check');
441         print $out "000000000\n";
442         close $out;
443         while (<$in>) { ... }
444         $r->command_close_bidi_pipe($pid, $in, undef, $ctx);
445
446 This idiom may prevent potential dead locks caused by data sent to the output
447 pipe not being flushed and thus not reaching the executed command.
448
449 =cut
450
451 sub command_close_bidi_pipe {
452         local $?;
453         my ($self, $pid, $in, $out, $ctx) = _maybe_self(@_);
454         _cmd_close($ctx, (grep { defined } ($in, $out)));
455         waitpid $pid, 0;
456         if ($? >> 8) {
457                 throw Git::Error::Command($ctx, $? >>8);
458         }
459 }
460
461
462 =item command_noisy ( COMMAND [, ARGUMENTS... ] )
463
464 Execute the given C<COMMAND> in the same way as command() does but do not
465 capture the command output - the standard output is not redirected and goes
466 to the standard output of the caller application.
467
468 While the method is called command_noisy(), you might want to as well use
469 it for the most silent Git commands which you know will never pollute your
470 stdout but you want to avoid the overhead of the pipe setup when calling them.
471
472 The function returns only after the command has finished running.
473
474 =cut
475
476 sub command_noisy {
477         my ($self, $cmd, @args) = _maybe_self(@_);
478         _check_valid_cmd($cmd);
479
480         my $pid = fork;
481         if (not defined $pid) {
482                 throw Error::Simple("fork failed: $!");
483         } elsif ($pid == 0) {
484                 _cmd_exec($self, $cmd, @args);
485         }
486         if (waitpid($pid, 0) > 0 and $?>>8 != 0) {
487                 throw Git::Error::Command(join(' ', $cmd, @args), $? >> 8);
488         }
489 }
490
491
492 =item version ()
493
494 Return the Git version in use.
495
496 =cut
497
498 sub version {
499         my $verstr = command_oneline('--version');
500         $verstr =~ s/^git version //;
501         $verstr;
502 }
503
504
505 =item exec_path ()
506
507 Return path to the Git sub-command executables (the same as
508 C<git --exec-path>). Useful mostly only internally.
509
510 =cut
511
512 sub exec_path { command_oneline('--exec-path') }
513
514
515 =item html_path ()
516
517 Return path to the Git html documentation (the same as
518 C<git --html-path>). Useful mostly only internally.
519
520 =cut
521
522 sub html_path { command_oneline('--html-path') }
523
524
525 =item get_tz_offset ( TIME )
526
527 Return the time zone offset from GMT in the form +/-HHMM where HH is
528 the number of hours from GMT and MM is the number of minutes.  This is
529 the equivalent of what strftime("%z", ...) would provide on a GNU
530 platform.
531
532 If TIME is not supplied, the current local time is used.
533
534 =cut
535
536 sub get_tz_offset {
537         # some systems don't handle or mishandle %z, so be creative.
538         my $t = shift || time;
539         my @t = localtime($t);
540         $t[5] += 1900;
541         my $gm = timegm(@t);
542         my $sign = qw( + + - )[ $gm <=> $t ];
543         return sprintf("%s%02d%02d", $sign, (gmtime(abs($t - $gm)))[2,1]);
544 }
545
546 =item get_record ( FILEHANDLE, INPUT_RECORD_SEPARATOR )
547
548 Read one record from FILEHANDLE delimited by INPUT_RECORD_SEPARATOR,
549 removing any trailing INPUT_RECORD_SEPARATOR.
550
551 =cut
552
553 sub get_record {
554         my ($fh, $rs) = @_;
555         local $/ = $rs;
556         my $rec = <$fh>;
557         chomp $rec if defined $rec;
558         $rec;
559 }
560
561 =item prompt ( PROMPT , ISPASSWORD  )
562
563 Query user C<PROMPT> and return answer from user.
564
565 Honours GIT_ASKPASS and SSH_ASKPASS environment variables for querying
566 the user. If no *_ASKPASS variable is set or an error occoured,
567 the terminal is tried as a fallback.
568 If C<ISPASSWORD> is set and true, the terminal disables echo.
569
570 =cut
571
572 sub prompt {
573         my ($prompt, $isPassword) = @_;
574         my $ret;
575         if (exists $ENV{'GIT_ASKPASS'}) {
576                 $ret = _prompt($ENV{'GIT_ASKPASS'}, $prompt);
577         }
578         if (!defined $ret && exists $ENV{'SSH_ASKPASS'}) {
579                 $ret = _prompt($ENV{'SSH_ASKPASS'}, $prompt);
580         }
581         if (!defined $ret) {
582                 print STDERR $prompt;
583                 STDERR->flush;
584                 if (defined $isPassword && $isPassword) {
585                         require Term::ReadKey;
586                         Term::ReadKey::ReadMode('noecho');
587                         $ret = '';
588                         while (defined(my $key = Term::ReadKey::ReadKey(0))) {
589                                 last if $key =~ /[\012\015]/; # \n\r
590                                 $ret .= $key;
591                         }
592                         Term::ReadKey::ReadMode('restore');
593                         print STDERR "\n";
594                         STDERR->flush;
595                 } else {
596                         chomp($ret = <STDIN>);
597                 }
598         }
599         return $ret;
600 }
601
602 sub _prompt {
603         my ($askpass, $prompt) = @_;
604         return unless length $askpass;
605         $prompt =~ s/\n/ /g;
606         my $ret;
607         open my $fh, "-|", $askpass, $prompt or return;
608         $ret = <$fh>;
609         $ret =~ s/[\015\012]//g; # strip \r\n, chomp does not work on all systems (i.e. windows) as expected
610         close ($fh);
611         return $ret;
612 }
613
614 =item repo_path ()
615
616 Return path to the git repository. Must be called on a repository instance.
617
618 =cut
619
620 sub repo_path { $_[0]->{opts}->{Repository} }
621
622
623 =item wc_path ()
624
625 Return path to the working copy. Must be called on a repository instance.
626
627 =cut
628
629 sub wc_path { $_[0]->{opts}->{WorkingCopy} }
630
631
632 =item wc_subdir ()
633
634 Return path to the subdirectory inside of a working copy. Must be called
635 on a repository instance.
636
637 =cut
638
639 sub wc_subdir { $_[0]->{opts}->{WorkingSubdir} ||= '' }
640
641
642 =item wc_chdir ( SUBDIR )
643
644 Change the working copy subdirectory to work within. The C<SUBDIR> is
645 relative to the working copy root directory (not the current subdirectory).
646 Must be called on a repository instance attached to a working copy
647 and the directory must exist.
648
649 =cut
650
651 sub wc_chdir {
652         my ($self, $subdir) = @_;
653         $self->wc_path()
654                 or throw Error::Simple("bare repository");
655
656         -d $self->wc_path().'/'.$subdir
657                 or throw Error::Simple("subdir not found: $subdir $!");
658         # Of course we will not "hold" the subdirectory so anyone
659         # can delete it now and we will never know. But at least we tried.
660
661         $self->{opts}->{WorkingSubdir} = $subdir;
662 }
663
664
665 =item config ( VARIABLE )
666
667 Retrieve the configuration C<VARIABLE> in the same manner as C<config>
668 does. In scalar context requires the variable to be set only one time
669 (exception is thrown otherwise), in array context returns allows the
670 variable to be set multiple times and returns all the values.
671
672 =cut
673
674 sub config {
675         return _config_common({}, @_);
676 }
677
678
679 =item config_bool ( VARIABLE )
680
681 Retrieve the bool configuration C<VARIABLE>. The return value
682 is usable as a boolean in perl (and C<undef> if it's not defined,
683 of course).
684
685 =cut
686
687 sub config_bool {
688         my $val = scalar _config_common({'kind' => '--bool'}, @_);
689
690         # Do not rewrite this as return (defined $val && $val eq 'true')
691         # as some callers do care what kind of falsehood they receive.
692         if (!defined $val) {
693                 return undef;
694         } else {
695                 return $val eq 'true';
696         }
697 }
698
699
700 =item config_path ( VARIABLE )
701
702 Retrieve the path configuration C<VARIABLE>. The return value
703 is an expanded path or C<undef> if it's not defined.
704
705 =cut
706
707 sub config_path {
708         return _config_common({'kind' => '--path'}, @_);
709 }
710
711
712 =item config_int ( VARIABLE )
713
714 Retrieve the integer configuration C<VARIABLE>. The return value
715 is simple decimal number.  An optional value suffix of 'k', 'm',
716 or 'g' in the config file will cause the value to be multiplied
717 by 1024, 1048576 (1024^2), or 1073741824 (1024^3) prior to output.
718 It would return C<undef> if configuration variable is not defined.
719
720 =cut
721
722 sub config_int {
723         return scalar _config_common({'kind' => '--int'}, @_);
724 }
725
726 # Common subroutine to implement bulk of what the config* family of methods
727 # do. This currently wraps command('config') so it is not so fast.
728 sub _config_common {
729         my ($opts) = shift @_;
730         my ($self, $var) = _maybe_self(@_);
731
732         try {
733                 my @cmd = ('config', $opts->{'kind'} ? $opts->{'kind'} : ());
734                 unshift @cmd, $self if $self;
735                 if (wantarray) {
736                         return command(@cmd, '--get-all', $var);
737                 } else {
738                         return command_oneline(@cmd, '--get', $var);
739                 }
740         } catch Git::Error::Command with {
741                 my $E = shift;
742                 if ($E->value() == 1) {
743                         # Key not found.
744                         return;
745                 } else {
746                         throw $E;
747                 }
748         };
749 }
750
751 =item get_colorbool ( NAME )
752
753 Finds if color should be used for NAMEd operation from the configuration,
754 and returns boolean (true for "use color", false for "do not use color").
755
756 =cut
757
758 sub get_colorbool {
759         my ($self, $var) = @_;
760         my $stdout_to_tty = (-t STDOUT) ? "true" : "false";
761         my $use_color = $self->command_oneline('config', '--get-colorbool',
762                                                $var, $stdout_to_tty);
763         return ($use_color eq 'true');
764 }
765
766 =item get_color ( SLOT, COLOR )
767
768 Finds color for SLOT from the configuration, while defaulting to COLOR,
769 and returns the ANSI color escape sequence:
770
771         print $repo->get_color("color.interactive.prompt", "underline blue white");
772         print "some text";
773         print $repo->get_color("", "normal");
774
775 =cut
776
777 sub get_color {
778         my ($self, $slot, $default) = @_;
779         my $color = $self->command_oneline('config', '--get-color', $slot, $default);
780         if (!defined $color) {
781                 $color = "";
782         }
783         return $color;
784 }
785
786 =item remote_refs ( REPOSITORY [, GROUPS [, REFGLOBS ] ] )
787
788 This function returns a hashref of refs stored in a given remote repository.
789 The hash is in the format C<refname =\> hash>. For tags, the C<refname> entry
790 contains the tag object while a C<refname^{}> entry gives the tagged objects.
791
792 C<REPOSITORY> has the same meaning as the appropriate C<git-ls-remote>
793 argument; either a URL or a remote name (if called on a repository instance).
794 C<GROUPS> is an optional arrayref that can contain 'tags' to return all the
795 tags and/or 'heads' to return all the heads. C<REFGLOB> is an optional array
796 of strings containing a shell-like glob to further limit the refs returned in
797 the hash; the meaning is again the same as the appropriate C<git-ls-remote>
798 argument.
799
800 This function may or may not be called on a repository instance. In the former
801 case, remote names as defined in the repository are recognized as repository
802 specifiers.
803
804 =cut
805
806 sub remote_refs {
807         my ($self, $repo, $groups, $refglobs) = _maybe_self(@_);
808         my @args;
809         if (ref $groups eq 'ARRAY') {
810                 foreach (@$groups) {
811                         if ($_ eq 'heads') {
812                                 push (@args, '--heads');
813                         } elsif ($_ eq 'tags') {
814                                 push (@args, '--tags');
815                         } else {
816                                 # Ignore unknown groups for future
817                                 # compatibility
818                         }
819                 }
820         }
821         push (@args, $repo);
822         if (ref $refglobs eq 'ARRAY') {
823                 push (@args, @$refglobs);
824         }
825
826         my @self = $self ? ($self) : (); # Ultra trickery
827         my ($fh, $ctx) = Git::command_output_pipe(@self, 'ls-remote', @args);
828         my %refs;
829         while (<$fh>) {
830                 chomp;
831                 my ($hash, $ref) = split(/\t/, $_, 2);
832                 $refs{$ref} = $hash;
833         }
834         Git::command_close_pipe(@self, $fh, $ctx);
835         return \%refs;
836 }
837
838
839 =item ident ( TYPE | IDENTSTR )
840
841 =item ident_person ( TYPE | IDENTSTR | IDENTARRAY )
842
843 This suite of functions retrieves and parses ident information, as stored
844 in the commit and tag objects or produced by C<var GIT_type_IDENT> (thus
845 C<TYPE> can be either I<author> or I<committer>; case is insignificant).
846
847 The C<ident> method retrieves the ident information from C<git var>
848 and either returns it as a scalar string or as an array with the fields parsed.
849 Alternatively, it can take a prepared ident string (e.g. from the commit
850 object) and just parse it.
851
852 C<ident_person> returns the person part of the ident - name and email;
853 it can take the same arguments as C<ident> or the array returned by C<ident>.
854
855 The synopsis is like:
856
857         my ($name, $email, $time_tz) = ident('author');
858         "$name <$email>" eq ident_person('author');
859         "$name <$email>" eq ident_person($name);
860         $time_tz =~ /^\d+ [+-]\d{4}$/;
861
862 =cut
863
864 sub ident {
865         my ($self, $type) = _maybe_self(@_);
866         my $identstr;
867         if (lc $type eq lc 'committer' or lc $type eq lc 'author') {
868                 my @cmd = ('var', 'GIT_'.uc($type).'_IDENT');
869                 unshift @cmd, $self if $self;
870                 $identstr = command_oneline(@cmd);
871         } else {
872                 $identstr = $type;
873         }
874         if (wantarray) {
875                 return $identstr =~ /^(.*) <(.*)> (\d+ [+-]\d{4})$/;
876         } else {
877                 return $identstr;
878         }
879 }
880
881 sub ident_person {
882         my ($self, @ident) = _maybe_self(@_);
883         $#ident == 0 and @ident = $self ? $self->ident($ident[0]) : ident($ident[0]);
884         return "$ident[0] <$ident[1]>";
885 }
886
887 =item hash_object ( TYPE, FILENAME )
888
889 Compute the SHA1 object id of the given C<FILENAME> considering it is
890 of the C<TYPE> object type (C<blob>, C<commit>, C<tree>).
891
892 The method can be called without any instance or on a specified Git repository,
893 it makes zero difference.
894
895 The function returns the SHA1 hash.
896
897 =cut
898
899 # TODO: Support for passing FILEHANDLE instead of FILENAME
900 sub hash_object {
901         my ($self, $type, $file) = _maybe_self(@_);
902         command_oneline('hash-object', '-t', $type, $file);
903 }
904
905
906 =item hash_and_insert_object ( FILENAME )
907
908 Compute the SHA1 object id of the given C<FILENAME> and add the object to the
909 object database.
910
911 The function returns the SHA1 hash.
912
913 =cut
914
915 # TODO: Support for passing FILEHANDLE instead of FILENAME
916 sub hash_and_insert_object {
917         my ($self, $filename) = @_;
918
919         carp "Bad filename \"$filename\"" if $filename =~ /[\r\n]/;
920
921         $self->_open_hash_and_insert_object_if_needed();
922         my ($in, $out) = ($self->{hash_object_in}, $self->{hash_object_out});
923
924         unless (print $out $filename, "\n") {
925                 $self->_close_hash_and_insert_object();
926                 throw Error::Simple("out pipe went bad");
927         }
928
929         chomp(my $hash = <$in>);
930         unless (defined($hash)) {
931                 $self->_close_hash_and_insert_object();
932                 throw Error::Simple("in pipe went bad");
933         }
934
935         return $hash;
936 }
937
938 sub _open_hash_and_insert_object_if_needed {
939         my ($self) = @_;
940
941         return if defined($self->{hash_object_pid});
942
943         ($self->{hash_object_pid}, $self->{hash_object_in},
944          $self->{hash_object_out}, $self->{hash_object_ctx}) =
945                 $self->command_bidi_pipe(qw(hash-object -w --stdin-paths --no-filters));
946 }
947
948 sub _close_hash_and_insert_object {
949         my ($self) = @_;
950
951         return unless defined($self->{hash_object_pid});
952
953         my @vars = map { 'hash_object_' . $_ } qw(pid in out ctx);
954
955         command_close_bidi_pipe(@$self{@vars});
956         delete @$self{@vars};
957 }
958
959 =item cat_blob ( SHA1, FILEHANDLE )
960
961 Prints the contents of the blob identified by C<SHA1> to C<FILEHANDLE> and
962 returns the number of bytes printed.
963
964 =cut
965
966 sub cat_blob {
967         my ($self, $sha1, $fh) = @_;
968
969         $self->_open_cat_blob_if_needed();
970         my ($in, $out) = ($self->{cat_blob_in}, $self->{cat_blob_out});
971
972         unless (print $out $sha1, "\n") {
973                 $self->_close_cat_blob();
974                 throw Error::Simple("out pipe went bad");
975         }
976
977         my $description = <$in>;
978         if ($description =~ / missing$/) {
979                 carp "$sha1 doesn't exist in the repository";
980                 return -1;
981         }
982
983         if ($description !~ /^[0-9a-fA-F]{40}(?:[0-9a-fA-F]{24})? \S+ (\d+)$/) {
984                 carp "Unexpected result returned from git cat-file";
985                 return -1;
986         }
987
988         my $size = $1;
989
990         my $blob;
991         my $bytesLeft = $size;
992
993         while (1) {
994                 last unless $bytesLeft;
995
996                 my $bytesToRead = $bytesLeft < 1024 ? $bytesLeft : 1024;
997                 my $read = read($in, $blob, $bytesToRead);
998                 unless (defined($read)) {
999                         $self->_close_cat_blob();
1000                         throw Error::Simple("in pipe went bad");
1001                 }
1002                 unless (print $fh $blob) {
1003                         $self->_close_cat_blob();
1004                         throw Error::Simple("couldn't write to passed in filehandle");
1005                 }
1006                 $bytesLeft -= $read;
1007         }
1008
1009         # Skip past the trailing newline.
1010         my $newline;
1011         my $read = read($in, $newline, 1);
1012         unless (defined($read)) {
1013                 $self->_close_cat_blob();
1014                 throw Error::Simple("in pipe went bad");
1015         }
1016         unless ($read == 1 && $newline eq "\n") {
1017                 $self->_close_cat_blob();
1018                 throw Error::Simple("didn't find newline after blob");
1019         }
1020
1021         return $size;
1022 }
1023
1024 sub _open_cat_blob_if_needed {
1025         my ($self) = @_;
1026
1027         return if defined($self->{cat_blob_pid});
1028
1029         ($self->{cat_blob_pid}, $self->{cat_blob_in},
1030          $self->{cat_blob_out}, $self->{cat_blob_ctx}) =
1031                 $self->command_bidi_pipe(qw(cat-file --batch));
1032 }
1033
1034 sub _close_cat_blob {
1035         my ($self) = @_;
1036
1037         return unless defined($self->{cat_blob_pid});
1038
1039         my @vars = map { 'cat_blob_' . $_ } qw(pid in out ctx);
1040
1041         command_close_bidi_pipe(@$self{@vars});
1042         delete @$self{@vars};
1043 }
1044
1045
1046 =item credential_read( FILEHANDLE )
1047
1048 Reads credential key-value pairs from C<FILEHANDLE>.  Reading stops at EOF or
1049 when an empty line is encountered.  Each line must be of the form C<key=value>
1050 with a non-empty key.  Function returns hash with all read values.  Any white
1051 space (other than new-line character) is preserved.
1052
1053 =cut
1054
1055 sub credential_read {
1056         my ($self, $reader) = _maybe_self(@_);
1057         my %credential;
1058         while (<$reader>) {
1059                 chomp;
1060                 if ($_ eq '') {
1061                         last;
1062                 } elsif (!/^([^=]+)=(.*)$/) {
1063                         throw Error::Simple("unable to parse git credential data:\n$_");
1064                 }
1065                 $credential{$1} = $2;
1066         }
1067         return %credential;
1068 }
1069
1070 =item credential_write( FILEHANDLE, CREDENTIAL_HASHREF )
1071
1072 Writes credential key-value pairs from hash referenced by
1073 C<CREDENTIAL_HASHREF> to C<FILEHANDLE>.  Keys and values cannot contain
1074 new-lines or NUL bytes characters, and key cannot contain equal signs nor be
1075 empty (if they do Error::Simple is thrown).  Any white space is preserved.  If
1076 value for a key is C<undef>, it will be skipped.
1077
1078 If C<'url'> key exists it will be written first.  (All the other key-value
1079 pairs are written in sorted order but you should not depend on that).  Once
1080 all lines are written, an empty line is printed.
1081
1082 =cut
1083
1084 sub credential_write {
1085         my ($self, $writer, $credential) = _maybe_self(@_);
1086         my ($key, $value);
1087
1088         # Check if $credential is valid prior to writing anything
1089         while (($key, $value) = each %$credential) {
1090                 if (!defined $key || !length $key) {
1091                         throw Error::Simple("credential key empty or undefined");
1092                 } elsif ($key =~ /[=\n\0]/) {
1093                         throw Error::Simple("credential key contains invalid characters: $key");
1094                 } elsif (defined $value && $value =~ /[\n\0]/) {
1095                         throw Error::Simple("credential value for key=$key contains invalid characters: $value");
1096                 }
1097         }
1098
1099         for $key (sort {
1100                 # url overwrites other fields, so it must come first
1101                 return -1 if $a eq 'url';
1102                 return  1 if $b eq 'url';
1103                 return $a cmp $b;
1104         } keys %$credential) {
1105                 if (defined $credential->{$key}) {
1106                         print $writer $key, '=', $credential->{$key}, "\n";
1107                 }
1108         }
1109         print $writer "\n";
1110 }
1111
1112 sub _credential_run {
1113         my ($self, $credential, $op) = _maybe_self(@_);
1114         my ($pid, $reader, $writer, $ctx) = command_bidi_pipe('credential', $op);
1115
1116         credential_write $writer, $credential;
1117         close $writer;
1118
1119         if ($op eq "fill") {
1120                 %$credential = credential_read $reader;
1121         }
1122         if (<$reader>) {
1123                 throw Error::Simple("unexpected output from git credential $op response:\n$_\n");
1124         }
1125
1126         command_close_bidi_pipe($pid, $reader, undef, $ctx);
1127 }
1128
1129 =item credential( CREDENTIAL_HASHREF [, OPERATION ] )
1130
1131 =item credential( CREDENTIAL_HASHREF, CODE )
1132
1133 Executes C<git credential> for a given set of credentials and specified
1134 operation.  In both forms C<CREDENTIAL_HASHREF> needs to be a reference to
1135 a hash which stores credentials.  Under certain conditions the hash can
1136 change.
1137
1138 In the first form, C<OPERATION> can be C<'fill'>, C<'approve'> or C<'reject'>,
1139 and function will execute corresponding C<git credential> sub-command.  If
1140 it's omitted C<'fill'> is assumed.  In case of C<'fill'> the values stored in
1141 C<CREDENTIAL_HASHREF> will be changed to the ones returned by the C<git
1142 credential fill> command.  The usual usage would look something like:
1143
1144         my %cred = (
1145                 'protocol' => 'https',
1146                 'host' => 'example.com',
1147                 'username' => 'bob'
1148         );
1149         Git::credential \%cred;
1150         if (try_to_authenticate($cred{'username'}, $cred{'password'})) {
1151                 Git::credential \%cred, 'approve';
1152                 ... do more stuff ...
1153         } else {
1154                 Git::credential \%cred, 'reject';
1155         }
1156
1157 In the second form, C<CODE> needs to be a reference to a subroutine.  The
1158 function will execute C<git credential fill> to fill the provided credential
1159 hash, then call C<CODE> with C<CREDENTIAL_HASHREF> as the sole argument.  If
1160 C<CODE>'s return value is defined, the function will execute C<git credential
1161 approve> (if return value yields true) or C<git credential reject> (if return
1162 value is false).  If the return value is undef, nothing at all is executed;
1163 this is useful, for example, if the credential could neither be verified nor
1164 rejected due to an unrelated network error.  The return value is the same as
1165 what C<CODE> returns.  With this form, the usage might look as follows:
1166
1167         if (Git::credential {
1168                 'protocol' => 'https',
1169                 'host' => 'example.com',
1170                 'username' => 'bob'
1171         }, sub {
1172                 my $cred = shift;
1173                 return !!try_to_authenticate($cred->{'username'},
1174                                              $cred->{'password'});
1175         }) {
1176                 ... do more stuff ...
1177         }
1178
1179 =cut
1180
1181 sub credential {
1182         my ($self, $credential, $op_or_code) = (_maybe_self(@_), 'fill');
1183
1184         if ('CODE' eq ref $op_or_code) {
1185                 _credential_run $credential, 'fill';
1186                 my $ret = $op_or_code->($credential);
1187                 if (defined $ret) {
1188                         _credential_run $credential, $ret ? 'approve' : 'reject';
1189                 }
1190                 return $ret;
1191         } else {
1192                 _credential_run $credential, $op_or_code;
1193         }
1194 }
1195
1196 { # %TEMP_* Lexical Context
1197
1198 my (%TEMP_FILEMAP, %TEMP_FILES);
1199
1200 =item temp_acquire ( NAME )
1201
1202 Attempts to retrieve the temporary file mapped to the string C<NAME>. If an
1203 associated temp file has not been created this session or was closed, it is
1204 created, cached, and set for autoflush and binmode.
1205
1206 Internally locks the file mapped to C<NAME>. This lock must be released with
1207 C<temp_release()> when the temp file is no longer needed. Subsequent attempts
1208 to retrieve temporary files mapped to the same C<NAME> while still locked will
1209 cause an error. This locking mechanism provides a weak guarantee and is not
1210 threadsafe. It does provide some error checking to help prevent temp file refs
1211 writing over one another.
1212
1213 In general, the L<File::Handle> returned should not be closed by consumers as
1214 it defeats the purpose of this caching mechanism. If you need to close the temp
1215 file handle, then you should use L<File::Temp> or another temp file faculty
1216 directly. If a handle is closed and then requested again, then a warning will
1217 issue.
1218
1219 =cut
1220
1221 sub temp_acquire {
1222         my $temp_fd = _temp_cache(@_);
1223
1224         $TEMP_FILES{$temp_fd}{locked} = 1;
1225         $temp_fd;
1226 }
1227
1228 =item temp_is_locked ( NAME )
1229
1230 Returns true if the internal lock created by a previous C<temp_acquire()>
1231 call with C<NAME> is still in effect.
1232
1233 When temp_acquire is called on a C<NAME>, it internally locks the temporary
1234 file mapped to C<NAME>.  That lock will not be released until C<temp_release()>
1235 is called with either the original C<NAME> or the L<File::Handle> that was
1236 returned from the original call to temp_acquire.
1237
1238 Subsequent attempts to call C<temp_acquire()> with the same C<NAME> will fail
1239 unless there has been an intervening C<temp_release()> call for that C<NAME>
1240 (or its corresponding L<File::Handle> that was returned by the original
1241 C<temp_acquire()> call).
1242
1243 If true is returned by C<temp_is_locked()> for a C<NAME>, an attempt to
1244 C<temp_acquire()> the same C<NAME> will cause an error unless
1245 C<temp_release> is first called on that C<NAME> (or its corresponding
1246 L<File::Handle> that was returned by the original C<temp_acquire()> call).
1247
1248 =cut
1249
1250 sub temp_is_locked {
1251         my ($self, $name) = _maybe_self(@_);
1252         my $temp_fd = \$TEMP_FILEMAP{$name};
1253
1254         defined $$temp_fd && $$temp_fd->opened && $TEMP_FILES{$$temp_fd}{locked};
1255 }
1256
1257 =item temp_release ( NAME )
1258
1259 =item temp_release ( FILEHANDLE )
1260
1261 Releases a lock acquired through C<temp_acquire()>. Can be called either with
1262 the C<NAME> mapping used when acquiring the temp file or with the C<FILEHANDLE>
1263 referencing a locked temp file.
1264
1265 Warns if an attempt is made to release a file that is not locked.
1266
1267 The temp file will be truncated before being released. This can help to reduce
1268 disk I/O where the system is smart enough to detect the truncation while data
1269 is in the output buffers. Beware that after the temp file is released and
1270 truncated, any operations on that file may fail miserably until it is
1271 re-acquired. All contents are lost between each release and acquire mapped to
1272 the same string.
1273
1274 =cut
1275
1276 sub temp_release {
1277         my ($self, $temp_fd, $trunc) = _maybe_self(@_);
1278
1279         if (exists $TEMP_FILEMAP{$temp_fd}) {
1280                 $temp_fd = $TEMP_FILES{$temp_fd};
1281         }
1282         unless ($TEMP_FILES{$temp_fd}{locked}) {
1283                 carp "Attempt to release temp file '",
1284                         $temp_fd, "' that has not been locked";
1285         }
1286         temp_reset($temp_fd) if $trunc and $temp_fd->opened;
1287
1288         $TEMP_FILES{$temp_fd}{locked} = 0;
1289         undef;
1290 }
1291
1292 sub _temp_cache {
1293         my ($self, $name) = _maybe_self(@_);
1294
1295         my $temp_fd = \$TEMP_FILEMAP{$name};
1296         if (defined $$temp_fd and $$temp_fd->opened) {
1297                 if ($TEMP_FILES{$$temp_fd}{locked}) {
1298                         throw Error::Simple("Temp file with moniker '" .
1299                                 $name . "' already in use");
1300                 }
1301         } else {
1302                 if (defined $$temp_fd) {
1303                         # then we're here because of a closed handle.
1304                         carp "Temp file '", $name,
1305                                 "' was closed. Opening replacement.";
1306                 }
1307                 my $fname;
1308
1309                 my $tmpdir;
1310                 if (defined $self) {
1311                         $tmpdir = $self->repo_path();
1312                 }
1313
1314                 my $n = $name;
1315                 $n =~ s/\W/_/g; # no strange chars
1316
1317                 ($$temp_fd, $fname) = File::Temp::tempfile(
1318                         "Git_${n}_XXXXXX", UNLINK => 1, DIR => $tmpdir,
1319                         ) or throw Error::Simple("couldn't open new temp file");
1320
1321                 $$temp_fd->autoflush;
1322                 binmode $$temp_fd;
1323                 $TEMP_FILES{$$temp_fd}{fname} = $fname;
1324         }
1325         $$temp_fd;
1326 }
1327
1328 =item temp_reset ( FILEHANDLE )
1329
1330 Truncates and resets the position of the C<FILEHANDLE>.
1331
1332 =cut
1333
1334 sub temp_reset {
1335         my ($self, $temp_fd) = _maybe_self(@_);
1336
1337         truncate $temp_fd, 0
1338                 or throw Error::Simple("couldn't truncate file");
1339         sysseek($temp_fd, 0, SEEK_SET) and seek($temp_fd, 0, SEEK_SET)
1340                 or throw Error::Simple("couldn't seek to beginning of file");
1341         sysseek($temp_fd, 0, SEEK_CUR) == 0 and tell($temp_fd) == 0
1342                 or throw Error::Simple("expected file position to be reset");
1343 }
1344
1345 =item temp_path ( NAME )
1346
1347 =item temp_path ( FILEHANDLE )
1348
1349 Returns the filename associated with the given tempfile.
1350
1351 =cut
1352
1353 sub temp_path {
1354         my ($self, $temp_fd) = _maybe_self(@_);
1355
1356         if (exists $TEMP_FILEMAP{$temp_fd}) {
1357                 $temp_fd = $TEMP_FILEMAP{$temp_fd};
1358         }
1359         $TEMP_FILES{$temp_fd}{fname};
1360 }
1361
1362 sub END {
1363         unlink values %TEMP_FILEMAP if %TEMP_FILEMAP;
1364 }
1365
1366 } # %TEMP_* Lexical Context
1367
1368 =item prefix_lines ( PREFIX, STRING [, STRING... ])
1369
1370 Prefixes lines in C<STRING> with C<PREFIX>.
1371
1372 =cut
1373
1374 sub prefix_lines {
1375         my $prefix = shift;
1376         my $string = join("\n", @_);
1377         $string =~ s/^/$prefix/mg;
1378         return $string;
1379 }
1380
1381 =item unquote_path ( PATH )
1382
1383 Unquote a quoted path containing c-escapes as returned by ls-files etc.
1384 when not using -z or when parsing the output of diff -u.
1385
1386 =cut
1387
1388 {
1389         my %cquote_map = (
1390                 "a" => chr(7),
1391                 "b" => chr(8),
1392                 "t" => chr(9),
1393                 "n" => chr(10),
1394                 "v" => chr(11),
1395                 "f" => chr(12),
1396                 "r" => chr(13),
1397                 "\\" => "\\",
1398                 "\042" => "\042",
1399         );
1400
1401         sub unquote_path {
1402                 local ($_) = @_;
1403                 my ($retval, $remainder);
1404                 if (!/^\042(.*)\042$/) {
1405                         return $_;
1406                 }
1407                 ($_, $retval) = ($1, "");
1408                 while (/^([^\\]*)\\(.*)$/) {
1409                         $remainder = $2;
1410                         $retval .= $1;
1411                         for ($remainder) {
1412                                 if (/^([0-3][0-7][0-7])(.*)$/) {
1413                                         $retval .= chr(oct($1));
1414                                         $_ = $2;
1415                                         last;
1416                                 }
1417                                 if (/^([\\\042abtnvfr])(.*)$/) {
1418                                         $retval .= $cquote_map{$1};
1419                                         $_ = $2;
1420                                         last;
1421                                 }
1422                                 # This is malformed
1423                                 throw Error::Simple("invalid quoted path $_[0]");
1424                         }
1425                         $_ = $remainder;
1426                 }
1427                 $retval .= $_;
1428                 return $retval;
1429         }
1430 }
1431
1432 =item get_comment_line_char ( )
1433
1434 Gets the core.commentchar configuration value.
1435 The value falls-back to '#' if core.commentchar is set to 'auto'.
1436
1437 =cut
1438
1439 sub get_comment_line_char {
1440         my $comment_line_char = config("core.commentchar") || '#';
1441         $comment_line_char = '#' if ($comment_line_char eq 'auto');
1442         $comment_line_char = '#' if (length($comment_line_char) != 1);
1443         return $comment_line_char;
1444 }
1445
1446 =item comment_lines ( STRING [, STRING... ])
1447
1448 Comments lines following core.commentchar configuration.
1449
1450 =cut
1451
1452 sub comment_lines {
1453         my $comment_line_char = get_comment_line_char;
1454         return prefix_lines("$comment_line_char ", @_);
1455 }
1456
1457 =back
1458
1459 =head1 ERROR HANDLING
1460
1461 All functions are supposed to throw Perl exceptions in case of errors.
1462 See the L<Error> module on how to catch those. Most exceptions are mere
1463 L<Error::Simple> instances.
1464
1465 However, the C<command()>, C<command_oneline()> and C<command_noisy()>
1466 functions suite can throw C<Git::Error::Command> exceptions as well: those are
1467 thrown when the external command returns an error code and contain the error
1468 code as well as access to the captured command's output. The exception class
1469 provides the usual C<stringify> and C<value> (command's exit code) methods and
1470 in addition also a C<cmd_output> method that returns either an array or a
1471 string with the captured command output (depending on the original function
1472 call context; C<command_noisy()> returns C<undef>) and $<cmdline> which
1473 returns the command and its arguments (but without proper quoting).
1474
1475 Note that the C<command_*_pipe()> functions cannot throw this exception since
1476 it has no idea whether the command failed or not. You will only find out
1477 at the time you C<close> the pipe; if you want to have that automated,
1478 use C<command_close_pipe()>, which can throw the exception.
1479
1480 =cut
1481
1482 {
1483         package Git::Error::Command;
1484
1485         @Git::Error::Command::ISA = qw(Error);
1486
1487         sub new {
1488                 my $self = shift;
1489                 my $cmdline = '' . shift;
1490                 my $value = 0 + shift;
1491                 my $outputref = shift;
1492                 my(@args) = ();
1493
1494                 local $Error::Depth = $Error::Depth + 1;
1495
1496                 push(@args, '-cmdline', $cmdline);
1497                 push(@args, '-value', $value);
1498                 push(@args, '-outputref', $outputref);
1499
1500                 $self->SUPER::new(-text => 'command returned error', @args);
1501         }
1502
1503         sub stringify {
1504                 my $self = shift;
1505                 my $text = $self->SUPER::stringify;
1506                 $self->cmdline() . ': ' . $text . ': ' . $self->value() . "\n";
1507         }
1508
1509         sub cmdline {
1510                 my $self = shift;
1511                 $self->{'-cmdline'};
1512         }
1513
1514         sub cmd_output {
1515                 my $self = shift;
1516                 my $ref = $self->{'-outputref'};
1517                 defined $ref or undef;
1518                 if (ref $ref eq 'ARRAY') {
1519                         return @$ref;
1520                 } else { # SCALAR
1521                         return $$ref;
1522                 }
1523         }
1524 }
1525
1526 =over 4
1527
1528 =item git_cmd_try { CODE } ERRMSG
1529
1530 This magical statement will automatically catch any C<Git::Error::Command>
1531 exceptions thrown by C<CODE> and make your program die with C<ERRMSG>
1532 on its lips; the message will have %s substituted for the command line
1533 and %d for the exit status. This statement is useful mostly for producing
1534 more user-friendly error messages.
1535
1536 In case of no exception caught the statement returns C<CODE>'s return value.
1537
1538 Note that this is the only auto-exported function.
1539
1540 =cut
1541
1542 sub git_cmd_try(&$) {
1543         my ($code, $errmsg) = @_;
1544         my @result;
1545         my $err;
1546         my $array = wantarray;
1547         try {
1548                 if ($array) {
1549                         @result = &$code;
1550                 } else {
1551                         $result[0] = &$code;
1552                 }
1553         } catch Git::Error::Command with {
1554                 my $E = shift;
1555                 $err = $errmsg;
1556                 $err =~ s/\%s/$E->cmdline()/ge;
1557                 $err =~ s/\%d/$E->value()/ge;
1558                 # We can't croak here since Error.pm would mangle
1559                 # that to Error::Simple.
1560         };
1561         $err and croak $err;
1562         return $array ? @result : $result[0];
1563 }
1564
1565
1566 =back
1567
1568 =head1 COPYRIGHT
1569
1570 Copyright 2006 by Petr Baudis E<lt>pasky@suse.czE<gt>.
1571
1572 This module is free software; it may be used, copied, modified
1573 and distributed under the terms of the GNU General Public Licence,
1574 either version 2, or (at your option) any later version.
1575
1576 =cut
1577
1578
1579 # Take raw method argument list and return ($obj, @args) in case
1580 # the method was called upon an instance and (undef, @args) if
1581 # it was called directly.
1582 sub _maybe_self {
1583         UNIVERSAL::isa($_[0], 'Git') ? @_ : (undef, @_);
1584 }
1585
1586 # Check if the command id is something reasonable.
1587 sub _check_valid_cmd {
1588         my ($cmd) = @_;
1589         $cmd =~ /^[a-z0-9A-Z_-]+$/ or throw Error::Simple("bad command: $cmd");
1590 }
1591
1592 # Common backend for the pipe creators.
1593 sub _command_common_pipe {
1594         my $direction = shift;
1595         my ($self, @p) = _maybe_self(@_);
1596         my (%opts, $cmd, @args);
1597         if (ref $p[0]) {
1598                 ($cmd, @args) = @{shift @p};
1599                 %opts = ref $p[0] ? %{$p[0]} : @p;
1600         } else {
1601                 ($cmd, @args) = @p;
1602         }
1603         _check_valid_cmd($cmd);
1604
1605         my $fh;
1606         if ($^O eq 'MSWin32') {
1607                 # ActiveState Perl
1608                 #defined $opts{STDERR} and
1609                 #       warn 'ignoring STDERR option - running w/ ActiveState';
1610                 $direction eq '-|' or
1611                         die 'input pipe for ActiveState not implemented';
1612                 # the strange construction with *ACPIPE is just to
1613                 # explain the tie below that we want to bind to
1614                 # a handle class, not scalar. It is not known if
1615                 # it is something specific to ActiveState Perl or
1616                 # just a Perl quirk.
1617                 tie (*ACPIPE, 'Git::activestate_pipe', $cmd, @args);
1618                 $fh = *ACPIPE;
1619
1620         } else {
1621                 my $pid = open($fh, $direction);
1622                 if (not defined $pid) {
1623                         throw Error::Simple("open failed: $!");
1624                 } elsif ($pid == 0) {
1625                         if ($opts{STDERR}) {
1626                                 open (STDERR, '>&', $opts{STDERR})
1627                                         or die "dup failed: $!";
1628                         } elsif (defined $opts{STDERR}) {
1629                                 open (STDERR, '>', '/dev/null')
1630                                         or die "opening /dev/null failed: $!";
1631                         }
1632                         _cmd_exec($self, $cmd, @args);
1633                 }
1634         }
1635         return wantarray ? ($fh, join(' ', $cmd, @args)) : $fh;
1636 }
1637
1638 # When already in the subprocess, set up the appropriate state
1639 # for the given repository and execute the git command.
1640 sub _cmd_exec {
1641         my ($self, @args) = @_;
1642         _setup_git_cmd_env($self);
1643         _execv_git_cmd(@args);
1644         die qq[exec "@args" failed: $!];
1645 }
1646
1647 # set up the appropriate state for git command
1648 sub _setup_git_cmd_env {
1649         my $self = shift;
1650         if ($self) {
1651                 $self->repo_path() and $ENV{'GIT_DIR'} = $self->repo_path();
1652                 $self->repo_path() and $self->wc_path()
1653                         and $ENV{'GIT_WORK_TREE'} = $self->wc_path();
1654                 $self->wc_path() and chdir($self->wc_path());
1655                 $self->wc_subdir() and chdir($self->wc_subdir());
1656         }
1657 }
1658
1659 # Execute the given Git command ($_[0]) with arguments ($_[1..])
1660 # by searching for it at proper places.
1661 sub _execv_git_cmd { exec('git', @_); }
1662
1663 # Close pipe to a subprocess.
1664 sub _cmd_close {
1665         my $ctx = shift @_;
1666         foreach my $fh (@_) {
1667                 if (close $fh) {
1668                         # nop
1669                 } elsif ($!) {
1670                         # It's just close, no point in fatalities
1671                         carp "error closing pipe: $!";
1672                 } elsif ($? >> 8) {
1673                         # The caller should pepper this.
1674                         throw Git::Error::Command($ctx, $? >> 8);
1675                 }
1676                 # else we might e.g. closed a live stream; the command
1677                 # dying of SIGPIPE would drive us here.
1678         }
1679 }
1680
1681
1682 sub DESTROY {
1683         my ($self) = @_;
1684         $self->_close_hash_and_insert_object();
1685         $self->_close_cat_blob();
1686 }
1687
1688
1689 # Pipe implementation for ActiveState Perl.
1690
1691 package Git::activestate_pipe;
1692
1693 sub TIEHANDLE {
1694         my ($class, @params) = @_;
1695         # FIXME: This is probably horrible idea and the thing will explode
1696         # at the moment you give it arguments that require some quoting,
1697         # but I have no ActiveState clue... --pasky
1698         # Let's just hope ActiveState Perl does at least the quoting
1699         # correctly.
1700         my @data = qx{git @params};
1701         bless { i => 0, data => \@data }, $class;
1702 }
1703
1704 sub READLINE {
1705         my $self = shift;
1706         if ($self->{i} >= scalar @{$self->{data}}) {
1707                 return undef;
1708         }
1709         my $i = $self->{i};
1710         if (wantarray) {
1711                 $self->{i} = $#{$self->{'data'}} + 1;
1712                 return splice(@{$self->{'data'}}, $i);
1713         }
1714         $self->{i} = $i + 1;
1715         return $self->{'data'}->[ $i ];
1716 }
1717
1718 sub CLOSE {
1719         my $self = shift;
1720         delete $self->{data};
1721         delete $self->{i};
1722 }
1723
1724 sub EOF {
1725         my $self = shift;
1726         return ($self->{i} >= scalar @{$self->{data}});
1727 }
1728
1729
1730 1; # Famous last words