Git.pm: refactor command_close_bidi_pipe to use _cmd_close
[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 269 # Nothing to pepper the possible exception with.
1323dba6 270 _cmd_close($ctx, $fh);
b1edc53d
PB
271
272 } elsif (not wantarray) {
273 local $/;
274 my $text = <$fh>;
8b9150e3 275 try {
1323dba6 276 _cmd_close($ctx, $fh);
8b9150e3
PB
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 288 try {
1323dba6 289 _cmd_close($ctx, $fh);
8b9150e3
PB
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 315 try {
1323dba6 316 _cmd_close($ctx, $fh);
8b9150e3
PB
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>';
1323dba6 384 _cmd_close($ctx, $fh);
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');
8a2cc51b 421 print $out "000000000\n";
d1a29af9
AR
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 $?;
1bc760ae 433 my ($self, $pid, $in, $out, $ctx) = _maybe_self(@_);
1323dba6 434 _cmd_close($ctx, $in, $out);
d1a29af9 435 waitpid $pid, 0;
d1a29af9
AR
436 if ($? >> 8) {
437 throw Git::Error::Command($ctx, $? >>8);
438 }
439}
440
b1edc53d
PB
441
442=item command_noisy ( COMMAND [, ARGUMENTS... ] )
443
444Execute the given C<COMMAND> in the same way as command() does but do not
445capture the command output - the standard output is not redirected and goes
446to the standard output of the caller application.
447
448While the method is called command_noisy(), you might want to as well use
449it for the most silent Git commands which you know will never pollute your
450stdout but you want to avoid the overhead of the pipe setup when calling them.
451
452The function returns only after the command has finished running.
453
454=cut
455
456sub command_noisy {
457 my ($self, $cmd, @args) = _maybe_self(@_);
d79850e1 458 _check_valid_cmd($cmd);
b1edc53d
PB
459
460 my $pid = fork;
461 if (not defined $pid) {
97b16c06 462 throw Error::Simple("fork failed: $!");
b1edc53d
PB
463 } elsif ($pid == 0) {
464 _cmd_exec($self, $cmd, @args);
465 }
8b9150e3
PB
466 if (waitpid($pid, 0) > 0 and $?>>8 != 0) {
467 throw Git::Error::Command(join(' ', $cmd, @args), $? >> 8);
b1edc53d
PB
468 }
469}
470
471
63df97ae
PB
472=item version ()
473
474Return the Git version in use.
475
63df97ae
PB
476=cut
477
18b0fc1c
PB
478sub version {
479 my $verstr = command_oneline('--version');
480 $verstr =~ s/^git version //;
481 $verstr;
482}
63df97ae
PB
483
484
eca1f6fd
PB
485=item exec_path ()
486
d5c7721d 487Return path to the Git sub-command executables (the same as
eca1f6fd
PB
488C<git --exec-path>). Useful mostly only internally.
489
eca1f6fd
PB
490=cut
491
18b0fc1c 492sub exec_path { command_oneline('--exec-path') }
eca1f6fd
PB
493
494
89a56bfb
MH
495=item html_path ()
496
497Return path to the Git html documentation (the same as
498C<git --html-path>). Useful mostly only internally.
499
500=cut
501
502sub html_path { command_oneline('--html-path') }
503
e9263e45 504=item prompt ( PROMPT , ISPASSWORD )
38ecf3a3
SS
505
506Query user C<PROMPT> and return answer from user.
507
8f3cab2b
SS
508Honours GIT_ASKPASS and SSH_ASKPASS environment variables for querying
509the user. If no *_ASKPASS variable is set or an error occoured,
38ecf3a3 510the terminal is tried as a fallback.
e9263e45 511If C<ISPASSWORD> is set and true, the terminal disables echo.
38ecf3a3
SS
512
513=cut
514
515sub prompt {
e9263e45 516 my ($prompt, $isPassword) = @_;
38ecf3a3
SS
517 my $ret;
518 if (exists $ENV{'GIT_ASKPASS'}) {
519 $ret = _prompt($ENV{'GIT_ASKPASS'}, $prompt);
520 }
8f3cab2b
SS
521 if (!defined $ret && exists $ENV{'SSH_ASKPASS'}) {
522 $ret = _prompt($ENV{'SSH_ASKPASS'}, $prompt);
523 }
38ecf3a3
SS
524 if (!defined $ret) {
525 print STDERR $prompt;
526 STDERR->flush;
e9263e45
SS
527 if (defined $isPassword && $isPassword) {
528 require Term::ReadKey;
529 Term::ReadKey::ReadMode('noecho');
530 $ret = '';
531 while (defined(my $key = Term::ReadKey::ReadKey(0))) {
532 last if $key =~ /[\012\015]/; # \n\r
533 $ret .= $key;
534 }
535 Term::ReadKey::ReadMode('restore');
536 print STDERR "\n";
537 STDERR->flush;
538 } else {
539 chomp($ret = <STDIN>);
38ecf3a3 540 }
38ecf3a3
SS
541 }
542 return $ret;
543}
544
545sub _prompt {
546 my ($askpass, $prompt) = @_;
547 return unless length $askpass;
e9263e45 548 $prompt =~ s/\n/ /g;
38ecf3a3
SS
549 my $ret;
550 open my $fh, "-|", $askpass, $prompt or return;
551 $ret = <$fh>;
552 $ret =~ s/[\015\012]//g; # strip \r\n, chomp does not work on all systems (i.e. windows) as expected
553 close ($fh);
554 return $ret;
555}
89a56bfb 556
d5c7721d
PB
557=item repo_path ()
558
559Return path to the git repository. Must be called on a repository instance.
560
561=cut
562
563sub repo_path { $_[0]->{opts}->{Repository} }
564
565
566=item wc_path ()
567
568Return path to the working copy. Must be called on a repository instance.
569
570=cut
571
572sub wc_path { $_[0]->{opts}->{WorkingCopy} }
573
574
575=item wc_subdir ()
576
577Return path to the subdirectory inside of a working copy. Must be called
578on a repository instance.
579
580=cut
581
582sub wc_subdir { $_[0]->{opts}->{WorkingSubdir} ||= '' }
583
584
585=item wc_chdir ( SUBDIR )
586
587Change the working copy subdirectory to work within. The C<SUBDIR> is
588relative to the working copy root directory (not the current subdirectory).
589Must be called on a repository instance attached to a working copy
590and the directory must exist.
591
592=cut
593
594sub wc_chdir {
595 my ($self, $subdir) = @_;
d5c7721d
PB
596 $self->wc_path()
597 or throw Error::Simple("bare repository");
598
599 -d $self->wc_path().'/'.$subdir
64abcc48 600 or throw Error::Simple("subdir not found: $subdir $!");
d5c7721d
PB
601 # Of course we will not "hold" the subdirectory so anyone
602 # can delete it now and we will never know. But at least we tried.
603
604 $self->{opts}->{WorkingSubdir} = $subdir;
605}
606
607
dc2613de
PB
608=item config ( VARIABLE )
609
e0d10e1c 610Retrieve the configuration C<VARIABLE> in the same manner as C<config>
dc2613de
PB
611does. In scalar context requires the variable to be set only one time
612(exception is thrown otherwise), in array context returns allows the
613variable to be set multiple times and returns all the values.
614
dc2613de
PB
615=cut
616
617sub config {
6942a3d7 618 return _config_common({}, @_);
dc2613de
PB
619}
620
621
35c49eea 622=item config_bool ( VARIABLE )
7b9a13ec 623
35c49eea
PB
624Retrieve the bool configuration C<VARIABLE>. The return value
625is usable as a boolean in perl (and C<undef> if it's not defined,
626of course).
7b9a13ec 627
7b9a13ec
TT
628=cut
629
35c49eea 630sub config_bool {
6942a3d7 631 my $val = scalar _config_common({'kind' => '--bool'}, @_);
7b9a13ec 632
6942a3d7
JH
633 # Do not rewrite this as return (defined $val && $val eq 'true')
634 # as some callers do care what kind of falsehood they receive.
635 if (!defined $val) {
636 return undef;
637 } else {
35c49eea 638 return $val eq 'true';
6942a3d7 639 }
7b9a13ec
TT
640}
641
9fef9e27
CS
642
643=item config_path ( VARIABLE )
644
645Retrieve the path configuration C<VARIABLE>. The return value
646is an expanded path or C<undef> if it's not defined.
647
9fef9e27
CS
648=cut
649
650sub config_path {
6942a3d7 651 return _config_common({'kind' => '--path'}, @_);
9fef9e27
CS
652}
653
6942a3d7 654
346d203b
JN
655=item config_int ( VARIABLE )
656
657Retrieve the integer configuration C<VARIABLE>. The return value
658is simple decimal number. An optional value suffix of 'k', 'm',
659or 'g' in the config file will cause the value to be multiplied
660by 1024, 1048576 (1024^2), or 1073741824 (1024^3) prior to output.
661It would return C<undef> if configuration variable is not defined,
662
346d203b
JN
663=cut
664
665sub config_int {
6942a3d7
JH
666 return scalar _config_common({'kind' => '--int'}, @_);
667}
668
669# Common subroutine to implement bulk of what the config* family of methods
670# do. This curently wraps command('config') so it is not so fast.
671sub _config_common {
672 my ($opts) = shift @_;
c2e357c2 673 my ($self, $var) = _maybe_self(@_);
346d203b
JN
674
675 try {
6942a3d7 676 my @cmd = ('config', $opts->{'kind'} ? $opts->{'kind'} : ());
c2e357c2 677 unshift @cmd, $self if $self;
6942a3d7
JH
678 if (wantarray) {
679 return command(@cmd, '--get-all', $var);
680 } else {
681 return command_oneline(@cmd, '--get', $var);
682 }
346d203b
JN
683 } catch Git::Error::Command with {
684 my $E = shift;
685 if ($E->value() == 1) {
686 # Key not found.
6942a3d7 687 return;
346d203b
JN
688 } else {
689 throw $E;
690 }
691 };
692}
7b9a13ec 693
b4c61ed6
JH
694=item get_colorbool ( NAME )
695
696Finds if color should be used for NAMEd operation from the configuration,
697and returns boolean (true for "use color", false for "do not use color").
698
699=cut
700
701sub get_colorbool {
702 my ($self, $var) = @_;
703 my $stdout_to_tty = (-t STDOUT) ? "true" : "false";
704 my $use_color = $self->command_oneline('config', '--get-colorbool',
705 $var, $stdout_to_tty);
706 return ($use_color eq 'true');
707}
708
709=item get_color ( SLOT, COLOR )
710
711Finds color for SLOT from the configuration, while defaulting to COLOR,
712and returns the ANSI color escape sequence:
713
714 print $repo->get_color("color.interactive.prompt", "underline blue white");
715 print "some text";
716 print $repo->get_color("", "normal");
717
718=cut
719
720sub get_color {
721 my ($self, $slot, $default) = @_;
722 my $color = $self->command_oneline('config', '--get-color', $slot, $default);
723 if (!defined $color) {
724 $color = "";
725 }
726 return $color;
727}
728
31a92f6a
PB
729=item remote_refs ( REPOSITORY [, GROUPS [, REFGLOBS ] ] )
730
731This function returns a hashref of refs stored in a given remote repository.
732The hash is in the format C<refname =\> hash>. For tags, the C<refname> entry
733contains the tag object while a C<refname^{}> entry gives the tagged objects.
734
735C<REPOSITORY> has the same meaning as the appropriate C<git-ls-remote>
a7793a74 736argument; either a URL or a remote name (if called on a repository instance).
31a92f6a
PB
737C<GROUPS> is an optional arrayref that can contain 'tags' to return all the
738tags and/or 'heads' to return all the heads. C<REFGLOB> is an optional array
739of strings containing a shell-like glob to further limit the refs returned in
740the hash; the meaning is again the same as the appropriate C<git-ls-remote>
741argument.
742
743This function may or may not be called on a repository instance. In the former
744case, remote names as defined in the repository are recognized as repository
745specifiers.
746
747=cut
748
749sub remote_refs {
750 my ($self, $repo, $groups, $refglobs) = _maybe_self(@_);
751 my @args;
752 if (ref $groups eq 'ARRAY') {
753 foreach (@$groups) {
754 if ($_ eq 'heads') {
755 push (@args, '--heads');
756 } elsif ($_ eq 'tags') {
757 push (@args, '--tags');
758 } else {
759 # Ignore unknown groups for future
760 # compatibility
761 }
762 }
763 }
764 push (@args, $repo);
765 if (ref $refglobs eq 'ARRAY') {
766 push (@args, @$refglobs);
767 }
768
769 my @self = $self ? ($self) : (); # Ultra trickery
770 my ($fh, $ctx) = Git::command_output_pipe(@self, 'ls-remote', @args);
771 my %refs;
772 while (<$fh>) {
773 chomp;
774 my ($hash, $ref) = split(/\t/, $_, 2);
775 $refs{$ref} = $hash;
776 }
777 Git::command_close_pipe(@self, $fh, $ctx);
778 return \%refs;
779}
780
781
c7a30e56
PB
782=item ident ( TYPE | IDENTSTR )
783
784=item ident_person ( TYPE | IDENTSTR | IDENTARRAY )
785
786This suite of functions retrieves and parses ident information, as stored
787in the commit and tag objects or produced by C<var GIT_type_IDENT> (thus
788C<TYPE> can be either I<author> or I<committer>; case is insignificant).
789
5354a56f 790The C<ident> method retrieves the ident information from C<git var>
c7a30e56
PB
791and either returns it as a scalar string or as an array with the fields parsed.
792Alternatively, it can take a prepared ident string (e.g. from the commit
793object) and just parse it.
794
795C<ident_person> returns the person part of the ident - name and email;
796it can take the same arguments as C<ident> or the array returned by C<ident>.
797
798The synopsis is like:
799
800 my ($name, $email, $time_tz) = ident('author');
801 "$name <$email>" eq ident_person('author');
802 "$name <$email>" eq ident_person($name);
803 $time_tz =~ /^\d+ [+-]\d{4}$/;
804
c7a30e56
PB
805=cut
806
807sub ident {
44617928 808 my ($self, $type) = _maybe_self(@_);
c7a30e56
PB
809 my $identstr;
810 if (lc $type eq lc 'committer' or lc $type eq lc 'author') {
44617928
FL
811 my @cmd = ('var', 'GIT_'.uc($type).'_IDENT');
812 unshift @cmd, $self if $self;
813 $identstr = command_oneline(@cmd);
c7a30e56
PB
814 } else {
815 $identstr = $type;
816 }
817 if (wantarray) {
818 return $identstr =~ /^(.*) <(.*)> (\d+ [+-]\d{4})$/;
819 } else {
820 return $identstr;
821 }
822}
823
824sub ident_person {
44617928
FL
825 my ($self, @ident) = _maybe_self(@_);
826 $#ident == 0 and @ident = $self ? $self->ident($ident[0]) : ident($ident[0]);
c7a30e56
PB
827 return "$ident[0] <$ident[1]>";
828}
829
830
24c4b714 831=item hash_object ( TYPE, FILENAME )
b1edc53d 832
58c8dd21
LW
833Compute the SHA1 object id of the given C<FILENAME> considering it is
834of the C<TYPE> object type (C<blob>, C<commit>, C<tree>).
b1edc53d 835
b1edc53d
PB
836The method can be called without any instance or on a specified Git repository,
837it makes zero difference.
838
839The function returns the SHA1 hash.
840
b1edc53d
PB
841=cut
842
18b0fc1c 843# TODO: Support for passing FILEHANDLE instead of FILENAME
e6634ac9
PB
844sub hash_object {
845 my ($self, $type, $file) = _maybe_self(@_);
18b0fc1c 846 command_oneline('hash-object', '-t', $type, $file);
e6634ac9 847}
b1edc53d
PB
848
849
7182530d
AR
850=item hash_and_insert_object ( FILENAME )
851
852Compute the SHA1 object id of the given C<FILENAME> and add the object to the
853object database.
854
855The function returns the SHA1 hash.
856
857=cut
858
859# TODO: Support for passing FILEHANDLE instead of FILENAME
860sub hash_and_insert_object {
861 my ($self, $filename) = @_;
862
863 carp "Bad filename \"$filename\"" if $filename =~ /[\r\n]/;
864
865 $self->_open_hash_and_insert_object_if_needed();
866 my ($in, $out) = ($self->{hash_object_in}, $self->{hash_object_out});
867
868 unless (print $out $filename, "\n") {
869 $self->_close_hash_and_insert_object();
870 throw Error::Simple("out pipe went bad");
871 }
872
873 chomp(my $hash = <$in>);
874 unless (defined($hash)) {
875 $self->_close_hash_and_insert_object();
876 throw Error::Simple("in pipe went bad");
877 }
878
879 return $hash;
880}
881
882sub _open_hash_and_insert_object_if_needed {
883 my ($self) = @_;
884
885 return if defined($self->{hash_object_pid});
886
887 ($self->{hash_object_pid}, $self->{hash_object_in},
888 $self->{hash_object_out}, $self->{hash_object_ctx}) =
48d9e6ae 889 $self->command_bidi_pipe(qw(hash-object -w --stdin-paths --no-filters));
7182530d
AR
890}
891
892sub _close_hash_and_insert_object {
893 my ($self) = @_;
894
895 return unless defined($self->{hash_object_pid});
896
897 my @vars = map { 'hash_object_' . $_ } qw(pid in out ctx);
898
452d36b1
AMS
899 command_close_bidi_pipe(@$self{@vars});
900 delete @$self{@vars};
7182530d
AR
901}
902
903=item cat_blob ( SHA1, FILEHANDLE )
904
905Prints the contents of the blob identified by C<SHA1> to C<FILEHANDLE> and
906returns the number of bytes printed.
907
908=cut
909
910sub cat_blob {
911 my ($self, $sha1, $fh) = @_;
912
913 $self->_open_cat_blob_if_needed();
914 my ($in, $out) = ($self->{cat_blob_in}, $self->{cat_blob_out});
915
916 unless (print $out $sha1, "\n") {
917 $self->_close_cat_blob();
918 throw Error::Simple("out pipe went bad");
919 }
920
921 my $description = <$in>;
922 if ($description =~ / missing$/) {
923 carp "$sha1 doesn't exist in the repository";
d683a0e0 924 return -1;
7182530d
AR
925 }
926
927 if ($description !~ /^[0-9a-fA-F]{40} \S+ (\d+)$/) {
928 carp "Unexpected result returned from git cat-file";
d683a0e0 929 return -1;
7182530d
AR
930 }
931
932 my $size = $1;
933
934 my $blob;
935 my $bytesRead = 0;
936
937 while (1) {
938 my $bytesLeft = $size - $bytesRead;
939 last unless $bytesLeft;
940
941 my $bytesToRead = $bytesLeft < 1024 ? $bytesLeft : 1024;
942 my $read = read($in, $blob, $bytesToRead, $bytesRead);
943 unless (defined($read)) {
944 $self->_close_cat_blob();
945 throw Error::Simple("in pipe went bad");
946 }
947
948 $bytesRead += $read;
949 }
950
951 # Skip past the trailing newline.
952 my $newline;
953 my $read = read($in, $newline, 1);
954 unless (defined($read)) {
955 $self->_close_cat_blob();
956 throw Error::Simple("in pipe went bad");
957 }
958 unless ($read == 1 && $newline eq "\n") {
959 $self->_close_cat_blob();
960 throw Error::Simple("didn't find newline after blob");
961 }
962
963 unless (print $fh $blob) {
964 $self->_close_cat_blob();
965 throw Error::Simple("couldn't write to passed in filehandle");
966 }
967
968 return $size;
969}
970
971sub _open_cat_blob_if_needed {
972 my ($self) = @_;
973
974 return if defined($self->{cat_blob_pid});
975
976 ($self->{cat_blob_pid}, $self->{cat_blob_in},
977 $self->{cat_blob_out}, $self->{cat_blob_ctx}) =
48d9e6ae 978 $self->command_bidi_pipe(qw(cat-file --batch));
7182530d
AR
979}
980
981sub _close_cat_blob {
982 my ($self) = @_;
983
984 return unless defined($self->{cat_blob_pid});
985
986 my @vars = map { 'cat_blob_' . $_ } qw(pid in out ctx);
987
452d36b1
AMS
988 command_close_bidi_pipe(@$self{@vars});
989 delete @$self{@vars};
7182530d 990}
8b9150e3 991
e41352b2
MG
992
993{ # %TEMP_* Lexical Context
994
836ff95d 995my (%TEMP_FILEMAP, %TEMP_FILES);
e41352b2
MG
996
997=item temp_acquire ( NAME )
998
999Attempts to retreive the temporary file mapped to the string C<NAME>. If an
1000associated temp file has not been created this session or was closed, it is
1001created, cached, and set for autoflush and binmode.
1002
1003Internally locks the file mapped to C<NAME>. This lock must be released with
1004C<temp_release()> when the temp file is no longer needed. Subsequent attempts
1005to retrieve temporary files mapped to the same C<NAME> while still locked will
1006cause an error. This locking mechanism provides a weak guarantee and is not
1007threadsafe. It does provide some error checking to help prevent temp file refs
1008writing over one another.
1009
1010In general, the L<File::Handle> returned should not be closed by consumers as
1011it defeats the purpose of this caching mechanism. If you need to close the temp
1012file handle, then you should use L<File::Temp> or another temp file faculty
1013directly. If a handle is closed and then requested again, then a warning will
1014issue.
1015
1016=cut
1017
1018sub temp_acquire {
bcdd1b44 1019 my $temp_fd = _temp_cache(@_);
e41352b2 1020
836ff95d 1021 $TEMP_FILES{$temp_fd}{locked} = 1;
e41352b2
MG
1022 $temp_fd;
1023}
1024
1025=item temp_release ( NAME )
1026
1027=item temp_release ( FILEHANDLE )
1028
1029Releases a lock acquired through C<temp_acquire()>. Can be called either with
1030the C<NAME> mapping used when acquiring the temp file or with the C<FILEHANDLE>
1031referencing a locked temp file.
1032
1033Warns if an attempt is made to release a file that is not locked.
1034
1035The temp file will be truncated before being released. This can help to reduce
1036disk I/O where the system is smart enough to detect the truncation while data
1037is in the output buffers. Beware that after the temp file is released and
1038truncated, any operations on that file may fail miserably until it is
1039re-acquired. All contents are lost between each release and acquire mapped to
1040the same string.
1041
1042=cut
1043
1044sub temp_release {
1045 my ($self, $temp_fd, $trunc) = _maybe_self(@_);
1046
836ff95d 1047 if (exists $TEMP_FILEMAP{$temp_fd}) {
e41352b2
MG
1048 $temp_fd = $TEMP_FILES{$temp_fd};
1049 }
836ff95d 1050 unless ($TEMP_FILES{$temp_fd}{locked}) {
e41352b2
MG
1051 carp "Attempt to release temp file '",
1052 $temp_fd, "' that has not been locked";
1053 }
1054 temp_reset($temp_fd) if $trunc and $temp_fd->opened;
1055
836ff95d 1056 $TEMP_FILES{$temp_fd}{locked} = 0;
e41352b2
MG
1057 undef;
1058}
1059
1060sub _temp_cache {
bcdd1b44 1061 my ($self, $name) = _maybe_self(@_);
e41352b2 1062
c14c8ceb
MG
1063 _verify_require();
1064
836ff95d 1065 my $temp_fd = \$TEMP_FILEMAP{$name};
e41352b2 1066 if (defined $$temp_fd and $$temp_fd->opened) {
836ff95d 1067 if ($TEMP_FILES{$$temp_fd}{locked}) {
8faea4f3
JS
1068 throw Error::Simple("Temp file with moniker '" .
1069 $name . "' already in use");
e41352b2
MG
1070 }
1071 } else {
1072 if (defined $$temp_fd) {
1073 # then we're here because of a closed handle.
1074 carp "Temp file '", $name,
1075 "' was closed. Opening replacement.";
1076 }
836ff95d 1077 my $fname;
bcdd1b44
MS
1078
1079 my $tmpdir;
1080 if (defined $self) {
1081 $tmpdir = $self->repo_path();
1082 }
1083
836ff95d 1084 ($$temp_fd, $fname) = File::Temp->tempfile(
bcdd1b44 1085 'Git_XXXXXX', UNLINK => 1, DIR => $tmpdir,
e41352b2 1086 ) or throw Error::Simple("couldn't open new temp file");
bcdd1b44 1087
e41352b2
MG
1088 $$temp_fd->autoflush;
1089 binmode $$temp_fd;
836ff95d 1090 $TEMP_FILES{$$temp_fd}{fname} = $fname;
e41352b2
MG
1091 }
1092 $$temp_fd;
1093}
1094
c14c8ceb
MG
1095sub _verify_require {
1096 eval { require File::Temp; require File::Spec; };
1097 $@ and throw Error::Simple($@);
1098}
1099
e41352b2
MG
1100=item temp_reset ( FILEHANDLE )
1101
1102Truncates and resets the position of the C<FILEHANDLE>.
1103
1104=cut
1105
1106sub temp_reset {
1107 my ($self, $temp_fd) = _maybe_self(@_);
1108
1109 truncate $temp_fd, 0
1110 or throw Error::Simple("couldn't truncate file");
1111 sysseek($temp_fd, 0, SEEK_SET) and seek($temp_fd, 0, SEEK_SET)
1112 or throw Error::Simple("couldn't seek to beginning of file");
1113 sysseek($temp_fd, 0, SEEK_CUR) == 0 and tell($temp_fd) == 0
1114 or throw Error::Simple("expected file position to be reset");
1115}
1116
836ff95d
MG
1117=item temp_path ( NAME )
1118
1119=item temp_path ( FILEHANDLE )
1120
1121Returns the filename associated with the given tempfile.
1122
1123=cut
1124
1125sub temp_path {
1126 my ($self, $temp_fd) = _maybe_self(@_);
1127
1128 if (exists $TEMP_FILEMAP{$temp_fd}) {
1129 $temp_fd = $TEMP_FILEMAP{$temp_fd};
1130 }
1131 $TEMP_FILES{$temp_fd}{fname};
1132}
1133
e41352b2 1134sub END {
836ff95d 1135 unlink values %TEMP_FILEMAP if %TEMP_FILEMAP;
e41352b2
MG
1136}
1137
1138} # %TEMP_* Lexical Context
1139
b1edc53d
PB
1140=back
1141
97b16c06 1142=head1 ERROR HANDLING
b1edc53d 1143
97b16c06 1144All functions are supposed to throw Perl exceptions in case of errors.
8b9150e3
PB
1145See the L<Error> module on how to catch those. Most exceptions are mere
1146L<Error::Simple> instances.
1147
1148However, the C<command()>, C<command_oneline()> and C<command_noisy()>
1149functions suite can throw C<Git::Error::Command> exceptions as well: those are
1150thrown when the external command returns an error code and contain the error
1151code as well as access to the captured command's output. The exception class
1152provides the usual C<stringify> and C<value> (command's exit code) methods and
1153in addition also a C<cmd_output> method that returns either an array or a
1154string with the captured command output (depending on the original function
1155call context; C<command_noisy()> returns C<undef>) and $<cmdline> which
1156returns the command and its arguments (but without proper quoting).
1157
d79850e1 1158Note that the C<command_*_pipe()> functions cannot throw this exception since
8b9150e3
PB
1159it has no idea whether the command failed or not. You will only find out
1160at the time you C<close> the pipe; if you want to have that automated,
1161use C<command_close_pipe()>, which can throw the exception.
1162
1163=cut
1164
1165{
1166 package Git::Error::Command;
1167
1168 @Git::Error::Command::ISA = qw(Error);
1169
1170 sub new {
1171 my $self = shift;
1172 my $cmdline = '' . shift;
1173 my $value = 0 + shift;
1174 my $outputref = shift;
1175 my(@args) = ();
1176
1177 local $Error::Depth = $Error::Depth + 1;
1178
1179 push(@args, '-cmdline', $cmdline);
1180 push(@args, '-value', $value);
1181 push(@args, '-outputref', $outputref);
1182
1183 $self->SUPER::new(-text => 'command returned error', @args);
1184 }
1185
1186 sub stringify {
1187 my $self = shift;
1188 my $text = $self->SUPER::stringify;
1189 $self->cmdline() . ': ' . $text . ': ' . $self->value() . "\n";
1190 }
1191
1192 sub cmdline {
1193 my $self = shift;
1194 $self->{'-cmdline'};
1195 }
1196
1197 sub cmd_output {
1198 my $self = shift;
1199 my $ref = $self->{'-outputref'};
1200 defined $ref or undef;
1201 if (ref $ref eq 'ARRAY') {
1202 return @$ref;
1203 } else { # SCALAR
1204 return $$ref;
1205 }
1206 }
1207}
1208
1209=over 4
1210
1211=item git_cmd_try { CODE } ERRMSG
1212
1213This magical statement will automatically catch any C<Git::Error::Command>
1214exceptions thrown by C<CODE> and make your program die with C<ERRMSG>
1215on its lips; the message will have %s substituted for the command line
1216and %d for the exit status. This statement is useful mostly for producing
1217more user-friendly error messages.
1218
1219In case of no exception caught the statement returns C<CODE>'s return value.
1220
1221Note that this is the only auto-exported function.
1222
1223=cut
1224
1225sub git_cmd_try(&$) {
1226 my ($code, $errmsg) = @_;
1227 my @result;
1228 my $err;
1229 my $array = wantarray;
1230 try {
1231 if ($array) {
1232 @result = &$code;
1233 } else {
1234 $result[0] = &$code;
1235 }
1236 } catch Git::Error::Command with {
1237 my $E = shift;
1238 $err = $errmsg;
1239 $err =~ s/\%s/$E->cmdline()/ge;
1240 $err =~ s/\%d/$E->value()/ge;
1241 # We can't croak here since Error.pm would mangle
1242 # that to Error::Simple.
1243 };
1244 $err and croak $err;
1245 return $array ? @result : $result[0];
1246}
1247
1248
1249=back
b1edc53d
PB
1250
1251=head1 COPYRIGHT
1252
1253Copyright 2006 by Petr Baudis E<lt>pasky@suse.czE<gt>.
1254
1255This module is free software; it may be used, copied, modified
1256and distributed under the terms of the GNU General Public Licence,
1257either version 2, or (at your option) any later version.
1258
1259=cut
1260
1261
1262# Take raw method argument list and return ($obj, @args) in case
1263# the method was called upon an instance and (undef, @args) if
1264# it was called directly.
1265sub _maybe_self {
d8b24b93 1266 UNIVERSAL::isa($_[0], 'Git') ? @_ : (undef, @_);
b1edc53d
PB
1267}
1268
d79850e1
PB
1269# Check if the command id is something reasonable.
1270sub _check_valid_cmd {
1271 my ($cmd) = @_;
1272 $cmd =~ /^[a-z0-9A-Z_-]+$/ or throw Error::Simple("bad command: $cmd");
1273}
1274
1275# Common backend for the pipe creators.
1276sub _command_common_pipe {
1277 my $direction = shift;
d43ba468
PB
1278 my ($self, @p) = _maybe_self(@_);
1279 my (%opts, $cmd, @args);
1280 if (ref $p[0]) {
1281 ($cmd, @args) = @{shift @p};
1282 %opts = ref $p[0] ? %{$p[0]} : @p;
1283 } else {
1284 ($cmd, @args) = @p;
1285 }
d79850e1
PB
1286 _check_valid_cmd($cmd);
1287
a6065b54 1288 my $fh;
d3b1785f 1289 if ($^O eq 'MSWin32') {
a6065b54
PB
1290 # ActiveState Perl
1291 #defined $opts{STDERR} and
1292 # warn 'ignoring STDERR option - running w/ ActiveState';
1293 $direction eq '-|' or
1294 die 'input pipe for ActiveState not implemented';
bed118d6
AR
1295 # the strange construction with *ACPIPE is just to
1296 # explain the tie below that we want to bind to
1297 # a handle class, not scalar. It is not known if
1298 # it is something specific to ActiveState Perl or
1299 # just a Perl quirk.
1300 tie (*ACPIPE, 'Git::activestate_pipe', $cmd, @args);
1301 $fh = *ACPIPE;
a6065b54
PB
1302
1303 } else {
1304 my $pid = open($fh, $direction);
1305 if (not defined $pid) {
1306 throw Error::Simple("open failed: $!");
1307 } elsif ($pid == 0) {
1308 if (defined $opts{STDERR}) {
1309 close STDERR;
1310 }
1311 if ($opts{STDERR}) {
1312 open (STDERR, '>&', $opts{STDERR})
1313 or die "dup failed: $!";
1314 }
1315 _cmd_exec($self, $cmd, @args);
d43ba468 1316 }
d79850e1
PB
1317 }
1318 return wantarray ? ($fh, join(' ', $cmd, @args)) : $fh;
1319}
1320
b1edc53d
PB
1321# When already in the subprocess, set up the appropriate state
1322# for the given repository and execute the git command.
1323sub _cmd_exec {
1324 my ($self, @args) = @_;
48d9e6ae
MO
1325 _setup_git_cmd_env($self);
1326 _execv_git_cmd(@args);
1327 die qq[exec "@args" failed: $!];
1328}
1329
1330# set up the appropriate state for git command
1331sub _setup_git_cmd_env {
1332 my $self = shift;
b1edc53d 1333 if ($self) {
d5c7721d 1334 $self->repo_path() and $ENV{'GIT_DIR'} = $self->repo_path();
da159c77
FL
1335 $self->repo_path() and $self->wc_path()
1336 and $ENV{'GIT_WORK_TREE'} = $self->wc_path();
d5c7721d
PB
1337 $self->wc_path() and chdir($self->wc_path());
1338 $self->wc_subdir() and chdir($self->wc_subdir());
b1edc53d 1339 }
b1edc53d
PB
1340}
1341
8062f81c
PB
1342# Execute the given Git command ($_[0]) with arguments ($_[1..])
1343# by searching for it at proper places.
18b0fc1c 1344sub _execv_git_cmd { exec('git', @_); }
8062f81c 1345
b1edc53d
PB
1346# Close pipe to a subprocess.
1347sub _cmd_close {
1323dba6
MN
1348 my $ctx = shift @_;
1349 foreach my $fh (@_) {
1350 if (close $fh) {
1351 # nop
1352 } elsif ($!) {
b1edc53d
PB
1353 # It's just close, no point in fatalities
1354 carp "error closing pipe: $!";
1355 } elsif ($? >> 8) {
8b9150e3
PB
1356 # The caller should pepper this.
1357 throw Git::Error::Command($ctx, $? >> 8);
b1edc53d
PB
1358 }
1359 # else we might e.g. closed a live stream; the command
1360 # dying of SIGPIPE would drive us here.
1361 }
1362}
1363
1364
7182530d
AR
1365sub DESTROY {
1366 my ($self) = @_;
1367 $self->_close_hash_and_insert_object();
1368 $self->_close_cat_blob();
1369}
b1edc53d
PB
1370
1371
a6065b54
PB
1372# Pipe implementation for ActiveState Perl.
1373
1374package Git::activestate_pipe;
1375use strict;
1376
1377sub TIEHANDLE {
1378 my ($class, @params) = @_;
1379 # FIXME: This is probably horrible idea and the thing will explode
1380 # at the moment you give it arguments that require some quoting,
1381 # but I have no ActiveState clue... --pasky
d3b1785f
AR
1382 # Let's just hope ActiveState Perl does at least the quoting
1383 # correctly.
1384 my @data = qx{git @params};
a6065b54
PB
1385 bless { i => 0, data => \@data }, $class;
1386}
1387
1388sub READLINE {
1389 my $self = shift;
1390 if ($self->{i} >= scalar @{$self->{data}}) {
1391 return undef;
1392 }
2f5b3980
AR
1393 my $i = $self->{i};
1394 if (wantarray) {
1395 $self->{i} = $#{$self->{'data'}} + 1;
1396 return splice(@{$self->{'data'}}, $i);
1397 }
1398 $self->{i} = $i + 1;
1399 return $self->{'data'}->[ $i ];
a6065b54
PB
1400}
1401
1402sub CLOSE {
1403 my $self = shift;
1404 delete $self->{data};
1405 delete $self->{i};
1406}
1407
1408sub EOF {
1409 my $self = shift;
1410 return ($self->{i} >= scalar @{$self->{data}});
1411}
1412
1413
b1edc53d 14141; # Famous last words