Merge branch 'js/bisect-helper-check-get-oid-return-value'
[git/git.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