perl/Git.pm

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