perl/Git.pm

   1 =head1 NAME
   2
   3 Git - Perl interface to the Git version control system
   4
   5 =cut
   6
   7
   8 package Git;
   9
  10 use strict;
  11
  12
  13 BEGIN {
  14
  15 our ($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
  27   git_cmd_try { Git::command_noisy('update-server-info') }
  28               '%s failed w/ code %d';
  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
  35   my ($fh, $c) = $repo->command_output_pipe('rev-list', '--since=last monday', '--all');
  36   my $lastrev = <$fh>; chomp $lastrev;
  37   $repo->command_close_pipe($fh, $c);
  38
  39   my $lastrev = $repo->command_oneline( [ 'rev-list', '--all' ],
  40                                         STDERR => 0 );
  41
  42 =cut
  43
  44
  45 require Exporter;
  46
  47 @ISA = qw(Exporter);
  48
  49 @EXPORT = qw(git_cmd_try);
  50
  51 # Methods which can be called as standalone functions as well:
  52 @EXPORT_OK = qw(command command_oneline command_noisy
  53                 command_output_pipe command_input_pipe command_close_pipe
  54                 command_bidi_pipe command_close_bidi_pipe
  55                 version exec_path hash_object git_cmd_try);
  56
  57
  58 =head1 DESCRIPTION
  59
  60 This module provides Perl scripts easy way to interface the Git version control
  61 system. The modules have an easy and well-tested way to call arbitrary Git
  62 commands; in the future, the interface will also provide specialized methods
  63 for doing easily operations which are not totally trivial to do over
  64 the generic command interface.
  65
  66 While some commands can be executed outside of any context (e.g. 'version'
  67 or 'init'), most operations require a repository context, which in practice
  68 means 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
  70 called as methods of the object are then executed in the context of the
  71 repository.
  72
  73 Part of the "repository state" is also information about path to the attached
  74 working copy (unless you work with a bare repository). You can also navigate
  75 inside of the working copy using the C<wc_chdir()> method. (Note that
  76 the repository object is self-contained and will not change working directory
  77 of your process.)
  78
  79 TODO: In the future, we might also do
  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
  85 Currently, the module merely wraps calls to external Git tools. In the future,
  86 it will provide a much faster way to interact with Git by linking directly
  87 to libgit. This should be completely opaque to the user, though (performance
  88 increate nonwithstanding).
  89
  90 =cut
  91
  92
  93 use Carp qw(carp croak); # but croak is bad - throw instead
  94 use Error qw(:try);
  95 use Cwd qw(abs_path);
  96 use IPC::Open2 qw(open2);
  97
  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
 111 Construct a new repository object.
 112 C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
 113 Possible options are:
 114
 115 B<Repository> - Path to the Git repository.
 116
 117 B<WorkingCopy> - Path to the associated working copy; not strictly required
 118 as many commands will happily crunch on a bare repository.
 119
 120 B<WorkingSubdir> - Subdirectory in the working copy to work inside.
 121 Just left undefined if you do not want to limit the scope of operations.
 122
 123 B<Directory> - Path to the Git working directory in its usual setup.
 124 The C<.git> directory is searched in the directory and all the parent
 125 directories; if found, C<WorkingCopy> is set to the directory containing
 126 it and C<Repository> to the C<.git> directory itself. If no C<.git>
 127 directory was found, the C<Directory> is assumed to be a bare repository,
 128 C<Repository> is set to point at it and C<WorkingCopy> is left undefined.
 129 If the C<$GIT_DIR> environment variable is set, things behave as expected
 130 as well.
 131
 132 You should not use both C<Directory> and either of C<Repository> and
 133 C<WorkingCopy> - the results of that are undefined.
 134
 135 Alternatively, a directory path may be passed as a single scalar argument
 136 to the constructor; it is equivalent to setting only the C<Directory> option
 137 field.
 138
 139 Calling the constructor with no options whatsoever is equivalent to
 140 calling it with C<< Directory => '.' >>. In general, if you are building
 141 a standard porcelain command, simply doing C<< Git->repository() >> should
 142 do the right thing and setup the object to reflect exactly where the user
 143 is right now.
 144
 145 =cut
 146
 147 sub 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.
 156                         $#args == 0 or throw Error::Simple("bad usage");
 157                         %opts = ( Directory => $args[0] );
 158                 } else {
 159                         %opts = @args;
 160                 }
 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                 };
 178
 179                 if ($dir) {
 180                         $dir =~ m#^/# or $dir = $opts{Directory} . '/' . $dir;
 181                         $opts{Repository} = $dir;
 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)) = '';
 191                         }
 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);
 212                 }
 213
 214                 delete $opts{Directory};
 215         }
 216
 217         $self = { opts => \%opts };
 218         bless $self, $class;
 219 }
 220
 221
 222 =back
 223
 224 =head1 METHODS
 225
 226 =over 4
 227
 228 =item command ( COMMAND [, ARGUMENTS... ] )
 229
 230 =item command ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } )
 231
 232 Execute the given Git C<COMMAND> (specify it without the 'git-'
 233 prefix), optionally with the specified extra C<ARGUMENTS>.
 234
 235 The second more elaborate form can be used if you want to further adjust
 236 the command execution. Currently, only one option is supported:
 237
 238 B<STDERR> - How to deal with the command's error output. By default (C<undef>)
 239 it is delivered to the caller's C<STDERR>. A false value (0 or '') will cause
 240 it to be thrown away. If you want to process it, you can get it in a filehandle
 241 you specify, but you must be extremely careful; if the error output is not
 242 very short and you want to read it in the same process as where you called
 243 C<command()>, you are set up for a nice deadlock!
 244
 245 The 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
 248 In scalar context, it returns all the command output in a single string
 249 (verbatim).
 250
 251 In array context, it returns an array containing lines printed to the
 252 command's stdout (without trailing newlines).
 253
 254 In both cases, the command's stdin and stderr are the same as the caller's.
 255
 256 =cut
 257
 258 sub command {
 259         my ($fh, $ctx) = command_output_pipe(@_);
 260
 261         if (not defined wantarray) {
 262                 # Nothing to pepper the possible exception with.
 263                 _cmd_close($fh, $ctx);
 264
 265         } elsif (not wantarray) {
 266                 local $/;
 267                 my $text = <$fh>;
 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                 };
 276                 return $text;
 277
 278         } else {
 279                 my @lines = <$fh>;
 280                 defined and chomp for @lines;
 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                 };
 288                 return @lines;
 289         }
 290 }
 291
 292
 293 =item command_oneline ( COMMAND [, ARGUMENTS... ] )
 294
 295 =item command_oneline ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } )
 296
 297 Execute the given C<COMMAND> in the same way as command()
 298 does but always return a scalar string containing the first line
 299 of the command's standard output.
 300
 301 =cut
 302
 303 sub command_oneline {
 304         my ($fh, $ctx) = command_output_pipe(@_);
 305
 306         my $line = <$fh>;
 307         defined $line and chomp $line;
 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         };
 316         return $line;
 317 }
 318
 319
 320 =item command_output_pipe ( COMMAND [, ARGUMENTS... ] )
 321
 322 =item command_output_pipe ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } )
 323
 324 Execute the given C<COMMAND> in the same way as command()
 325 does but return a pipe filehandle from which the command output can be
 326 read.
 327
 328 The function can return C<($pipe, $ctx)> in array context.
 329 See C<command_close_pipe()> for details.
 330
 331 =cut
 332
 333 sub command_output_pipe {
 334         _command_common_pipe('-|', @_);
 335 }
 336
 337
 338 =item command_input_pipe ( COMMAND [, ARGUMENTS... ] )
 339
 340 =item command_input_pipe ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } )
 341
 342 Execute the given C<COMMAND> in the same way as command_output_pipe()
 343 does but return an input pipe filehandle instead; the command output
 344 is not captured.
 345
 346 The function can return C<($pipe, $ctx)> in array context.
 347 See C<command_close_pipe()> for details.
 348
 349 =cut
 350
 351 sub command_input_pipe {
 352         _command_common_pipe('|-', @_);
 353 }
 354
 355
 356 =item command_close_pipe ( PIPE [, CTX ] )
 357
 358 Close the C<PIPE> as returned from C<command_*_pipe()>, checking
 359 whether the command finished successfully. The optional C<CTX> argument
 360 is required if you want to see the command name in the error message,
 361 and it is the second value returned by C<command_*_pipe()> when
 362 called in array context. The call idiom is:
 363
 364         my ($fh, $ctx) = $r->command_output_pipe('status');
 365         while (<$fh>) { ... }
 366         $r->command_close_pipe($fh, $ctx);
 367
 368 Note that you should not rely on whatever actually is in C<CTX>;
 369 currently it is simply the command name but in future the context might
 370 have more complicated structure.
 371
 372 =cut
 373
 374 sub command_close_pipe {
 375         my ($self, $fh, $ctx) = _maybe_self(@_);
 376         $ctx ||= '<unknown>';
 377         _cmd_close($fh, $ctx);
 378 }
 379
 380 =item command_bidi_pipe ( COMMAND [, ARGUMENTS... ] )
 381
 382 Execute the given C<COMMAND> in the same way as command_output_pipe()
 383 does but return both an input pipe filehandle and an output pipe filehandle.
 384
 385 The function will return return C<($pid, $pipe_in, $pipe_out, $ctx)>.
 386 See C<command_close_bidi_pipe()> for details.
 387
 388 =cut
 389
 390 sub 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
 398 Close the C<PIPE_IN> and C<PIPE_OUT> as returned from C<command_bidi_pipe()>,
 399 checking whether the command finished successfully. The optional C<CTX>
 400 argument is required if you want to see the command name in the error message,
 401 and it is the fourth value returned by C<command_bidi_pipe()>.  The call idiom
 402 is:
 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
 409 Note that you should not rely on whatever actually is in C<CTX>;
 410 currently it is simply the command name but in future the context might
 411 have more complicated structure.
 412
 413 =cut
 414
 415 sub 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
 434
 435 =item command_noisy ( COMMAND [, ARGUMENTS... ] )
 436
 437 Execute the given C<COMMAND> in the same way as command() does but do not
 438 capture the command output - the standard output is not redirected and goes
 439 to the standard output of the caller application.
 440
 441 While the method is called command_noisy(), you might want to as well use
 442 it for the most silent Git commands which you know will never pollute your
 443 stdout but you want to avoid the overhead of the pipe setup when calling them.
 444
 445 The function returns only after the command has finished running.
 446
 447 =cut
 448
 449 sub command_noisy {
 450         my ($self, $cmd, @args) = _maybe_self(@_);
 451         _check_valid_cmd($cmd);
 452
 453         my $pid = fork;
 454         if (not defined $pid) {
 455                 throw Error::Simple("fork failed: $!");
 456         } elsif ($pid == 0) {
 457                 _cmd_exec($self, $cmd, @args);
 458         }
 459         if (waitpid($pid, 0) > 0 and $?>>8 != 0) {
 460                 throw Git::Error::Command(join(' ', $cmd, @args), $? >> 8);
 461         }
 462 }
 463
 464
 465 =item version ()
 466
 467 Return the Git version in use.
 468
 469 =cut
 470
 471 sub version {
 472         my $verstr = command_oneline('--version');
 473         $verstr =~ s/^git version //;
 474         $verstr;
 475 }
 476
 477
 478 =item exec_path ()
 479
 480 Return path to the Git sub-command executables (the same as
 481 C<git --exec-path>). Useful mostly only internally.
 482
 483 =cut
 484
 485 sub exec_path { command_oneline('--exec-path') }
 486
 487
 488 =item repo_path ()
 489
 490 Return path to the git repository. Must be called on a repository instance.
 491
 492 =cut
 493
 494 sub repo_path { $_[0]->{opts}->{Repository} }
 495
 496
 497 =item wc_path ()
 498
 499 Return path to the working copy. Must be called on a repository instance.
 500
 501 =cut
 502
 503 sub wc_path { $_[0]->{opts}->{WorkingCopy} }
 504
 505
 506 =item wc_subdir ()
 507
 508 Return path to the subdirectory inside of a working copy. Must be called
 509 on a repository instance.
 510
 511 =cut
 512
 513 sub wc_subdir { $_[0]->{opts}->{WorkingSubdir} ||= '' }
 514
 515
 516 =item wc_chdir ( SUBDIR )
 517
 518 Change the working copy subdirectory to work within. The C<SUBDIR> is
 519 relative to the working copy root directory (not the current subdirectory).
 520 Must be called on a repository instance attached to a working copy
 521 and the directory must exist.
 522
 523 =cut
 524
 525 sub wc_chdir {
 526         my ($self, $subdir) = @_;
 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
 539 =item config ( VARIABLE )
 540
 541 Retrieve the configuration C<VARIABLE> in the same manner as C<config>
 542 does. In scalar context requires the variable to be set only one time
 543 (exception is thrown otherwise), in array context returns allows the
 544 variable to be set multiple times and returns all the values.
 545
 546 This currently wraps command('config') so it is not so fast.
 547
 548 =cut
 549
 550 sub config {
 551         my ($self, $var) = _maybe_self(@_);
 552
 553         try {
 554                 my @cmd = ('config');
 555                 unshift @cmd, $self if $self;
 556                 if (wantarray) {
 557                         return command(@cmd, '--get-all', $var);
 558                 } else {
 559                         return command_oneline(@cmd, '--get', $var);
 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
 573 =item config_bool ( VARIABLE )
 574
 575 Retrieve the bool configuration C<VARIABLE>. The return value
 576 is usable as a boolean in perl (and C<undef> if it's not defined,
 577 of course).
 578
 579 This currently wraps command('config') so it is not so fast.
 580
 581 =cut
 582
 583 sub config_bool {
 584         my ($self, $var) = _maybe_self(@_);
 585
 586         try {
 587                 my @cmd = ('config', '--bool', '--get', $var);
 588                 unshift @cmd, $self if $self;
 589                 my $val = command_oneline(@cmd);
 590                 return undef unless defined $val;
 591                 return $val eq 'true';
 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
 603 =item config_int ( VARIABLE )
 604
 605 Retrieve the integer configuration C<VARIABLE>. The return value
 606 is simple decimal number.  An optional value suffix of 'k', 'm',
 607 or 'g' in the config file will cause the value to be multiplied
 608 by 1024, 1048576 (1024^2), or 1073741824 (1024^3) prior to output.
 609 It would return C<undef> if configuration variable is not defined,
 610
 611 This currently wraps command('config') so it is not so fast.
 612
 613 =cut
 614
 615 sub config_int {
 616         my ($self, $var) = _maybe_self(@_);
 617
 618         try {
 619                 my @cmd = ('config', '--int', '--get', $var);
 620                 unshift @cmd, $self if $self;
 621                 return command_oneline(@cmd);
 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 }
 632
 633 =item get_colorbool ( NAME )
 634
 635 Finds if color should be used for NAMEd operation from the configuration,
 636 and returns boolean (true for "use color", false for "do not use color").
 637
 638 =cut
 639
 640 sub 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
 650 Finds color for SLOT from the configuration, while defaulting to COLOR,
 651 and 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
 659 sub 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
 668 =item ident ( TYPE | IDENTSTR )
 669
 670 =item ident_person ( TYPE | IDENTSTR | IDENTARRAY )
 671
 672 This suite of functions retrieves and parses ident information, as stored
 673 in the commit and tag objects or produced by C<var GIT_type_IDENT> (thus
 674 C<TYPE> can be either I<author> or I<committer>; case is insignificant).
 675
 676 The C<ident> method retrieves the ident information from C<git-var>
 677 and either returns it as a scalar string or as an array with the fields parsed.
 678 Alternatively, it can take a prepared ident string (e.g. from the commit
 679 object) and just parse it.
 680
 681 C<ident_person> returns the person part of the ident - name and email;
 682 it can take the same arguments as C<ident> or the array returned by C<ident>.
 683
 684 The 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
 691 =cut
 692
 693 sub ident {
 694         my ($self, $type) = _maybe_self(@_);
 695         my $identstr;
 696         if (lc $type eq lc 'committer' or lc $type eq lc 'author') {
 697                 my @cmd = ('var', 'GIT_'.uc($type).'_IDENT');
 698                 unshift @cmd, $self if $self;
 699                 $identstr = command_oneline(@cmd);
 700         } else {
 701                 $identstr = $type;
 702         }
 703         if (wantarray) {
 704                 return $identstr =~ /^(.*) <(.*)> (\d+ [+-]\d{4})$/;
 705         } else {
 706                 return $identstr;
 707         }
 708 }
 709
 710 sub ident_person {
 711         my ($self, @ident) = _maybe_self(@_);
 712         $#ident == 0 and @ident = $self ? $self->ident($ident[0]) : ident($ident[0]);
 713         return "$ident[0] <$ident[1]>";
 714 }
 715
 716
 717 =item hash_object ( TYPE, FILENAME )
 718
 719 Compute the SHA1 object id of the given C<FILENAME> (or data waiting in
 720 C<FILEHANDLE>) considering it is of the C<TYPE> object type (C<blob>,
 721 C<commit>, C<tree>).
 722
 723 The method can be called without any instance or on a specified Git repository,
 724 it makes zero difference.
 725
 726 The function returns the SHA1 hash.
 727
 728 =cut
 729
 730 # TODO: Support for passing FILEHANDLE instead of FILENAME
 731 sub hash_object {
 732         my ($self, $type, $file) = _maybe_self(@_);
 733         command_oneline('hash-object', '-t', $type, $file);
 734 }
 735
 736
 737
 738 =back
 739
 740 =head1 ERROR HANDLING
 741
 742 All functions are supposed to throw Perl exceptions in case of errors.
 743 See the L<Error> module on how to catch those. Most exceptions are mere
 744 L<Error::Simple> instances.
 745
 746 However, the C<command()>, C<command_oneline()> and C<command_noisy()>
 747 functions suite can throw C<Git::Error::Command> exceptions as well: those are
 748 thrown when the external command returns an error code and contain the error
 749 code as well as access to the captured command's output. The exception class
 750 provides the usual C<stringify> and C<value> (command's exit code) methods and
 751 in addition also a C<cmd_output> method that returns either an array or a
 752 string with the captured command output (depending on the original function
 753 call context; C<command_noisy()> returns C<undef>) and $<cmdline> which
 754 returns the command and its arguments (but without proper quoting).
 755
 756 Note that the C<command_*_pipe()> functions cannot throw this exception since
 757 it has no idea whether the command failed or not. You will only find out
 758 at the time you C<close> the pipe; if you want to have that automated,
 759 use 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
 811 This magical statement will automatically catch any C<Git::Error::Command>
 812 exceptions thrown by C<CODE> and make your program die with C<ERRMSG>
 813 on its lips; the message will have %s substituted for the command line
 814 and %d for the exit status. This statement is useful mostly for producing
 815 more user-friendly error messages.
 816
 817 In case of no exception caught the statement returns C<CODE>'s return value.
 818
 819 Note that this is the only auto-exported function.
 820
 821 =cut
 822
 823 sub 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
 848
 849 =head1 COPYRIGHT
 850
 851 Copyright 2006 by Petr Baudis E<lt>pasky@suse.czE<gt>.
 852
 853 This module is free software; it may be used, copied, modified
 854 and distributed under the terms of the GNU General Public Licence,
 855 either 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.
 863 sub _maybe_self {
 864         # This breaks inheritance. Oh well.
 865         ref $_[0] eq 'Git' ? @_ : (undef, @_);
 866 }
 867
 868 # Check if the command id is something reasonable.
 869 sub _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.
 875 sub _command_common_pipe {
 876         my $direction = shift;
 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         }
 885         _check_valid_cmd($cmd);
 886
 887         my $fh;
 888         if ($^O eq 'MSWin32') {
 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';
 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;
 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);
 915                 }
 916         }
 917         return wantarray ? ($fh, join(' ', $cmd, @args)) : $fh;
 918 }
 919
 920 # When already in the subprocess, set up the appropriate state
 921 # for the given repository and execute the git command.
 922 sub _cmd_exec {
 923         my ($self, @args) = @_;
 924         if ($self) {
 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());
 928         }
 929         _execv_git_cmd(@args);
 930         die qq[exec "@args" failed: $!];
 931 }
 932
 933 # Execute the given Git command ($_[0]) with arguments ($_[1..])
 934 # by searching for it at proper places.
 935 sub _execv_git_cmd { exec('git', @_); }
 936
 937 # Close pipe to a subprocess.
 938 sub _cmd_close {
 939         my ($fh, $ctx) = @_;
 940         if (not close $fh) {
 941                 if ($!) {
 942                         # It's just close, no point in fatalities
 943                         carp "error closing pipe: $!";
 944                 } elsif ($? >> 8) {
 945                         # The caller should pepper this.
 946                         throw Git::Error::Command($ctx, $? >> 8);
 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
 954 sub DESTROY { }
 955
 956
 957 # Pipe implementation for ActiveState Perl.
 958
 959 package Git::activestate_pipe;
 960 use strict;
 961
 962 sub 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
 967         # Let's just hope ActiveState Perl does at least the quoting
 968         # correctly.
 969         my @data = qx{git @params};
 970         bless { i => 0, data => \@data }, $class;
 971 }
 972
 973 sub READLINE {
 974         my $self = shift;
 975         if ($self->{i} >= scalar @{$self->{data}}) {
 976                 return undef;
 977         }
 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 ];
 985 }
 986
 987 sub CLOSE {
 988         my $self = shift;
 989         delete $self->{data};
 990         delete $self->{i};
 991 }
 992
 993 sub EOF {
 994         my $self = shift;
 995         return ($self->{i} >= scalar @{$self->{data}});
 996 }
 997
 998
 999 1; # Famous last words