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