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