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