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