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