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