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