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