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