3 Git - Perl interface to the Git version control system
15 our ($VERSION, @ISA, @EXPORT, @EXPORT_OK);
17 # Totally unstable API.
25 my $version = Git::command_oneline('version');
27 git_cmd_try { Git::command_noisy('update-server-info') }
28 '%s failed w/ code %d';
30 my $repo = Git->repository (Directory => '/srv/git/cogito.git');
33 my @revs = $repo->command('rev-list', '--since=last monday', '--all');
35 my ($fh, $c) = $repo->command_output_pipe('rev-list', '--since=last monday', '--all');
36 my $lastrev = <$fh>; chomp $lastrev;
37 $repo->command_close_pipe($fh, $c);
39 my $lastrev = $repo->command_oneline( [ 'rev-list', '--all' ],
42 my $sha1 = $repo->hash_and_insert_object('file.txt');
43 my $tempfile = tempfile();
44 my $size = $repo->cat_blob($sha1, $tempfile);
53 @EXPORT = qw(git_cmd_try);
55 # Methods which can be called as standalone functions as well:
56 @EXPORT_OK = qw(command command_oneline command_noisy
57 command_output_pipe command_input_pipe command_close_pipe
58 command_bidi_pipe command_close_bidi_pipe
59 version exec_path hash_object git_cmd_try
65 This module provides Perl scripts easy way to interface the Git version control
66 system. The modules have an easy and well-tested way to call arbitrary Git
67 commands; in the future, the interface will also provide specialized methods
68 for doing easily operations which are not totally trivial to do over
69 the generic command interface.
71 While some commands can be executed outside of any context (e.g. 'version'
72 or 'init'), most operations require a repository context, which in practice
73 means getting an instance of the Git object using the repository() constructor.
74 (In the future, we will also get a new_repository() constructor.) All commands
75 called as methods of the object are then executed in the context of the
78 Part of the "repository state" is also information about path to the attached
79 working copy (unless you work with a bare repository). You can also navigate
80 inside of the working copy using the C<wc_chdir()> method. (Note that
81 the repository object is self-contained and will not change working directory
84 TODO: In the future, we might also do
86 my $remoterepo = $repo->remote_repository (Name => 'cogito', Branch => 'master');
87 $remoterepo ||= Git->remote_repository ('http://git.or.cz/cogito.git/');
88 my @refs = $remoterepo->refs();
90 Currently, the module merely wraps calls to external Git tools. In the future,
91 it will provide a much faster way to interact with Git by linking directly
92 to libgit. This should be completely opaque to the user, though (performance
93 increate nonwithstanding).
98 use Carp
qw(carp croak); # but croak is bad - throw instead
100 use Cwd
qw(abs_path);
101 use IPC
::Open2
qw(open2);
110 =item repository ( OPTIONS )
112 =item repository ( DIRECTORY )
116 Construct a new repository object.
117 C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
118 Possible options are:
120 B<Repository> - Path to the Git repository.
122 B<WorkingCopy> - Path to the associated working copy; not strictly required
123 as many commands will happily crunch on a bare repository.
125 B<WorkingSubdir> - Subdirectory in the working copy to work inside.
126 Just left undefined if you do not want to limit the scope of operations.
128 B<Directory> - Path to the Git working directory in its usual setup.
129 The C<.git> directory is searched in the directory and all the parent
130 directories; if found, C<WorkingCopy> is set to the directory containing
131 it and C<Repository> to the C<.git> directory itself. If no C<.git>
132 directory was found, the C<Directory> is assumed to be a bare repository,
133 C<Repository> is set to point at it and C<WorkingCopy> is left undefined.
134 If the C<$GIT_DIR> environment variable is set, things behave as expected
137 You should not use both C<Directory> and either of C<Repository> and
138 C<WorkingCopy> - the results of that are undefined.
140 Alternatively, a directory path may be passed as a single scalar argument
141 to the constructor; it is equivalent to setting only the C<Directory> option
144 Calling the constructor with no options whatsoever is equivalent to
145 calling it with C<< Directory => '.' >>. In general, if you are building
146 a standard porcelain command, simply doing C<< Git->repository() >> should
147 do the right thing and setup the object to reflect exactly where the user
158 if (defined $args[0]) {
159 if ($#args % 2 != 1) {
161 $#args == 0 or throw Error
::Simple
("bad usage");
162 %opts = ( Directory
=> $args[0] );
168 if (not defined $opts{Repository
} and not defined $opts{WorkingCopy
}) {
169 $opts{Directory
} ||= '.';
172 if ($opts{Directory
}) {
173 -d
$opts{Directory
} or throw Error
::Simple
("Directory not found: $!");
175 my $search = Git
->repository(WorkingCopy
=> $opts{Directory
});
178 $dir = $search->command_oneline(['rev-parse', '--git-dir'],
180 } catch Git
::Error
::Command with
{
185 $dir =~ m
#^/# or $dir = $opts{Directory} . '/' . $dir;
186 $opts{Repository
} = $dir;
188 # If --git-dir went ok, this shouldn't die either.
189 my $prefix = $search->command_oneline('rev-parse', '--show-prefix');
190 $dir = abs_path
($opts{Directory
}) . '/';
192 if (substr($dir, -length($prefix)) ne $prefix) {
193 throw Error
::Simple
("rev-parse confused me - $dir does not have trailing $prefix");
195 substr($dir, -length($prefix)) = '';
197 $opts{WorkingCopy
} = $dir;
198 $opts{WorkingSubdir
} = $prefix;
201 # A bare repository? Let's see...
202 $dir = $opts{Directory
};
204 unless (-d
"$dir/refs" and -d
"$dir/objects" and -e
"$dir/HEAD") {
205 # Mimick git-rev-parse --git-dir error message:
206 throw Error
::Simple
('fatal: Not a git repository');
208 my $search = Git
->repository(Repository
=> $dir);
210 $search->command('symbolic-ref', 'HEAD');
211 } catch Git
::Error
::Command with
{
212 # Mimick git-rev-parse --git-dir error message:
213 throw Error
::Simple
('fatal: Not a git repository');
216 $opts{Repository
} = abs_path
($dir);
219 delete $opts{Directory
};
222 $self = { opts
=> \
%opts };
232 =item command ( COMMAND [, ARGUMENTS... ] )
234 =item command ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } )
236 Execute the given Git C<COMMAND> (specify it without the 'git-'
237 prefix), optionally with the specified extra C<ARGUMENTS>.
239 The second more elaborate form can be used if you want to further adjust
240 the command execution. Currently, only one option is supported:
242 B<STDERR> - How to deal with the command's error output. By default (C<undef>)
243 it is delivered to the caller's C<STDERR>. A false value (0 or '') will cause
244 it to be thrown away. If you want to process it, you can get it in a filehandle
245 you specify, but you must be extremely careful; if the error output is not
246 very short and you want to read it in the same process as where you called
247 C<command()>, you are set up for a nice deadlock!
249 The 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).
252 In scalar context, it returns all the command output in a single string
255 In array context, it returns an array containing lines printed to the
256 command's stdout (without trailing newlines).
258 In both cases, the command's stdin and stderr are the same as the caller's.
263 my ($fh, $ctx) = command_output_pipe
(@_);
265 if (not defined wantarray) {
266 # Nothing to pepper the possible exception with.
267 _cmd_close
($fh, $ctx);
269 } elsif (not wantarray) {
273 _cmd_close
($fh, $ctx);
274 } catch Git
::Error
::Command with
{
275 # Pepper with the output:
277 $E->{'-outputref'} = \
$text;
284 defined and chomp for @lines;
286 _cmd_close
($fh, $ctx);
287 } catch Git
::Error
::Command with
{
289 $E->{'-outputref'} = \
@lines;
297 =item command_oneline ( COMMAND [, ARGUMENTS... ] )
299 =item command_oneline ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } )
301 Execute the given C<COMMAND> in the same way as command()
302 does but always return a scalar string containing the first line
303 of the command's standard output.
307 sub command_oneline
{
308 my ($fh, $ctx) = command_output_pipe
(@_);
311 defined $line and chomp $line;
313 _cmd_close
($fh, $ctx);
314 } catch Git
::Error
::Command with
{
315 # Pepper with the output:
317 $E->{'-outputref'} = \
$line;
324 =item command_output_pipe ( COMMAND [, ARGUMENTS... ] )
326 =item command_output_pipe ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } )
328 Execute the given C<COMMAND> in the same way as command()
329 does but return a pipe filehandle from which the command output can be
332 The function can return C<($pipe, $ctx)> in array context.
333 See C<command_close_pipe()> for details.
337 sub command_output_pipe
{
338 _command_common_pipe
('-|', @_);
342 =item command_input_pipe ( COMMAND [, ARGUMENTS... ] )
344 =item command_input_pipe ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } )
346 Execute the given C<COMMAND> in the same way as command_output_pipe()
347 does but return an input pipe filehandle instead; the command output
350 The function can return C<($pipe, $ctx)> in array context.
351 See C<command_close_pipe()> for details.
355 sub command_input_pipe
{
356 _command_common_pipe
('|-', @_);
360 =item command_close_pipe ( PIPE [, CTX ] )
362 Close the C<PIPE> as returned from C<command_*_pipe()>, checking
363 whether the command finished successfully. The optional C<CTX> argument
364 is required if you want to see the command name in the error message,
365 and it is the second value returned by C<command_*_pipe()> when
366 called in array context. The call idiom is:
368 my ($fh, $ctx) = $r->command_output_pipe('status');
369 while (<$fh>) { ... }
370 $r->command_close_pipe($fh, $ctx);
372 Note that you should not rely on whatever actually is in C<CTX>;
373 currently it is simply the command name but in future the context might
374 have more complicated structure.
378 sub command_close_pipe
{
379 my ($self, $fh, $ctx) = _maybe_self
(@_);
380 $ctx ||= '<unknown>';
381 _cmd_close
($fh, $ctx);
384 =item command_bidi_pipe ( COMMAND [, ARGUMENTS... ] )
386 Execute the given C<COMMAND> in the same way as command_output_pipe()
387 does but return both an input pipe filehandle and an output pipe filehandle.
389 The function will return return C<($pid, $pipe_in, $pipe_out, $ctx)>.
390 See C<command_close_bidi_pipe()> for details.
394 sub command_bidi_pipe
{
395 my ($pid, $in, $out);
396 $pid = open2
($in, $out, 'git', @_);
397 return ($pid, $in, $out, join(' ', @_));
400 =item command_close_bidi_pipe ( PID, PIPE_IN, PIPE_OUT [, CTX] )
402 Close the C<PIPE_IN> and C<PIPE_OUT> as returned from C<command_bidi_pipe()>,
403 checking whether the command finished successfully. The optional C<CTX>
404 argument is required if you want to see the command name in the error message,
405 and it is the fourth value returned by C<command_bidi_pipe()>. The call idiom
408 my ($pid, $in, $out, $ctx) = $r->command_bidi_pipe('cat-file --batch-check');
409 print "000000000\n" $out;
410 while (<$in>) { ... }
411 $r->command_close_bidi_pipe($pid, $in, $out, $ctx);
413 Note that you should not rely on whatever actually is in C<CTX>;
414 currently it is simply the command name but in future the context might
415 have more complicated structure.
419 sub command_close_bidi_pipe
{
421 my ($pid, $in, $out, $ctx) = @_;
422 foreach my $fh ($in, $out) {
425 carp
"error closing pipe: $!";
427 throw Git
::Error
::Command
($ctx, $?
>>8);
435 throw Git
::Error
::Command
($ctx, $?
>>8);
440 =item command_noisy ( COMMAND [, ARGUMENTS... ] )
442 Execute the given C<COMMAND> in the same way as command() does but do not
443 capture the command output - the standard output is not redirected and goes
444 to the standard output of the caller application.
446 While the method is called command_noisy(), you might want to as well use
447 it for the most silent Git commands which you know will never pollute your
448 stdout but you want to avoid the overhead of the pipe setup when calling them.
450 The function returns only after the command has finished running.
455 my ($self, $cmd, @args) = _maybe_self
(@_);
456 _check_valid_cmd
($cmd);
459 if (not defined $pid) {
460 throw Error
::Simple
("fork failed: $!");
461 } elsif ($pid == 0) {
462 _cmd_exec
($self, $cmd, @args);
464 if (waitpid($pid, 0) > 0 and $?
>>8 != 0) {
465 throw Git
::Error
::Command
(join(' ', $cmd, @args), $?
>> 8);
472 Return the Git version in use.
477 my $verstr = command_oneline
('--version');
478 $verstr =~ s/^git version //;
485 Return path to the Git sub-command executables (the same as
486 C<git --exec-path>). Useful mostly only internally.
490 sub exec_path
{ command_oneline
('--exec-path') }
495 Return path to the git repository. Must be called on a repository instance.
499 sub repo_path
{ $_[0]->{opts
}->{Repository
} }
504 Return path to the working copy. Must be called on a repository instance.
508 sub wc_path
{ $_[0]->{opts
}->{WorkingCopy
} }
513 Return path to the subdirectory inside of a working copy. Must be called
514 on a repository instance.
518 sub wc_subdir
{ $_[0]->{opts
}->{WorkingSubdir
} ||= '' }
521 =item wc_chdir ( SUBDIR )
523 Change the working copy subdirectory to work within. The C<SUBDIR> is
524 relative to the working copy root directory (not the current subdirectory).
525 Must be called on a repository instance attached to a working copy
526 and the directory must exist.
531 my ($self, $subdir) = @_;
533 or throw Error
::Simple
("bare repository");
535 -d
$self->wc_path().'/'.$subdir
536 or throw Error
::Simple
("subdir not found: $!");
537 # Of course we will not "hold" the subdirectory so anyone
538 # can delete it now and we will never know. But at least we tried.
540 $self->{opts
}->{WorkingSubdir
} = $subdir;
544 =item config ( VARIABLE )
546 Retrieve the configuration C<VARIABLE> in the same manner as C<config>
547 does. In scalar context requires the variable to be set only one time
548 (exception is thrown otherwise), in array context returns allows the
549 variable to be set multiple times and returns all the values.
551 This currently wraps command('config') so it is not so fast.
556 my ($self, $var) = _maybe_self
(@_);
559 my @cmd = ('config');
560 unshift @cmd, $self if $self;
562 return command
(@cmd, '--get-all', $var);
564 return command_oneline
(@cmd, '--get', $var);
566 } catch Git
::Error
::Command with
{
568 if ($E->value() == 1) {
578 =item config_bool ( VARIABLE )
580 Retrieve the bool configuration C<VARIABLE>. The return value
581 is usable as a boolean in perl (and C<undef> if it's not defined,
584 This currently wraps command('config') so it is not so fast.
589 my ($self, $var) = _maybe_self
(@_);
592 my @cmd = ('config', '--bool', '--get', $var);
593 unshift @cmd, $self if $self;
594 my $val = command_oneline
(@cmd);
595 return undef unless defined $val;
596 return $val eq 'true';
597 } catch Git
::Error
::Command with
{
599 if ($E->value() == 1) {
608 =item config_int ( VARIABLE )
610 Retrieve the integer configuration C<VARIABLE>. The return value
611 is simple decimal number. An optional value suffix of 'k', 'm',
612 or 'g' in the config file will cause the value to be multiplied
613 by 1024, 1048576 (1024^2), or 1073741824 (1024^3) prior to output.
614 It would return C<undef> if configuration variable is not defined,
616 This currently wraps command('config') so it is not so fast.
621 my ($self, $var) = _maybe_self
(@_);
624 my @cmd = ('config', '--int', '--get', $var);
625 unshift @cmd, $self if $self;
626 return command_oneline
(@cmd);
627 } catch Git
::Error
::Command with
{
629 if ($E->value() == 1) {
638 =item get_colorbool ( NAME )
640 Finds if color should be used for NAMEd operation from the configuration,
641 and returns boolean (true for "use color", false for "do not use color").
646 my ($self, $var) = @_;
647 my $stdout_to_tty = (-t STDOUT
) ?
"true" : "false";
648 my $use_color = $self->command_oneline('config', '--get-colorbool',
649 $var, $stdout_to_tty);
650 return ($use_color eq 'true');
653 =item get_color ( SLOT, COLOR )
655 Finds color for SLOT from the configuration, while defaulting to COLOR,
656 and returns the ANSI color escape sequence:
658 print $repo->get_color("color.interactive.prompt", "underline blue white");
660 print $repo->get_color("", "normal");
665 my ($self, $slot, $default) = @_;
666 my $color = $self->command_oneline('config', '--get-color', $slot, $default);
667 if (!defined $color) {
673 =item remote_refs ( REPOSITORY [, GROUPS [, REFGLOBS ] ] )
675 This function returns a hashref of refs stored in a given remote repository.
676 The hash is in the format C<refname =\> hash>. For tags, the C<refname> entry
677 contains the tag object while a C<refname^{}> entry gives the tagged objects.
679 C<REPOSITORY> has the same meaning as the appropriate C<git-ls-remote>
680 argument; either an URL or a remote name (if called on a repository instance).
681 C<GROUPS> is an optional arrayref that can contain 'tags' to return all the
682 tags and/or 'heads' to return all the heads. C<REFGLOB> is an optional array
683 of strings containing a shell-like glob to further limit the refs returned in
684 the hash; the meaning is again the same as the appropriate C<git-ls-remote>
687 This function may or may not be called on a repository instance. In the former
688 case, remote names as defined in the repository are recognized as repository
694 my ($self, $repo, $groups, $refglobs) = _maybe_self
(@_);
696 if (ref $groups eq 'ARRAY') {
699 push (@args, '--heads');
700 } elsif ($_ eq 'tags') {
701 push (@args, '--tags');
703 # Ignore unknown groups for future
709 if (ref $refglobs eq 'ARRAY') {
710 push (@args, @
$refglobs);
713 my @self = $self ?
($self) : (); # Ultra trickery
714 my ($fh, $ctx) = Git
::command_output_pipe
(@self, 'ls-remote', @args);
718 my ($hash, $ref) = split(/\t/, $_, 2);
721 Git
::command_close_pipe
(@self, $fh, $ctx);
726 =item ident ( TYPE | IDENTSTR )
728 =item ident_person ( TYPE | IDENTSTR | IDENTARRAY )
730 This suite of functions retrieves and parses ident information, as stored
731 in the commit and tag objects or produced by C<var GIT_type_IDENT> (thus
732 C<TYPE> can be either I<author> or I<committer>; case is insignificant).
734 The C<ident> method retrieves the ident information from C<git var>
735 and either returns it as a scalar string or as an array with the fields parsed.
736 Alternatively, it can take a prepared ident string (e.g. from the commit
737 object) and just parse it.
739 C<ident_person> returns the person part of the ident - name and email;
740 it can take the same arguments as C<ident> or the array returned by C<ident>.
742 The synopsis is like:
744 my ($name, $email, $time_tz) = ident('author');
745 "$name <$email>" eq ident_person('author');
746 "$name <$email>" eq ident_person($name);
747 $time_tz =~ /^\d+ [+-]\d{4}$/;
752 my ($self, $type) = _maybe_self
(@_);
754 if (lc $type eq lc 'committer' or lc $type eq lc 'author') {
755 my @cmd = ('var', 'GIT_'.uc($type).'_IDENT');
756 unshift @cmd, $self if $self;
757 $identstr = command_oneline
(@cmd);
762 return $identstr =~ /^(.*) <(.*)> (\d+ [+-]\d{4})$/;
769 my ($self, @ident) = _maybe_self
(@_);
770 $#ident == 0 and @ident = $self ?
$self->ident($ident[0]) : ident
($ident[0]);
771 return "$ident[0] <$ident[1]>";
775 =item hash_object ( TYPE, FILENAME )
777 Compute the SHA1 object id of the given C<FILENAME> considering it is
778 of the C<TYPE> object type (C<blob>, C<commit>, C<tree>).
780 The method can be called without any instance or on a specified Git repository,
781 it makes zero difference.
783 The function returns the SHA1 hash.
787 # TODO: Support for passing FILEHANDLE instead of FILENAME
789 my ($self, $type, $file) = _maybe_self
(@_);
790 command_oneline
('hash-object', '-t', $type, $file);
794 =item hash_and_insert_object ( FILENAME )
796 Compute the SHA1 object id of the given C<FILENAME> and add the object to the
799 The function returns the SHA1 hash.
803 # TODO: Support for passing FILEHANDLE instead of FILENAME
804 sub hash_and_insert_object
{
805 my ($self, $filename) = @_;
807 carp
"Bad filename \"$filename\"" if $filename =~ /[\r\n]/;
809 $self->_open_hash_and_insert_object_if_needed();
810 my ($in, $out) = ($self->{hash_object_in
}, $self->{hash_object_out
});
812 unless (print $out $filename, "\n") {
813 $self->_close_hash_and_insert_object();
814 throw Error
::Simple
("out pipe went bad");
817 chomp(my $hash = <$in>);
818 unless (defined($hash)) {
819 $self->_close_hash_and_insert_object();
820 throw Error
::Simple
("in pipe went bad");
826 sub _open_hash_and_insert_object_if_needed
{
829 return if defined($self->{hash_object_pid
});
831 ($self->{hash_object_pid
}, $self->{hash_object_in
},
832 $self->{hash_object_out
}, $self->{hash_object_ctx
}) =
833 command_bidi_pipe
(qw(hash-object -w --stdin-paths));
836 sub _close_hash_and_insert_object
{
839 return unless defined($self->{hash_object_pid
});
841 my @vars = map { 'hash_object_' . $_ } qw(pid in out ctx);
843 command_close_bidi_pipe
(@
$self{@vars});
844 delete @
$self{@vars};
847 =item cat_blob ( SHA1, FILEHANDLE )
849 Prints the contents of the blob identified by C<SHA1> to C<FILEHANDLE> and
850 returns the number of bytes printed.
855 my ($self, $sha1, $fh) = @_;
857 $self->_open_cat_blob_if_needed();
858 my ($in, $out) = ($self->{cat_blob_in
}, $self->{cat_blob_out
});
860 unless (print $out $sha1, "\n") {
861 $self->_close_cat_blob();
862 throw Error
::Simple
("out pipe went bad");
865 my $description = <$in>;
866 if ($description =~ / missing$/) {
867 carp
"$sha1 doesn't exist in the repository";
871 if ($description !~ /^[0-9a-fA-F]{40} \S+ (\d+)$/) {
872 carp
"Unexpected result returned from git cat-file";
882 my $bytesLeft = $size - $bytesRead;
883 last unless $bytesLeft;
885 my $bytesToRead = $bytesLeft < 1024 ?
$bytesLeft : 1024;
886 my $read = read($in, $blob, $bytesToRead, $bytesRead);
887 unless (defined($read)) {
888 $self->_close_cat_blob();
889 throw Error
::Simple
("in pipe went bad");
895 # Skip past the trailing newline.
897 my $read = read($in, $newline, 1);
898 unless (defined($read)) {
899 $self->_close_cat_blob();
900 throw Error
::Simple
("in pipe went bad");
902 unless ($read == 1 && $newline eq "\n") {
903 $self->_close_cat_blob();
904 throw Error
::Simple
("didn't find newline after blob");
907 unless (print $fh $blob) {
908 $self->_close_cat_blob();
909 throw Error
::Simple
("couldn't write to passed in filehandle");
915 sub _open_cat_blob_if_needed
{
918 return if defined($self->{cat_blob_pid
});
920 ($self->{cat_blob_pid
}, $self->{cat_blob_in
},
921 $self->{cat_blob_out
}, $self->{cat_blob_ctx
}) =
922 command_bidi_pipe
(qw(cat-file --batch));
925 sub _close_cat_blob
{
928 return unless defined($self->{cat_blob_pid
});
930 my @vars = map { 'cat_blob_' . $_ } qw(pid in out ctx);
932 command_close_bidi_pipe
(@
$self{@vars});
933 delete @
$self{@vars};
938 =head1 ERROR HANDLING
940 All functions are supposed to throw Perl exceptions in case of errors.
941 See the L<Error> module on how to catch those. Most exceptions are mere
942 L<Error::Simple> instances.
944 However, the C<command()>, C<command_oneline()> and C<command_noisy()>
945 functions suite can throw C<Git::Error::Command> exceptions as well: those are
946 thrown when the external command returns an error code and contain the error
947 code as well as access to the captured command's output. The exception class
948 provides the usual C<stringify> and C<value> (command's exit code) methods and
949 in addition also a C<cmd_output> method that returns either an array or a
950 string with the captured command output (depending on the original function
951 call context; C<command_noisy()> returns C<undef>) and $<cmdline> which
952 returns the command and its arguments (but without proper quoting).
954 Note that the C<command_*_pipe()> functions cannot throw this exception since
955 it has no idea whether the command failed or not. You will only find out
956 at the time you C<close> the pipe; if you want to have that automated,
957 use C<command_close_pipe()>, which can throw the exception.
962 package Git
::Error
::Command
;
964 @Git::Error
::Command
::ISA
= qw(Error);
968 my $cmdline = '' . shift;
969 my $value = 0 + shift;
970 my $outputref = shift;
973 local $Error::Depth
= $Error::Depth
+ 1;
975 push(@args, '-cmdline', $cmdline);
976 push(@args, '-value', $value);
977 push(@args, '-outputref', $outputref);
979 $self->SUPER::new
(-text
=> 'command returned error', @args);
984 my $text = $self->SUPER::stringify
;
985 $self->cmdline() . ': ' . $text . ': ' . $self->value() . "\n";
995 my $ref = $self->{'-outputref'};
996 defined $ref or undef;
997 if (ref $ref eq 'ARRAY') {
1007 =item git_cmd_try { CODE } ERRMSG
1009 This magical statement will automatically catch any C<Git::Error::Command>
1010 exceptions thrown by C<CODE> and make your program die with C<ERRMSG>
1011 on its lips; the message will have %s substituted for the command line
1012 and %d for the exit status. This statement is useful mostly for producing
1013 more user-friendly error messages.
1015 In case of no exception caught the statement returns C<CODE>'s return value.
1017 Note that this is the only auto-exported function.
1021 sub git_cmd_try
(&$) {
1022 my ($code, $errmsg) = @_;
1025 my $array = wantarray;
1030 $result[0] = &$code;
1032 } catch Git
::Error
::Command with
{
1035 $err =~ s/\%s/$E->cmdline()/ge;
1036 $err =~ s/\%d/$E->value()/ge;
1037 # We can't croak here since Error.pm would mangle
1038 # that to Error::Simple.
1040 $err and croak
$err;
1041 return $array ?
@result : $result[0];
1049 Copyright 2006 by Petr Baudis E<lt>pasky@suse.czE<gt>.
1051 This module is free software; it may be used, copied, modified
1052 and distributed under the terms of the GNU General Public Licence,
1053 either version 2, or (at your option) any later version.
1058 # Take raw method argument list and return ($obj, @args) in case
1059 # the method was called upon an instance and (undef, @args) if
1060 # it was called directly.
1062 # This breaks inheritance. Oh well.
1063 ref $_[0] eq 'Git' ?
@_ : (undef, @_);
1066 # Check if the command id is something reasonable.
1067 sub _check_valid_cmd
{
1069 $cmd =~ /^[a-z0-9A-Z_-]+$/ or throw Error
::Simple
("bad command: $cmd");
1072 # Common backend for the pipe creators.
1073 sub _command_common_pipe
{
1074 my $direction = shift;
1075 my ($self, @p) = _maybe_self
(@_);
1076 my (%opts, $cmd, @args);
1078 ($cmd, @args) = @
{shift @p};
1079 %opts = ref $p[0] ?
%{$p[0]} : @p;
1083 _check_valid_cmd
($cmd);
1086 if ($^O
eq 'MSWin32') {
1088 #defined $opts{STDERR} and
1089 # warn 'ignoring STDERR option - running w/ ActiveState';
1090 $direction eq '-|' or
1091 die 'input pipe for ActiveState not implemented';
1092 # the strange construction with *ACPIPE is just to
1093 # explain the tie below that we want to bind to
1094 # a handle class, not scalar. It is not known if
1095 # it is something specific to ActiveState Perl or
1096 # just a Perl quirk.
1097 tie
(*ACPIPE
, 'Git::activestate_pipe', $cmd, @args);
1101 my $pid = open($fh, $direction);
1102 if (not defined $pid) {
1103 throw Error
::Simple
("open failed: $!");
1104 } elsif ($pid == 0) {
1105 if (defined $opts{STDERR
}) {
1108 if ($opts{STDERR
}) {
1109 open (STDERR
, '>&', $opts{STDERR
})
1110 or die "dup failed: $!";
1112 _cmd_exec
($self, $cmd, @args);
1115 return wantarray ?
($fh, join(' ', $cmd, @args)) : $fh;
1118 # When already in the subprocess, set up the appropriate state
1119 # for the given repository and execute the git command.
1121 my ($self, @args) = @_;
1123 $self->repo_path() and $ENV{'GIT_DIR'} = $self->repo_path();
1124 $self->wc_path() and chdir($self->wc_path());
1125 $self->wc_subdir() and chdir($self->wc_subdir());
1127 _execv_git_cmd
(@args);
1128 die qq[exec "@args" failed
: $!];
1131 # Execute the given Git command ($_[0]) with arguments ($_[1..])
1132 # by searching for it at proper places.
1133 sub _execv_git_cmd
{ exec('git', @_); }
1135 # Close pipe to a subprocess.
1137 my ($fh, $ctx) = @_;
1138 if (not close $fh) {
1140 # It's just close, no point in fatalities
1141 carp
"error closing pipe: $!";
1143 # The caller should pepper this.
1144 throw Git
::Error
::Command
($ctx, $?
>> 8);
1146 # else we might e.g. closed a live stream; the command
1147 # dying of SIGPIPE would drive us here.
1154 $self->_close_hash_and_insert_object();
1155 $self->_close_cat_blob();
1159 # Pipe implementation for ActiveState Perl.
1161 package Git
::activestate_pipe
;
1165 my ($class, @params) = @_;
1166 # FIXME: This is probably horrible idea and the thing will explode
1167 # at the moment you give it arguments that require some quoting,
1168 # but I have no ActiveState clue... --pasky
1169 # Let's just hope ActiveState Perl does at least the quoting
1171 my @data = qx{git
@params};
1172 bless { i
=> 0, data
=> \
@data }, $class;
1177 if ($self->{i
} >= scalar @
{$self->{data
}}) {
1182 $self->{i
} = $#{$self->{'data'}} + 1;
1183 return splice(@
{$self->{'data'}}, $i);
1185 $self->{i
} = $i + 1;
1186 return $self->{'data'}->[ $i ];
1191 delete $self->{data
};
1197 return ($self->{i
} >= scalar @
{$self->{data
}});
1201 1; # Famous last words