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