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