perl / Git.pmon commit Merge branch 'js/mingw-tests' (4b589e5)
   1=head1 NAME
   2
   3Git - Perl interface to the Git version control system
   4
   5=cut
   6
   7
   8package Git;
   9
  10use 5.008;
  11use strict;
  12
  13
  14BEGIN {
  15
  16our ($VERSION, @ISA, @EXPORT, @EXPORT_OK);
  17
  18# Totally unstable API.
  19$VERSION = '0.01';
  20
  21
  22=head1 SYNOPSIS
  23
  24  use Git;
  25
  26  my $version = Git::command_oneline('version');
  27
  28  git_cmd_try { Git::command_noisy('update-server-info') }
  29              '%s failed w/ code %d';
  30
  31  my $repo = Git->repository (Directory => '/srv/git/cogito.git');
  32
  33
  34  my @revs = $repo->command('rev-list', '--since=last monday', '--all');
  35
  36  my ($fh, $c) = $repo->command_output_pipe('rev-list', '--since=last monday', '--all');
  37  my $lastrev = <$fh>; chomp $lastrev;
  38  $repo->command_close_pipe($fh, $c);
  39
  40  my $lastrev = $repo->command_oneline( [ 'rev-list', '--all' ],
  41                                        STDERR => 0 );
  42
  43  my $sha1 = $repo->hash_and_insert_object('file.txt');
  44  my $tempfile = tempfile();
  45  my $size = $repo->cat_blob($sha1, $tempfile);
  46
  47=cut
  48
  49
  50require Exporter;
  51
  52@ISA = qw(Exporter);
  53
  54@EXPORT = qw(git_cmd_try);
  55
  56# Methods which can be called as standalone functions as well:
  57@EXPORT_OK = qw(command command_oneline command_noisy
  58                command_output_pipe command_input_pipe command_close_pipe
  59                command_bidi_pipe command_close_bidi_pipe
  60                version exec_path html_path hash_object git_cmd_try
  61                remote_refs prompt
  62                get_tz_offset
  63                credential credential_read credential_write
  64                temp_acquire temp_is_locked temp_release temp_reset temp_path);
  65
  66
  67=head1 DESCRIPTION
  68
  69This module provides Perl scripts easy way to interface the Git version control
  70system. The modules have an easy and well-tested way to call arbitrary Git
  71commands; in the future, the interface will also provide specialized methods
  72for doing easily operations which are not totally trivial to do over
  73the generic command interface.
  74
  75While some commands can be executed outside of any context (e.g. 'version'
  76or 'init'), most operations require a repository context, which in practice
  77means getting an instance of the Git object using the repository() constructor.
  78(In the future, we will also get a new_repository() constructor.) All commands
  79called as methods of the object are then executed in the context of the
  80repository.
  81
  82Part of the "repository state" is also information about path to the attached
  83working copy (unless you work with a bare repository). You can also navigate
  84inside of the working copy using the C<wc_chdir()> method. (Note that
  85the repository object is self-contained and will not change working directory
  86of your process.)
  87
  88TODO: In the future, we might also do
  89
  90        my $remoterepo = $repo->remote_repository (Name => 'cogito', Branch => 'master');
  91        $remoterepo ||= Git->remote_repository ('http://git.or.cz/cogito.git/');
  92        my @refs = $remoterepo->refs();
  93
  94Currently, the module merely wraps calls to external Git tools. In the future,
  95it will provide a much faster way to interact with Git by linking directly
  96to libgit. This should be completely opaque to the user, though (performance
  97increase notwithstanding).
  98
  99=cut
 100
 101
 102use Carp qw(carp croak); # but croak is bad - throw instead
 103use Error qw(:try);
 104use Cwd qw(abs_path cwd);
 105use IPC::Open2 qw(open2);
 106use Fcntl qw(SEEK_SET SEEK_CUR);
 107use Time::Local qw(timegm);
 108}
 109
 110
 111=head1 CONSTRUCTORS
 112
 113=over 4
 114
 115=item repository ( OPTIONS )
 116
 117=item repository ( DIRECTORY )
 118
 119=item repository ()
 120
 121Construct a new repository object.
 122C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
 123Possible options are:
 124
 125B<Repository> - Path to the Git repository.
 126
 127B<WorkingCopy> - Path to the associated working copy; not strictly required
 128as many commands will happily crunch on a bare repository.
 129
 130B<WorkingSubdir> - Subdirectory in the working copy to work inside.
 131Just left undefined if you do not want to limit the scope of operations.
 132
 133B<Directory> - Path to the Git working directory in its usual setup.
 134The C<.git> directory is searched in the directory and all the parent
 135directories; if found, C<WorkingCopy> is set to the directory containing
 136it and C<Repository> to the C<.git> directory itself. If no C<.git>
 137directory was found, the C<Directory> is assumed to be a bare repository,
 138C<Repository> is set to point at it and C<WorkingCopy> is left undefined.
 139If the C<$GIT_DIR> environment variable is set, things behave as expected
 140as well.
 141
 142You should not use both C<Directory> and either of C<Repository> and
 143C<WorkingCopy> - the results of that are undefined.
 144
 145Alternatively, a directory path may be passed as a single scalar argument
 146to the constructor; it is equivalent to setting only the C<Directory> option
 147field.
 148
 149Calling the constructor with no options whatsoever is equivalent to
 150calling it with C<< Directory => '.' >>. In general, if you are building
 151a standard porcelain command, simply doing C<< Git->repository() >> should
 152do the right thing and setup the object to reflect exactly where the user
 153is right now.
 154
 155=cut
 156
 157sub repository {
 158        my $class = shift;
 159        my @args = @_;
 160        my %opts = ();
 161        my $self;
 162
 163        if (defined $args[0]) {
 164                if ($#args % 2 != 1) {
 165                        # Not a hash.
 166                        $#args == 0 or throw Error::Simple("bad usage");
 167                        %opts = ( Directory => $args[0] );
 168                } else {
 169                        %opts = @args;
 170                }
 171        }
 172
 173        if (not defined $opts{Repository} and not defined $opts{WorkingCopy}
 174                and not defined $opts{Directory}) {
 175                $opts{Directory} = '.';
 176        }
 177
 178        if (defined $opts{Directory}) {
 179                -d $opts{Directory} or throw Error::Simple("Directory not found: $opts{Directory} $!");
 180
 181                my $search = Git->repository(WorkingCopy => $opts{Directory});
 182                my $dir;
 183                try {
 184                        $dir = $search->command_oneline(['rev-parse', '--git-dir'],
 185                                                        STDERR => 0);
 186                } catch Git::Error::Command with {
 187                        $dir = undef;
 188                };
 189
 190                if ($dir) {
 191                        _verify_require();
 192                        File::Spec->file_name_is_absolute($dir) or $dir = $opts{Directory} . '/' . $dir;
 193                        $opts{Repository} = abs_path($dir);
 194
 195                        # If --git-dir went ok, this shouldn't die either.
 196                        my $prefix = $search->command_oneline('rev-parse', '--show-prefix');
 197                        $dir = abs_path($opts{Directory}) . '/';
 198                        if ($prefix) {
 199                                if (substr($dir, -length($prefix)) ne $prefix) {
 200                                        throw Error::Simple("rev-parse confused me - $dir does not have trailing $prefix");
 201                                }
 202                                substr($dir, -length($prefix)) = '';
 203                        }
 204                        $opts{WorkingCopy} = $dir;
 205                        $opts{WorkingSubdir} = $prefix;
 206
 207                } else {
 208                        # A bare repository? Let's see...
 209                        $dir = $opts{Directory};
 210
 211                        unless (-d "$dir/refs" and -d "$dir/objects" and -e "$dir/HEAD") {
 212                                # Mimic git-rev-parse --git-dir error message:
 213                                throw Error::Simple("fatal: Not a git repository: $dir");
 214                        }
 215                        my $search = Git->repository(Repository => $dir);
 216                        try {
 217                                $search->command('symbolic-ref', 'HEAD');
 218                        } catch Git::Error::Command with {
 219                                # Mimic git-rev-parse --git-dir error message:
 220                                throw Error::Simple("fatal: Not a git repository: $dir");
 221                        }
 222
 223                        $opts{Repository} = abs_path($dir);
 224                }
 225
 226                delete $opts{Directory};
 227        }
 228
 229        $self = { opts => \%opts };
 230        bless $self, $class;
 231}
 232
 233=back
 234
 235=head1 METHODS
 236
 237=over 4
 238
 239=item command ( COMMAND [, ARGUMENTS... ] )
 240
 241=item command ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } )
 242
 243Execute the given Git C<COMMAND> (specify it without the 'git-'
 244prefix), optionally with the specified extra C<ARGUMENTS>.
 245
 246The second more elaborate form can be used if you want to further adjust
 247the command execution. Currently, only one option is supported:
 248
 249B<STDERR> - How to deal with the command's error output. By default (C<undef>)
 250it is delivered to the caller's C<STDERR>. A false value (0 or '') will cause
 251it to be thrown away. If you want to process it, you can get it in a filehandle
 252you specify, but you must be extremely careful; if the error output is not
 253very short and you want to read it in the same process as where you called
 254C<command()>, you are set up for a nice deadlock!
 255
 256The method can be called without any instance or on a specified Git repository
 257(in that case the command will be run in the repository context).
 258
 259In scalar context, it returns all the command output in a single string
 260(verbatim).
 261
 262In array context, it returns an array containing lines printed to the
 263command's stdout (without trailing newlines).
 264
 265In both cases, the command's stdin and stderr are the same as the caller's.
 266
 267=cut
 268
 269sub command {
 270        my ($fh, $ctx) = command_output_pipe(@_);
 271
 272        if (not defined wantarray) {
 273                # Nothing to pepper the possible exception with.
 274                _cmd_close($ctx, $fh);
 275
 276        } elsif (not wantarray) {
 277                local $/;
 278                my $text = <$fh>;
 279                try {
 280                        _cmd_close($ctx, $fh);
 281                } catch Git::Error::Command with {
 282                        # Pepper with the output:
 283                        my $E = shift;
 284                        $E->{'-outputref'} = \$text;
 285                        throw $E;
 286                };
 287                return $text;
 288
 289        } else {
 290                my @lines = <$fh>;
 291                defined and chomp for @lines;
 292                try {
 293                        _cmd_close($ctx, $fh);
 294                } catch Git::Error::Command with {
 295                        my $E = shift;
 296                        $E->{'-outputref'} = \@lines;
 297                        throw $E;
 298                };
 299                return @lines;
 300        }
 301}
 302
 303
 304=item command_oneline ( COMMAND [, ARGUMENTS... ] )
 305
 306=item command_oneline ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } )
 307
 308Execute the given C<COMMAND> in the same way as command()
 309does but always return a scalar string containing the first line
 310of the command's standard output.
 311
 312=cut
 313
 314sub command_oneline {
 315        my ($fh, $ctx) = command_output_pipe(@_);
 316
 317        my $line = <$fh>;
 318        defined $line and chomp $line;
 319        try {
 320                _cmd_close($ctx, $fh);
 321        } catch Git::Error::Command with {
 322                # Pepper with the output:
 323                my $E = shift;
 324                $E->{'-outputref'} = \$line;
 325                throw $E;
 326        };
 327        return $line;
 328}
 329
 330
 331=item command_output_pipe ( COMMAND [, ARGUMENTS... ] )
 332
 333=item command_output_pipe ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } )
 334
 335Execute the given C<COMMAND> in the same way as command()
 336does but return a pipe filehandle from which the command output can be
 337read.
 338
 339The function can return C<($pipe, $ctx)> in array context.
 340See C<command_close_pipe()> for details.
 341
 342=cut
 343
 344sub command_output_pipe {
 345        _command_common_pipe('-|', @_);
 346}
 347
 348
 349=item command_input_pipe ( COMMAND [, ARGUMENTS... ] )
 350
 351=item command_input_pipe ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } )
 352
 353Execute the given C<COMMAND> in the same way as command_output_pipe()
 354does but return an input pipe filehandle instead; the command output
 355is not captured.
 356
 357The function can return C<($pipe, $ctx)> in array context.
 358See C<command_close_pipe()> for details.
 359
 360=cut
 361
 362sub command_input_pipe {
 363        _command_common_pipe('|-', @_);
 364}
 365
 366
 367=item command_close_pipe ( PIPE [, CTX ] )
 368
 369Close the C<PIPE> as returned from C<command_*_pipe()>, checking
 370whether the command finished successfully. The optional C<CTX> argument
 371is required if you want to see the command name in the error message,
 372and it is the second value returned by C<command_*_pipe()> when
 373called in array context. The call idiom is:
 374
 375        my ($fh, $ctx) = $r->command_output_pipe('status');
 376        while (<$fh>) { ... }
 377        $r->command_close_pipe($fh, $ctx);
 378
 379Note that you should not rely on whatever actually is in C<CTX>;
 380currently it is simply the command name but in future the context might
 381have more complicated structure.
 382
 383=cut
 384
 385sub command_close_pipe {
 386        my ($self, $fh, $ctx) = _maybe_self(@_);
 387        $ctx ||= '<unknown>';
 388        _cmd_close($ctx, $fh);
 389}
 390
 391=item command_bidi_pipe ( COMMAND [, ARGUMENTS... ] )
 392
 393Execute the given C<COMMAND> in the same way as command_output_pipe()
 394does but return both an input pipe filehandle and an output pipe filehandle.
 395
 396The function will return return C<($pid, $pipe_in, $pipe_out, $ctx)>.
 397See C<command_close_bidi_pipe()> for details.
 398
 399=cut
 400
 401sub command_bidi_pipe {
 402        my ($pid, $in, $out);
 403        my ($self) = _maybe_self(@_);
 404        local %ENV = %ENV;
 405        my $cwd_save = undef;
 406        if ($self) {
 407                shift;
 408                $cwd_save = cwd();
 409                _setup_git_cmd_env($self);
 410        }
 411        $pid = open2($in, $out, 'git', @_);
 412        chdir($cwd_save) if $cwd_save;
 413        return ($pid, $in, $out, join(' ', @_));
 414}
 415
 416=item command_close_bidi_pipe ( PID, PIPE_IN, PIPE_OUT [, CTX] )
 417
 418Close the C<PIPE_IN> and C<PIPE_OUT> as returned from C<command_bidi_pipe()>,
 419checking whether the command finished successfully. The optional C<CTX>
 420argument is required if you want to see the command name in the error message,
 421and it is the fourth value returned by C<command_bidi_pipe()>.  The call idiom
 422is:
 423
 424        my ($pid, $in, $out, $ctx) = $r->command_bidi_pipe('cat-file --batch-check');
 425        print $out "000000000\n";
 426        while (<$in>) { ... }
 427        $r->command_close_bidi_pipe($pid, $in, $out, $ctx);
 428
 429Note that you should not rely on whatever actually is in C<CTX>;
 430currently it is simply the command name but in future the context might
 431have more complicated structure.
 432
 433C<PIPE_IN> and C<PIPE_OUT> may be C<undef> if they have been closed prior to
 434calling this function.  This may be useful in a query-response type of
 435commands where caller first writes a query and later reads response, eg:
 436
 437        my ($pid, $in, $out, $ctx) = $r->command_bidi_pipe('cat-file --batch-check');
 438        print $out "000000000\n";
 439        close $out;
 440        while (<$in>) { ... }
 441        $r->command_close_bidi_pipe($pid, $in, undef, $ctx);
 442
 443This idiom may prevent potential dead locks caused by data sent to the output
 444pipe not being flushed and thus not reaching the executed command.
 445
 446=cut
 447
 448sub command_close_bidi_pipe {
 449        local $?;
 450        my ($self, $pid, $in, $out, $ctx) = _maybe_self(@_);
 451        _cmd_close($ctx, (grep { defined } ($in, $out)));
 452        waitpid $pid, 0;
 453        if ($? >> 8) {
 454                throw Git::Error::Command($ctx, $? >>8);
 455        }
 456}
 457
 458
 459=item command_noisy ( COMMAND [, ARGUMENTS... ] )
 460
 461Execute the given C<COMMAND> in the same way as command() does but do not
 462capture the command output - the standard output is not redirected and goes
 463to the standard output of the caller application.
 464
 465While the method is called command_noisy(), you might want to as well use
 466it for the most silent Git commands which you know will never pollute your
 467stdout but you want to avoid the overhead of the pipe setup when calling them.
 468
 469The function returns only after the command has finished running.
 470
 471=cut
 472
 473sub command_noisy {
 474        my ($self, $cmd, @args) = _maybe_self(@_);
 475        _check_valid_cmd($cmd);
 476
 477        my $pid = fork;
 478        if (not defined $pid) {
 479                throw Error::Simple("fork failed: $!");
 480        } elsif ($pid == 0) {
 481                _cmd_exec($self, $cmd, @args);
 482        }
 483        if (waitpid($pid, 0) > 0 and $?>>8 != 0) {
 484                throw Git::Error::Command(join(' ', $cmd, @args), $? >> 8);
 485        }
 486}
 487
 488
 489=item version ()
 490
 491Return the Git version in use.
 492
 493=cut
 494
 495sub version {
 496        my $verstr = command_oneline('--version');
 497        $verstr =~ s/^git version //;
 498        $verstr;
 499}
 500
 501
 502=item exec_path ()
 503
 504Return path to the Git sub-command executables (the same as
 505C<git --exec-path>). Useful mostly only internally.
 506
 507=cut
 508
 509sub exec_path { command_oneline('--exec-path') }
 510
 511
 512=item html_path ()
 513
 514Return path to the Git html documentation (the same as
 515C<git --html-path>). Useful mostly only internally.
 516
 517=cut
 518
 519sub html_path { command_oneline('--html-path') }
 520
 521
 522=item get_tz_offset ( TIME )
 523
 524Return the time zone offset from GMT in the form +/-HHMM where HH is
 525the number of hours from GMT and MM is the number of minutes.  This is
 526the equivalent of what strftime("%z", ...) would provide on a GNU
 527platform.
 528
 529If TIME is not supplied, the current local time is used.
 530
 531=cut
 532
 533sub get_tz_offset {
 534        # some systmes don't handle or mishandle %z, so be creative.
 535        my $t = shift || time;
 536        my $gm = timegm(localtime($t));
 537        my $sign = qw( + + - )[ $gm <=> $t ];
 538        return sprintf("%s%02d%02d", $sign, (gmtime(abs($t - $gm)))[2,1]);
 539}
 540
 541
 542=item prompt ( PROMPT , ISPASSWORD  )
 543
 544Query user C<PROMPT> and return answer from user.
 545
 546Honours GIT_ASKPASS and SSH_ASKPASS environment variables for querying
 547the user. If no *_ASKPASS variable is set or an error occoured,
 548the terminal is tried as a fallback.
 549If C<ISPASSWORD> is set and true, the terminal disables echo.
 550
 551=cut
 552
 553sub prompt {
 554        my ($prompt, $isPassword) = @_;
 555        my $ret;
 556        if (exists $ENV{'GIT_ASKPASS'}) {
 557                $ret = _prompt($ENV{'GIT_ASKPASS'}, $prompt);
 558        }
 559        if (!defined $ret && exists $ENV{'SSH_ASKPASS'}) {
 560                $ret = _prompt($ENV{'SSH_ASKPASS'}, $prompt);
 561        }
 562        if (!defined $ret) {
 563                print STDERR $prompt;
 564                STDERR->flush;
 565                if (defined $isPassword && $isPassword) {
 566                        require Term::ReadKey;
 567                        Term::ReadKey::ReadMode('noecho');
 568                        $ret = '';
 569                        while (defined(my $key = Term::ReadKey::ReadKey(0))) {
 570                                last if $key =~ /[\012\015]/; # \n\r
 571                                $ret .= $key;
 572                        }
 573                        Term::ReadKey::ReadMode('restore');
 574                        print STDERR "\n";
 575                        STDERR->flush;
 576                } else {
 577                        chomp($ret = <STDIN>);
 578                }
 579        }
 580        return $ret;
 581}
 582
 583sub _prompt {
 584        my ($askpass, $prompt) = @_;
 585        return unless length $askpass;
 586        $prompt =~ s/\n/ /g;
 587        my $ret;
 588        open my $fh, "-|", $askpass, $prompt or return;
 589        $ret = <$fh>;
 590        $ret =~ s/[\015\012]//g; # strip \r\n, chomp does not work on all systems (i.e. windows) as expected
 591        close ($fh);
 592        return $ret;
 593}
 594
 595=item repo_path ()
 596
 597Return path to the git repository. Must be called on a repository instance.
 598
 599=cut
 600
 601sub repo_path { $_[0]->{opts}->{Repository} }
 602
 603
 604=item wc_path ()
 605
 606Return path to the working copy. Must be called on a repository instance.
 607
 608=cut
 609
 610sub wc_path { $_[0]->{opts}->{WorkingCopy} }
 611
 612
 613=item wc_subdir ()
 614
 615Return path to the subdirectory inside of a working copy. Must be called
 616on a repository instance.
 617
 618=cut
 619
 620sub wc_subdir { $_[0]->{opts}->{WorkingSubdir} ||= '' }
 621
 622
 623=item wc_chdir ( SUBDIR )
 624
 625Change the working copy subdirectory to work within. The C<SUBDIR> is
 626relative to the working copy root directory (not the current subdirectory).
 627Must be called on a repository instance attached to a working copy
 628and the directory must exist.
 629
 630=cut
 631
 632sub wc_chdir {
 633        my ($self, $subdir) = @_;
 634        $self->wc_path()
 635                or throw Error::Simple("bare repository");
 636
 637        -d $self->wc_path().'/'.$subdir
 638                or throw Error::Simple("subdir not found: $subdir $!");
 639        # Of course we will not "hold" the subdirectory so anyone
 640        # can delete it now and we will never know. But at least we tried.
 641
 642        $self->{opts}->{WorkingSubdir} = $subdir;
 643}
 644
 645
 646=item config ( VARIABLE )
 647
 648Retrieve the configuration C<VARIABLE> in the same manner as C<config>
 649does. In scalar context requires the variable to be set only one time
 650(exception is thrown otherwise), in array context returns allows the
 651variable to be set multiple times and returns all the values.
 652
 653=cut
 654
 655sub config {
 656        return _config_common({}, @_);
 657}
 658
 659
 660=item config_bool ( VARIABLE )
 661
 662Retrieve the bool configuration C<VARIABLE>. The return value
 663is usable as a boolean in perl (and C<undef> if it's not defined,
 664of course).
 665
 666=cut
 667
 668sub config_bool {
 669        my $val = scalar _config_common({'kind' => '--bool'}, @_);
 670
 671        # Do not rewrite this as return (defined $val && $val eq 'true')
 672        # as some callers do care what kind of falsehood they receive.
 673        if (!defined $val) {
 674                return undef;
 675        } else {
 676                return $val eq 'true';
 677        }
 678}
 679
 680
 681=item config_path ( VARIABLE )
 682
 683Retrieve the path configuration C<VARIABLE>. The return value
 684is an expanded path or C<undef> if it's not defined.
 685
 686=cut
 687
 688sub config_path {
 689        return _config_common({'kind' => '--path'}, @_);
 690}
 691
 692
 693=item config_int ( VARIABLE )
 694
 695Retrieve the integer configuration C<VARIABLE>. The return value
 696is simple decimal number.  An optional value suffix of 'k', 'm',
 697or 'g' in the config file will cause the value to be multiplied
 698by 1024, 1048576 (1024^2), or 1073741824 (1024^3) prior to output.
 699It would return C<undef> if configuration variable is not defined.
 700
 701=cut
 702
 703sub config_int {
 704        return scalar _config_common({'kind' => '--int'}, @_);
 705}
 706
 707# Common subroutine to implement bulk of what the config* family of methods
 708# do. This currently wraps command('config') so it is not so fast.
 709sub _config_common {
 710        my ($opts) = shift @_;
 711        my ($self, $var) = _maybe_self(@_);
 712
 713        try {
 714                my @cmd = ('config', $opts->{'kind'} ? $opts->{'kind'} : ());
 715                unshift @cmd, $self if $self;
 716                if (wantarray) {
 717                        return command(@cmd, '--get-all', $var);
 718                } else {
 719                        return command_oneline(@cmd, '--get', $var);
 720                }
 721        } catch Git::Error::Command with {
 722                my $E = shift;
 723                if ($E->value() == 1) {
 724                        # Key not found.
 725                        return;
 726                } else {
 727                        throw $E;
 728                }
 729        };
 730}
 731
 732=item get_colorbool ( NAME )
 733
 734Finds if color should be used for NAMEd operation from the configuration,
 735and returns boolean (true for "use color", false for "do not use color").
 736
 737=cut
 738
 739sub get_colorbool {
 740        my ($self, $var) = @_;
 741        my $stdout_to_tty = (-t STDOUT) ? "true" : "false";
 742        my $use_color = $self->command_oneline('config', '--get-colorbool',
 743                                               $var, $stdout_to_tty);
 744        return ($use_color eq 'true');
 745}
 746
 747=item get_color ( SLOT, COLOR )
 748
 749Finds color for SLOT from the configuration, while defaulting to COLOR,
 750and returns the ANSI color escape sequence:
 751
 752        print $repo->get_color("color.interactive.prompt", "underline blue white");
 753        print "some text";
 754        print $repo->get_color("", "normal");
 755
 756=cut
 757
 758sub get_color {
 759        my ($self, $slot, $default) = @_;
 760        my $color = $self->command_oneline('config', '--get-color', $slot, $default);
 761        if (!defined $color) {
 762                $color = "";
 763        }
 764        return $color;
 765}
 766
 767=item remote_refs ( REPOSITORY [, GROUPS [, REFGLOBS ] ] )
 768
 769This function returns a hashref of refs stored in a given remote repository.
 770The hash is in the format C<refname =\> hash>. For tags, the C<refname> entry
 771contains the tag object while a C<refname^{}> entry gives the tagged objects.
 772
 773C<REPOSITORY> has the same meaning as the appropriate C<git-ls-remote>
 774argument; either a URL or a remote name (if called on a repository instance).
 775C<GROUPS> is an optional arrayref that can contain 'tags' to return all the
 776tags and/or 'heads' to return all the heads. C<REFGLOB> is an optional array
 777of strings containing a shell-like glob to further limit the refs returned in
 778the hash; the meaning is again the same as the appropriate C<git-ls-remote>
 779argument.
 780
 781This function may or may not be called on a repository instance. In the former
 782case, remote names as defined in the repository are recognized as repository
 783specifiers.
 784
 785=cut
 786
 787sub remote_refs {
 788        my ($self, $repo, $groups, $refglobs) = _maybe_self(@_);
 789        my @args;
 790        if (ref $groups eq 'ARRAY') {
 791                foreach (@$groups) {
 792                        if ($_ eq 'heads') {
 793                                push (@args, '--heads');
 794                        } elsif ($_ eq 'tags') {
 795                                push (@args, '--tags');
 796                        } else {
 797                                # Ignore unknown groups for future
 798                                # compatibility
 799                        }
 800                }
 801        }
 802        push (@args, $repo);
 803        if (ref $refglobs eq 'ARRAY') {
 804                push (@args, @$refglobs);
 805        }
 806
 807        my @self = $self ? ($self) : (); # Ultra trickery
 808        my ($fh, $ctx) = Git::command_output_pipe(@self, 'ls-remote', @args);
 809        my %refs;
 810        while (<$fh>) {
 811                chomp;
 812                my ($hash, $ref) = split(/\t/, $_, 2);
 813                $refs{$ref} = $hash;
 814        }
 815        Git::command_close_pipe(@self, $fh, $ctx);
 816        return \%refs;
 817}
 818
 819
 820=item ident ( TYPE | IDENTSTR )
 821
 822=item ident_person ( TYPE | IDENTSTR | IDENTARRAY )
 823
 824This suite of functions retrieves and parses ident information, as stored
 825in the commit and tag objects or produced by C<var GIT_type_IDENT> (thus
 826C<TYPE> can be either I<author> or I<committer>; case is insignificant).
 827
 828The C<ident> method retrieves the ident information from C<git var>
 829and either returns it as a scalar string or as an array with the fields parsed.
 830Alternatively, it can take a prepared ident string (e.g. from the commit
 831object) and just parse it.
 832
 833C<ident_person> returns the person part of the ident - name and email;
 834it can take the same arguments as C<ident> or the array returned by C<ident>.
 835
 836The synopsis is like:
 837
 838        my ($name, $email, $time_tz) = ident('author');
 839        "$name <$email>" eq ident_person('author');
 840        "$name <$email>" eq ident_person($name);
 841        $time_tz =~ /^\d+ [+-]\d{4}$/;
 842
 843=cut
 844
 845sub ident {
 846        my ($self, $type) = _maybe_self(@_);
 847        my $identstr;
 848        if (lc $type eq lc 'committer' or lc $type eq lc 'author') {
 849                my @cmd = ('var', 'GIT_'.uc($type).'_IDENT');
 850                unshift @cmd, $self if $self;
 851                $identstr = command_oneline(@cmd);
 852        } else {
 853                $identstr = $type;
 854        }
 855        if (wantarray) {
 856                return $identstr =~ /^(.*) <(.*)> (\d+ [+-]\d{4})$/;
 857        } else {
 858                return $identstr;
 859        }
 860}
 861
 862sub ident_person {
 863        my ($self, @ident) = _maybe_self(@_);
 864        $#ident == 0 and @ident = $self ? $self->ident($ident[0]) : ident($ident[0]);
 865        return "$ident[0] <$ident[1]>";
 866}
 867
 868=item parse_mailboxes
 869
 870Return an array of mailboxes extracted from a string.
 871
 872=cut
 873
 874sub parse_mailboxes {
 875        my $re_comment = qr/\((?:[^)]*)\)/;
 876        my $re_quote = qr/"(?:[^\"\\]|\\.)*"/;
 877        my $re_word = qr/(?:[^]["\s()<>:;@\\,.]|\\.)+/;
 878
 879        # divide the string in tokens of the above form
 880        my $re_token = qr/(?:$re_quote|$re_word|$re_comment|\S)/;
 881        my @tokens = map { $_ =~ /\s*($re_token)\s*/g } @_;
 882
 883        # add a delimiter to simplify treatment for the last mailbox
 884        push @tokens, ",";
 885
 886        my (@addr_list, @phrase, @address, @comment, @buffer) = ();
 887        foreach my $token (@tokens) {
 888                if ($token =~ /^[,;]$/) {
 889                        # if buffer still contains undeterminated strings
 890                        # append it at the end of @address or @phrase
 891                        if (@address) {
 892                                push @address, @buffer;
 893                        } else {
 894                                push @phrase, @buffer;
 895                        }
 896
 897                        my $str_phrase = join ' ', @phrase;
 898                        my $str_address = join '', @address;
 899                        my $str_comment = join ' ', @comment;
 900
 901                        # quote are necessary if phrase contains
 902                        # special characters
 903                        if ($str_phrase =~ /[][()<>:;@\\,.\000-\037\177]/) {
 904                                $str_phrase =~ s/(^|[^\\])"/$1/g;
 905                                $str_phrase = qq["$str_phrase"];
 906                        }
 907
 908                        # add "<>" around the address if necessary
 909                        if ($str_address ne "" && $str_phrase ne "") {
 910                                $str_address = qq[<$str_address>];
 911                        }
 912
 913                        my $str_mailbox = "$str_phrase $str_address $str_comment";
 914                        $str_mailbox =~ s/^\s*|\s*$//g;
 915                        push @addr_list, $str_mailbox if ($str_mailbox);
 916
 917                        @phrase = @address = @comment = @buffer = ();
 918                } elsif ($token =~ /^\(/) {
 919                        push @comment, $token;
 920                } elsif ($token eq "<") {
 921                        push @phrase, (splice @address), (splice @buffer);
 922                } elsif ($token eq ">") {
 923                        push @address, (splice @buffer);
 924                } elsif ($token eq "@") {
 925                        push @address, (splice @buffer), "@";
 926                } elsif ($token eq ".") {
 927                        push @address, (splice @buffer), ".";
 928                } else {
 929                        push @buffer, $token;
 930                }
 931        }
 932
 933        return @addr_list;
 934}
 935
 936=item hash_object ( TYPE, FILENAME )
 937
 938Compute the SHA1 object id of the given C<FILENAME> considering it is
 939of the C<TYPE> object type (C<blob>, C<commit>, C<tree>).
 940
 941The method can be called without any instance or on a specified Git repository,
 942it makes zero difference.
 943
 944The function returns the SHA1 hash.
 945
 946=cut
 947
 948# TODO: Support for passing FILEHANDLE instead of FILENAME
 949sub hash_object {
 950        my ($self, $type, $file) = _maybe_self(@_);
 951        command_oneline('hash-object', '-t', $type, $file);
 952}
 953
 954
 955=item hash_and_insert_object ( FILENAME )
 956
 957Compute the SHA1 object id of the given C<FILENAME> and add the object to the
 958object database.
 959
 960The function returns the SHA1 hash.
 961
 962=cut
 963
 964# TODO: Support for passing FILEHANDLE instead of FILENAME
 965sub hash_and_insert_object {
 966        my ($self, $filename) = @_;
 967
 968        carp "Bad filename \"$filename\"" if $filename =~ /[\r\n]/;
 969
 970        $self->_open_hash_and_insert_object_if_needed();
 971        my ($in, $out) = ($self->{hash_object_in}, $self->{hash_object_out});
 972
 973        unless (print $out $filename, "\n") {
 974                $self->_close_hash_and_insert_object();
 975                throw Error::Simple("out pipe went bad");
 976        }
 977
 978        chomp(my $hash = <$in>);
 979        unless (defined($hash)) {
 980                $self->_close_hash_and_insert_object();
 981                throw Error::Simple("in pipe went bad");
 982        }
 983
 984        return $hash;
 985}
 986
 987sub _open_hash_and_insert_object_if_needed {
 988        my ($self) = @_;
 989
 990        return if defined($self->{hash_object_pid});
 991
 992        ($self->{hash_object_pid}, $self->{hash_object_in},
 993         $self->{hash_object_out}, $self->{hash_object_ctx}) =
 994                $self->command_bidi_pipe(qw(hash-object -w --stdin-paths --no-filters));
 995}
 996
 997sub _close_hash_and_insert_object {
 998        my ($self) = @_;
 999
1000        return unless defined($self->{hash_object_pid});
1001
1002        my @vars = map { 'hash_object_' . $_ } qw(pid in out ctx);
1003
1004        command_close_bidi_pipe(@$self{@vars});
1005        delete @$self{@vars};
1006}
1007
1008=item cat_blob ( SHA1, FILEHANDLE )
1009
1010Prints the contents of the blob identified by C<SHA1> to C<FILEHANDLE> and
1011returns the number of bytes printed.
1012
1013=cut
1014
1015sub cat_blob {
1016        my ($self, $sha1, $fh) = @_;
1017
1018        $self->_open_cat_blob_if_needed();
1019        my ($in, $out) = ($self->{cat_blob_in}, $self->{cat_blob_out});
1020
1021        unless (print $out $sha1, "\n") {
1022                $self->_close_cat_blob();
1023                throw Error::Simple("out pipe went bad");
1024        }
1025
1026        my $description = <$in>;
1027        if ($description =~ / missing$/) {
1028                carp "$sha1 doesn't exist in the repository";
1029                return -1;
1030        }
1031
1032        if ($description !~ /^[0-9a-fA-F]{40} \S+ (\d+)$/) {
1033                carp "Unexpected result returned from git cat-file";
1034                return -1;
1035        }
1036
1037        my $size = $1;
1038
1039        my $blob;
1040        my $bytesLeft = $size;
1041
1042        while (1) {
1043                last unless $bytesLeft;
1044
1045                my $bytesToRead = $bytesLeft < 1024 ? $bytesLeft : 1024;
1046                my $read = read($in, $blob, $bytesToRead);
1047                unless (defined($read)) {
1048                        $self->_close_cat_blob();
1049                        throw Error::Simple("in pipe went bad");
1050                }
1051                unless (print $fh $blob) {
1052                        $self->_close_cat_blob();
1053                        throw Error::Simple("couldn't write to passed in filehandle");
1054                }
1055                $bytesLeft -= $read;
1056        }
1057
1058        # Skip past the trailing newline.
1059        my $newline;
1060        my $read = read($in, $newline, 1);
1061        unless (defined($read)) {
1062                $self->_close_cat_blob();
1063                throw Error::Simple("in pipe went bad");
1064        }
1065        unless ($read == 1 && $newline eq "\n") {
1066                $self->_close_cat_blob();
1067                throw Error::Simple("didn't find newline after blob");
1068        }
1069
1070        return $size;
1071}
1072
1073sub _open_cat_blob_if_needed {
1074        my ($self) = @_;
1075
1076        return if defined($self->{cat_blob_pid});
1077
1078        ($self->{cat_blob_pid}, $self->{cat_blob_in},
1079         $self->{cat_blob_out}, $self->{cat_blob_ctx}) =
1080                $self->command_bidi_pipe(qw(cat-file --batch));
1081}
1082
1083sub _close_cat_blob {
1084        my ($self) = @_;
1085
1086        return unless defined($self->{cat_blob_pid});
1087
1088        my @vars = map { 'cat_blob_' . $_ } qw(pid in out ctx);
1089
1090        command_close_bidi_pipe(@$self{@vars});
1091        delete @$self{@vars};
1092}
1093
1094
1095=item credential_read( FILEHANDLE )
1096
1097Reads credential key-value pairs from C<FILEHANDLE>.  Reading stops at EOF or
1098when an empty line is encountered.  Each line must be of the form C<key=value>
1099with a non-empty key.  Function returns hash with all read values.  Any white
1100space (other than new-line character) is preserved.
1101
1102=cut
1103
1104sub credential_read {
1105        my ($self, $reader) = _maybe_self(@_);
1106        my %credential;
1107        while (<$reader>) {
1108                chomp;
1109                if ($_ eq '') {
1110                        last;
1111                } elsif (!/^([^=]+)=(.*)$/) {
1112                        throw Error::Simple("unable to parse git credential data:\n$_");
1113                }
1114                $credential{$1} = $2;
1115        }
1116        return %credential;
1117}
1118
1119=item credential_write( FILEHANDLE, CREDENTIAL_HASHREF )
1120
1121Writes credential key-value pairs from hash referenced by
1122C<CREDENTIAL_HASHREF> to C<FILEHANDLE>.  Keys and values cannot contain
1123new-lines or NUL bytes characters, and key cannot contain equal signs nor be
1124empty (if they do Error::Simple is thrown).  Any white space is preserved.  If
1125value for a key is C<undef>, it will be skipped.
1126
1127If C<'url'> key exists it will be written first.  (All the other key-value
1128pairs are written in sorted order but you should not depend on that).  Once
1129all lines are written, an empty line is printed.
1130
1131=cut
1132
1133sub credential_write {
1134        my ($self, $writer, $credential) = _maybe_self(@_);
1135        my ($key, $value);
1136
1137        # Check if $credential is valid prior to writing anything
1138        while (($key, $value) = each %$credential) {
1139                if (!defined $key || !length $key) {
1140                        throw Error::Simple("credential key empty or undefined");
1141                } elsif ($key =~ /[=\n\0]/) {
1142                        throw Error::Simple("credential key contains invalid characters: $key");
1143                } elsif (defined $value && $value =~ /[\n\0]/) {
1144                        throw Error::Simple("credential value for key=$key contains invalid characters: $value");
1145                }
1146        }
1147
1148        for $key (sort {
1149                # url overwrites other fields, so it must come first
1150                return -1 if $a eq 'url';
1151                return  1 if $b eq 'url';
1152                return $a cmp $b;
1153        } keys %$credential) {
1154                if (defined $credential->{$key}) {
1155                        print $writer $key, '=', $credential->{$key}, "\n";
1156                }
1157        }
1158        print $writer "\n";
1159}
1160
1161sub _credential_run {
1162        my ($self, $credential, $op) = _maybe_self(@_);
1163        my ($pid, $reader, $writer, $ctx) = command_bidi_pipe('credential', $op);
1164
1165        credential_write $writer, $credential;
1166        close $writer;
1167
1168        if ($op eq "fill") {
1169                %$credential = credential_read $reader;
1170        }
1171        if (<$reader>) {
1172                throw Error::Simple("unexpected output from git credential $op response:\n$_\n");
1173        }
1174
1175        command_close_bidi_pipe($pid, $reader, undef, $ctx);
1176}
1177
1178=item credential( CREDENTIAL_HASHREF [, OPERATION ] )
1179
1180=item credential( CREDENTIAL_HASHREF, CODE )
1181
1182Executes C<git credential> for a given set of credentials and specified
1183operation.  In both forms C<CREDENTIAL_HASHREF> needs to be a reference to
1184a hash which stores credentials.  Under certain conditions the hash can
1185change.
1186
1187In the first form, C<OPERATION> can be C<'fill'>, C<'approve'> or C<'reject'>,
1188and function will execute corresponding C<git credential> sub-command.  If
1189it's omitted C<'fill'> is assumed.  In case of C<'fill'> the values stored in
1190C<CREDENTIAL_HASHREF> will be changed to the ones returned by the C<git
1191credential fill> command.  The usual usage would look something like:
1192
1193        my %cred = (
1194                'protocol' => 'https',
1195                'host' => 'example.com',
1196                'username' => 'bob'
1197        );
1198        Git::credential \%cred;
1199        if (try_to_authenticate($cred{'username'}, $cred{'password'})) {
1200                Git::credential \%cred, 'approve';
1201                ... do more stuff ...
1202        } else {
1203                Git::credential \%cred, 'reject';
1204        }
1205
1206In the second form, C<CODE> needs to be a reference to a subroutine.  The
1207function will execute C<git credential fill> to fill the provided credential
1208hash, then call C<CODE> with C<CREDENTIAL_HASHREF> as the sole argument.  If
1209C<CODE>'s return value is defined, the function will execute C<git credential
1210approve> (if return value yields true) or C<git credential reject> (if return
1211value is false).  If the return value is undef, nothing at all is executed;
1212this is useful, for example, if the credential could neither be verified nor
1213rejected due to an unrelated network error.  The return value is the same as
1214what C<CODE> returns.  With this form, the usage might look as follows:
1215
1216        if (Git::credential {
1217                'protocol' => 'https',
1218                'host' => 'example.com',
1219                'username' => 'bob'
1220        }, sub {
1221                my $cred = shift;
1222                return !!try_to_authenticate($cred->{'username'},
1223                                             $cred->{'password'});
1224        }) {
1225                ... do more stuff ...
1226        }
1227
1228=cut
1229
1230sub credential {
1231        my ($self, $credential, $op_or_code) = (_maybe_self(@_), 'fill');
1232
1233        if ('CODE' eq ref $op_or_code) {
1234                _credential_run $credential, 'fill';
1235                my $ret = $op_or_code->($credential);
1236                if (defined $ret) {
1237                        _credential_run $credential, $ret ? 'approve' : 'reject';
1238                }
1239                return $ret;
1240        } else {
1241                _credential_run $credential, $op_or_code;
1242        }
1243}
1244
1245{ # %TEMP_* Lexical Context
1246
1247my (%TEMP_FILEMAP, %TEMP_FILES);
1248
1249=item temp_acquire ( NAME )
1250
1251Attempts to retrieve the temporary file mapped to the string C<NAME>. If an
1252associated temp file has not been created this session or was closed, it is
1253created, cached, and set for autoflush and binmode.
1254
1255Internally locks the file mapped to C<NAME>. This lock must be released with
1256C<temp_release()> when the temp file is no longer needed. Subsequent attempts
1257to retrieve temporary files mapped to the same C<NAME> while still locked will
1258cause an error. This locking mechanism provides a weak guarantee and is not
1259threadsafe. It does provide some error checking to help prevent temp file refs
1260writing over one another.
1261
1262In general, the L<File::Handle> returned should not be closed by consumers as
1263it defeats the purpose of this caching mechanism. If you need to close the temp
1264file handle, then you should use L<File::Temp> or another temp file faculty
1265directly. If a handle is closed and then requested again, then a warning will
1266issue.
1267
1268=cut
1269
1270sub temp_acquire {
1271        my $temp_fd = _temp_cache(@_);
1272
1273        $TEMP_FILES{$temp_fd}{locked} = 1;
1274        $temp_fd;
1275}
1276
1277=item temp_is_locked ( NAME )
1278
1279Returns true if the internal lock created by a previous C<temp_acquire()>
1280call with C<NAME> is still in effect.
1281
1282When temp_acquire is called on a C<NAME>, it internally locks the temporary
1283file mapped to C<NAME>.  That lock will not be released until C<temp_release()>
1284is called with either the original C<NAME> or the L<File::Handle> that was
1285returned from the original call to temp_acquire.
1286
1287Subsequent attempts to call C<temp_acquire()> with the same C<NAME> will fail
1288unless there has been an intervening C<temp_release()> call for that C<NAME>
1289(or its corresponding L<File::Handle> that was returned by the original
1290C<temp_acquire()> call).
1291
1292If true is returned by C<temp_is_locked()> for a C<NAME>, an attempt to
1293C<temp_acquire()> the same C<NAME> will cause an error unless
1294C<temp_release> is first called on that C<NAME> (or its corresponding
1295L<File::Handle> that was returned by the original C<temp_acquire()> call).
1296
1297=cut
1298
1299sub temp_is_locked {
1300        my ($self, $name) = _maybe_self(@_);
1301        my $temp_fd = \$TEMP_FILEMAP{$name};
1302
1303        defined $$temp_fd && $$temp_fd->opened && $TEMP_FILES{$$temp_fd}{locked};
1304}
1305
1306=item temp_release ( NAME )
1307
1308=item temp_release ( FILEHANDLE )
1309
1310Releases a lock acquired through C<temp_acquire()>. Can be called either with
1311the C<NAME> mapping used when acquiring the temp file or with the C<FILEHANDLE>
1312referencing a locked temp file.
1313
1314Warns if an attempt is made to release a file that is not locked.
1315
1316The temp file will be truncated before being released. This can help to reduce
1317disk I/O where the system is smart enough to detect the truncation while data
1318is in the output buffers. Beware that after the temp file is released and
1319truncated, any operations on that file may fail miserably until it is
1320re-acquired. All contents are lost between each release and acquire mapped to
1321the same string.
1322
1323=cut
1324
1325sub temp_release {
1326        my ($self, $temp_fd, $trunc) = _maybe_self(@_);
1327
1328        if (exists $TEMP_FILEMAP{$temp_fd}) {
1329                $temp_fd = $TEMP_FILES{$temp_fd};
1330        }
1331        unless ($TEMP_FILES{$temp_fd}{locked}) {
1332                carp "Attempt to release temp file '",
1333                        $temp_fd, "' that has not been locked";
1334        }
1335        temp_reset($temp_fd) if $trunc and $temp_fd->opened;
1336
1337        $TEMP_FILES{$temp_fd}{locked} = 0;
1338        undef;
1339}
1340
1341sub _temp_cache {
1342        my ($self, $name) = _maybe_self(@_);
1343
1344        _verify_require();
1345
1346        my $temp_fd = \$TEMP_FILEMAP{$name};
1347        if (defined $$temp_fd and $$temp_fd->opened) {
1348                if ($TEMP_FILES{$$temp_fd}{locked}) {
1349                        throw Error::Simple("Temp file with moniker '" .
1350                                $name . "' already in use");
1351                }
1352        } else {
1353                if (defined $$temp_fd) {
1354                        # then we're here because of a closed handle.
1355                        carp "Temp file '", $name,
1356                                "' was closed. Opening replacement.";
1357                }
1358                my $fname;
1359
1360                my $tmpdir;
1361                if (defined $self) {
1362                        $tmpdir = $self->repo_path();
1363                }
1364
1365                my $n = $name;
1366                $n =~ s/\W/_/g; # no strange chars
1367
1368                ($$temp_fd, $fname) = File::Temp::tempfile(
1369                        "Git_${n}_XXXXXX", UNLINK => 1, DIR => $tmpdir,
1370                        ) or throw Error::Simple("couldn't open new temp file");
1371
1372                $$temp_fd->autoflush;
1373                binmode $$temp_fd;
1374                $TEMP_FILES{$$temp_fd}{fname} = $fname;
1375        }
1376        $$temp_fd;
1377}
1378
1379sub _verify_require {
1380        eval { require File::Temp; require File::Spec; };
1381        $@ and throw Error::Simple($@);
1382}
1383
1384=item temp_reset ( FILEHANDLE )
1385
1386Truncates and resets the position of the C<FILEHANDLE>.
1387
1388=cut
1389
1390sub temp_reset {
1391        my ($self, $temp_fd) = _maybe_self(@_);
1392
1393        truncate $temp_fd, 0
1394                or throw Error::Simple("couldn't truncate file");
1395        sysseek($temp_fd, 0, SEEK_SET) and seek($temp_fd, 0, SEEK_SET)
1396                or throw Error::Simple("couldn't seek to beginning of file");
1397        sysseek($temp_fd, 0, SEEK_CUR) == 0 and tell($temp_fd) == 0
1398                or throw Error::Simple("expected file position to be reset");
1399}
1400
1401=item temp_path ( NAME )
1402
1403=item temp_path ( FILEHANDLE )
1404
1405Returns the filename associated with the given tempfile.
1406
1407=cut
1408
1409sub temp_path {
1410        my ($self, $temp_fd) = _maybe_self(@_);
1411
1412        if (exists $TEMP_FILEMAP{$temp_fd}) {
1413                $temp_fd = $TEMP_FILEMAP{$temp_fd};
1414        }
1415        $TEMP_FILES{$temp_fd}{fname};
1416}
1417
1418sub END {
1419        unlink values %TEMP_FILEMAP if %TEMP_FILEMAP;
1420}
1421
1422} # %TEMP_* Lexical Context
1423
1424=back
1425
1426=head1 ERROR HANDLING
1427
1428All functions are supposed to throw Perl exceptions in case of errors.
1429See the L<Error> module on how to catch those. Most exceptions are mere
1430L<Error::Simple> instances.
1431
1432However, the C<command()>, C<command_oneline()> and C<command_noisy()>
1433functions suite can throw C<Git::Error::Command> exceptions as well: those are
1434thrown when the external command returns an error code and contain the error
1435code as well as access to the captured command's output. The exception class
1436provides the usual C<stringify> and C<value> (command's exit code) methods and
1437in addition also a C<cmd_output> method that returns either an array or a
1438string with the captured command output (depending on the original function
1439call context; C<command_noisy()> returns C<undef>) and $<cmdline> which
1440returns the command and its arguments (but without proper quoting).
1441
1442Note that the C<command_*_pipe()> functions cannot throw this exception since
1443it has no idea whether the command failed or not. You will only find out
1444at the time you C<close> the pipe; if you want to have that automated,
1445use C<command_close_pipe()>, which can throw the exception.
1446
1447=cut
1448
1449{
1450        package Git::Error::Command;
1451
1452        @Git::Error::Command::ISA = qw(Error);
1453
1454        sub new {
1455                my $self = shift;
1456                my $cmdline = '' . shift;
1457                my $value = 0 + shift;
1458                my $outputref = shift;
1459                my(@args) = ();
1460
1461                local $Error::Depth = $Error::Depth + 1;
1462
1463                push(@args, '-cmdline', $cmdline);
1464                push(@args, '-value', $value);
1465                push(@args, '-outputref', $outputref);
1466
1467                $self->SUPER::new(-text => 'command returned error', @args);
1468        }
1469
1470        sub stringify {
1471                my $self = shift;
1472                my $text = $self->SUPER::stringify;
1473                $self->cmdline() . ': ' . $text . ': ' . $self->value() . "\n";
1474        }
1475
1476        sub cmdline {
1477                my $self = shift;
1478                $self->{'-cmdline'};
1479        }
1480
1481        sub cmd_output {
1482                my $self = shift;
1483                my $ref = $self->{'-outputref'};
1484                defined $ref or undef;
1485                if (ref $ref eq 'ARRAY') {
1486                        return @$ref;
1487                } else { # SCALAR
1488                        return $$ref;
1489                }
1490        }
1491}
1492
1493=over 4
1494
1495=item git_cmd_try { CODE } ERRMSG
1496
1497This magical statement will automatically catch any C<Git::Error::Command>
1498exceptions thrown by C<CODE> and make your program die with C<ERRMSG>
1499on its lips; the message will have %s substituted for the command line
1500and %d for the exit status. This statement is useful mostly for producing
1501more user-friendly error messages.
1502
1503In case of no exception caught the statement returns C<CODE>'s return value.
1504
1505Note that this is the only auto-exported function.
1506
1507=cut
1508
1509sub git_cmd_try(&$) {
1510        my ($code, $errmsg) = @_;
1511        my @result;
1512        my $err;
1513        my $array = wantarray;
1514        try {
1515                if ($array) {
1516                        @result = &$code;
1517                } else {
1518                        $result[0] = &$code;
1519                }
1520        } catch Git::Error::Command with {
1521                my $E = shift;
1522                $err = $errmsg;
1523                $err =~ s/\%s/$E->cmdline()/ge;
1524                $err =~ s/\%d/$E->value()/ge;
1525                # We can't croak here since Error.pm would mangle
1526                # that to Error::Simple.
1527        };
1528        $err and croak $err;
1529        return $array ? @result : $result[0];
1530}
1531
1532
1533=back
1534
1535=head1 COPYRIGHT
1536
1537Copyright 2006 by Petr Baudis E<lt>pasky@suse.czE<gt>.
1538
1539This module is free software; it may be used, copied, modified
1540and distributed under the terms of the GNU General Public Licence,
1541either version 2, or (at your option) any later version.
1542
1543=cut
1544
1545
1546# Take raw method argument list and return ($obj, @args) in case
1547# the method was called upon an instance and (undef, @args) if
1548# it was called directly.
1549sub _maybe_self {
1550        UNIVERSAL::isa($_[0], 'Git') ? @_ : (undef, @_);
1551}
1552
1553# Check if the command id is something reasonable.
1554sub _check_valid_cmd {
1555        my ($cmd) = @_;
1556        $cmd =~ /^[a-z0-9A-Z_-]+$/ or throw Error::Simple("bad command: $cmd");
1557}
1558
1559# Common backend for the pipe creators.
1560sub _command_common_pipe {
1561        my $direction = shift;
1562        my ($self, @p) = _maybe_self(@_);
1563        my (%opts, $cmd, @args);
1564        if (ref $p[0]) {
1565                ($cmd, @args) = @{shift @p};
1566                %opts = ref $p[0] ? %{$p[0]} : @p;
1567        } else {
1568                ($cmd, @args) = @p;
1569        }
1570        _check_valid_cmd($cmd);
1571
1572        my $fh;
1573        if ($^O eq 'MSWin32') {
1574                # ActiveState Perl
1575                #defined $opts{STDERR} and
1576                #       warn 'ignoring STDERR option - running w/ ActiveState';
1577                $direction eq '-|' or
1578                        die 'input pipe for ActiveState not implemented';
1579                # the strange construction with *ACPIPE is just to
1580                # explain the tie below that we want to bind to
1581                # a handle class, not scalar. It is not known if
1582                # it is something specific to ActiveState Perl or
1583                # just a Perl quirk.
1584                tie (*ACPIPE, 'Git::activestate_pipe', $cmd, @args);
1585                $fh = *ACPIPE;
1586
1587        } else {
1588                my $pid = open($fh, $direction);
1589                if (not defined $pid) {
1590                        throw Error::Simple("open failed: $!");
1591                } elsif ($pid == 0) {
1592                        if ($opts{STDERR}) {
1593                                open (STDERR, '>&', $opts{STDERR})
1594                                        or die "dup failed: $!";
1595                        } elsif (defined $opts{STDERR}) {
1596                                open (STDERR, '>', '/dev/null')
1597                                        or die "opening /dev/null failed: $!";
1598                        }
1599                        _cmd_exec($self, $cmd, @args);
1600                }
1601        }
1602        return wantarray ? ($fh, join(' ', $cmd, @args)) : $fh;
1603}
1604
1605# When already in the subprocess, set up the appropriate state
1606# for the given repository and execute the git command.
1607sub _cmd_exec {
1608        my ($self, @args) = @_;
1609        _setup_git_cmd_env($self);
1610        _execv_git_cmd(@args);
1611        die qq[exec "@args" failed: $!];
1612}
1613
1614# set up the appropriate state for git command
1615sub _setup_git_cmd_env {
1616        my $self = shift;
1617        if ($self) {
1618                $self->repo_path() and $ENV{'GIT_DIR'} = $self->repo_path();
1619                $self->repo_path() and $self->wc_path()
1620                        and $ENV{'GIT_WORK_TREE'} = $self->wc_path();
1621                $self->wc_path() and chdir($self->wc_path());
1622                $self->wc_subdir() and chdir($self->wc_subdir());
1623        }
1624}
1625
1626# Execute the given Git command ($_[0]) with arguments ($_[1..])
1627# by searching for it at proper places.
1628sub _execv_git_cmd { exec('git', @_); }
1629
1630# Close pipe to a subprocess.
1631sub _cmd_close {
1632        my $ctx = shift @_;
1633        foreach my $fh (@_) {
1634                if (close $fh) {
1635                        # nop
1636                } elsif ($!) {
1637                        # It's just close, no point in fatalities
1638                        carp "error closing pipe: $!";
1639                } elsif ($? >> 8) {
1640                        # The caller should pepper this.
1641                        throw Git::Error::Command($ctx, $? >> 8);
1642                }
1643                # else we might e.g. closed a live stream; the command
1644                # dying of SIGPIPE would drive us here.
1645        }
1646}
1647
1648
1649sub DESTROY {
1650        my ($self) = @_;
1651        $self->_close_hash_and_insert_object();
1652        $self->_close_cat_blob();
1653}
1654
1655
1656# Pipe implementation for ActiveState Perl.
1657
1658package Git::activestate_pipe;
1659use strict;
1660
1661sub TIEHANDLE {
1662        my ($class, @params) = @_;
1663        # FIXME: This is probably horrible idea and the thing will explode
1664        # at the moment you give it arguments that require some quoting,
1665        # but I have no ActiveState clue... --pasky
1666        # Let's just hope ActiveState Perl does at least the quoting
1667        # correctly.
1668        my @data = qx{git @params};
1669        bless { i => 0, data => \@data }, $class;
1670}
1671
1672sub READLINE {
1673        my $self = shift;
1674        if ($self->{i} >= scalar @{$self->{data}}) {
1675                return undef;
1676        }
1677        my $i = $self->{i};
1678        if (wantarray) {
1679                $self->{i} = $#{$self->{'data'}} + 1;
1680                return splice(@{$self->{'data'}}, $i);
1681        }
1682        $self->{i} = $i + 1;
1683        return $self->{'data'}->[ $i ];
1684}
1685
1686sub CLOSE {
1687        my $self = shift;
1688        delete $self->{data};
1689        delete $self->{i};
1690}
1691
1692sub EOF {
1693        my $self = shift;
1694        return ($self->{i} >= scalar @{$self->{data}});
1695}
1696
1697
16981; # Famous last words