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