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