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