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