1=head1 NAME 2 3Git - Perl interface to the Git version control system 4 5=cut 6 7 8package Git; 9 10use strict; 11 12 13BEGIN{ 14 15our($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 49require 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 61 62=head1 DESCRIPTION 63 64This module provides Perl scripts easy way to interface the Git version control 65system. The modules have an easy and well-tested way to call arbitrary Git 66commands; in the future, the interface will also provide specialized methods 67for doing easily operations which are not totally trivial to do over 68the generic command interface. 69 70While some commands can be executed outside of any context (e.g. 'version' 71or 'init'), most operations require a repository context, which in practice 72means getting an instance of the Git object using the repository() constructor. 73(In the future, we will also get a new_repository() constructor.) All commands 74called as methods of the object are then executed in the context of the 75repository. 76 77Part of the "repository state" is also information about path to the attached 78working copy (unless you work with a bare repository). You can also navigate 79inside of the working copy using the C<wc_chdir()> method. (Note that 80the repository object is self-contained and will not change working directory 81of your process.) 82 83TODO: In the future, we might also do 84 85 my $remoterepo = $repo->remote_repository (Name => 'cogito', Branch => 'master'); 86 $remoterepo ||= Git->remote_repository ('http://git.or.cz/cogito.git/'); 87 my @refs = $remoterepo->refs(); 88 89Currently, the module merely wraps calls to external Git tools. In the future, 90it will provide a much faster way to interact with Git by linking directly 91to libgit. This should be completely opaque to the user, though (performance 92increate nonwithstanding). 93 94=cut 95 96 97use Carp qw(carp croak);# but croak is bad - throw instead 98use Error qw(:try); 99use Cwd qw(abs_path); 100use IPC::Open2 qw(open2); 101 102} 103 104 105=head1 CONSTRUCTORS 106 107=over 4 108 109=item repository ( OPTIONS ) 110 111=item repository ( DIRECTORY ) 112 113=item repository () 114 115Construct a new repository object. 116C<OPTIONS> are passed in a hash like fashion, using key and value pairs. 117Possible options are: 118 119B<Repository> - Path to the Git repository. 120 121B<WorkingCopy> - Path to the associated working copy; not strictly required 122as many commands will happily crunch on a bare repository. 123 124B<WorkingSubdir> - Subdirectory in the working copy to work inside. 125Just left undefined if you do not want to limit the scope of operations. 126 127B<Directory> - Path to the Git working directory in its usual setup. 128The C<.git> directory is searched in the directory and all the parent 129directories; if found, C<WorkingCopy> is set to the directory containing 130it and C<Repository> to the C<.git> directory itself. If no C<.git> 131directory was found, the C<Directory> is assumed to be a bare repository, 132C<Repository> is set to point at it and C<WorkingCopy> is left undefined. 133If the C<$GIT_DIR> environment variable is set, things behave as expected 134as well. 135 136You should not use both C<Directory> and either of C<Repository> and 137C<WorkingCopy> - the results of that are undefined. 138 139Alternatively, a directory path may be passed as a single scalar argument 140to the constructor; it is equivalent to setting only the C<Directory> option 141field. 142 143Calling the constructor with no options whatsoever is equivalent to 144calling it with C<< Directory => '.' >>. In general, if you are building 145a standard porcelain command, simply doing C<< Git->repository() >> should 146do the right thing and setup the object to reflect exactly where the user 147is right now. 148 149=cut 150 151sub repository { 152my$class=shift; 153my@args=@_; 154my%opts= (); 155my$self; 156 157if(defined$args[0]) { 158if($#args%2!=1) { 159# Not a hash. 160$#args==0or throw Error::Simple("bad usage"); 161%opts= ( Directory =>$args[0] ); 162}else{ 163%opts=@args; 164} 165} 166 167if(not defined$opts{Repository}and not defined$opts{WorkingCopy}) { 168$opts{Directory} ||='.'; 169} 170 171if($opts{Directory}) { 172-d $opts{Directory}or throw Error::Simple("Directory not found:$!"); 173 174my$search= Git->repository(WorkingCopy =>$opts{Directory}); 175my$dir; 176try{ 177$dir=$search->command_oneline(['rev-parse','--git-dir'], 178 STDERR =>0); 179} catch Git::Error::Command with { 180$dir=undef; 181}; 182 183if($dir) { 184$dir=~ m#^/# or $dir = $opts{Directory} . '/' . $dir; 185$opts{Repository} =$dir; 186 187# If --git-dir went ok, this shouldn't die either. 188my$prefix=$search->command_oneline('rev-parse','--show-prefix'); 189$dir= abs_path($opts{Directory}) .'/'; 190if($prefix) { 191if(substr($dir, -length($prefix))ne$prefix) { 192 throw Error::Simple("rev-parse confused me -$dirdoes not have trailing$prefix"); 193} 194substr($dir, -length($prefix)) =''; 195} 196$opts{WorkingCopy} =$dir; 197$opts{WorkingSubdir} =$prefix; 198 199}else{ 200# A bare repository? Let's see... 201$dir=$opts{Directory}; 202 203unless(-d "$dir/refs"and-d "$dir/objects"and-e "$dir/HEAD") { 204# Mimick git-rev-parse --git-dir error message: 205 throw Error::Simple('fatal: Not a git repository'); 206} 207my$search= Git->repository(Repository =>$dir); 208try{ 209$search->command('symbolic-ref','HEAD'); 210} catch Git::Error::Command with { 211# Mimick git-rev-parse --git-dir error message: 212 throw Error::Simple('fatal: Not a git repository'); 213} 214 215$opts{Repository} = abs_path($dir); 216} 217 218delete$opts{Directory}; 219} 220 221$self= { opts => \%opts}; 222bless$self,$class; 223} 224 225=back 226 227=head1 METHODS 228 229=over 4 230 231=item command ( COMMAND [, ARGUMENTS... ] ) 232 233=item command ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } ) 234 235Execute the given Git C<COMMAND> (specify it without the 'git-' 236prefix), optionally with the specified extra C<ARGUMENTS>. 237 238The second more elaborate form can be used if you want to further adjust 239the command execution. Currently, only one option is supported: 240 241B<STDERR> - How to deal with the command's error output. By default (C<undef>) 242it is delivered to the caller's C<STDERR>. A false value (0 or '') will cause 243it to be thrown away. If you want to process it, you can get it in a filehandle 244you specify, but you must be extremely careful; if the error output is not 245very short and you want to read it in the same process as where you called 246C<command()>, you are set up for a nice deadlock! 247 248The method can be called without any instance or on a specified Git repository 249(in that case the command will be run in the repository context). 250 251In scalar context, it returns all the command output in a single string 252(verbatim). 253 254In array context, it returns an array containing lines printed to the 255command's stdout (without trailing newlines). 256 257In both cases, the command's stdin and stderr are the same as the caller's. 258 259=cut 260 261sub command { 262my($fh,$ctx) = command_output_pipe(@_); 263 264if(not defined wantarray) { 265# Nothing to pepper the possible exception with. 266 _cmd_close($fh,$ctx); 267 268}elsif(not wantarray) { 269local$/; 270my$text= <$fh>; 271try{ 272 _cmd_close($fh,$ctx); 273} catch Git::Error::Command with { 274# Pepper with the output: 275my$E=shift; 276$E->{'-outputref'} = \$text; 277 throw $E; 278}; 279return$text; 280 281}else{ 282my@lines= <$fh>; 283defined and chompfor@lines; 284try{ 285 _cmd_close($fh,$ctx); 286} catch Git::Error::Command with { 287my$E=shift; 288$E->{'-outputref'} = \@lines; 289 throw $E; 290}; 291return@lines; 292} 293} 294 295 296=item command_oneline ( COMMAND [, ARGUMENTS... ] ) 297 298=item command_oneline ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } ) 299 300Execute the given C<COMMAND> in the same way as command() 301does but always return a scalar string containing the first line 302of the command's standard output. 303 304=cut 305 306sub command_oneline { 307my($fh,$ctx) = command_output_pipe(@_); 308 309my$line= <$fh>; 310defined$lineand chomp$line; 311try{ 312 _cmd_close($fh,$ctx); 313} catch Git::Error::Command with { 314# Pepper with the output: 315my$E=shift; 316$E->{'-outputref'} = \$line; 317 throw $E; 318}; 319return$line; 320} 321 322 323=item command_output_pipe ( COMMAND [, ARGUMENTS... ] ) 324 325=item command_output_pipe ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } ) 326 327Execute the given C<COMMAND> in the same way as command() 328does but return a pipe filehandle from which the command output can be 329read. 330 331The function can return C<($pipe, $ctx)> in array context. 332See C<command_close_pipe()> for details. 333 334=cut 335 336sub command_output_pipe { 337 _command_common_pipe('-|',@_); 338} 339 340 341=item command_input_pipe ( COMMAND [, ARGUMENTS... ] ) 342 343=item command_input_pipe ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } ) 344 345Execute the given C<COMMAND> in the same way as command_output_pipe() 346does but return an input pipe filehandle instead; the command output 347is not captured. 348 349The function can return C<($pipe, $ctx)> in array context. 350See C<command_close_pipe()> for details. 351 352=cut 353 354sub command_input_pipe { 355 _command_common_pipe('|-',@_); 356} 357 358 359=item command_close_pipe ( PIPE [, CTX ] ) 360 361Close the C<PIPE> as returned from C<command_*_pipe()>, checking 362whether the command finished successfully. The optional C<CTX> argument 363is required if you want to see the command name in the error message, 364and it is the second value returned by C<command_*_pipe()> when 365called in array context. The call idiom is: 366 367 my ($fh, $ctx) = $r->command_output_pipe('status'); 368 while (<$fh>) { ... } 369 $r->command_close_pipe($fh, $ctx); 370 371Note that you should not rely on whatever actually is in C<CTX>; 372currently it is simply the command name but in future the context might 373have more complicated structure. 374 375=cut 376 377sub command_close_pipe { 378my($self,$fh,$ctx) = _maybe_self(@_); 379$ctx||='<unknown>'; 380 _cmd_close($fh,$ctx); 381} 382 383=item command_bidi_pipe ( COMMAND [, ARGUMENTS... ] ) 384 385Execute the given C<COMMAND> in the same way as command_output_pipe() 386does but return both an input pipe filehandle and an output pipe filehandle. 387 388The function will return return C<($pid, $pipe_in, $pipe_out, $ctx)>. 389See C<command_close_bidi_pipe()> for details. 390 391=cut 392 393sub command_bidi_pipe { 394my($pid,$in,$out); 395$pid= open2($in,$out,'git',@_); 396return($pid,$in,$out,join(' ',@_)); 397} 398 399=item command_close_bidi_pipe ( PID, PIPE_IN, PIPE_OUT [, CTX] ) 400 401Close the C<PIPE_IN> and C<PIPE_OUT> as returned from C<command_bidi_pipe()>, 402checking whether the command finished successfully. The optional C<CTX> 403argument is required if you want to see the command name in the error message, 404and it is the fourth value returned by C<command_bidi_pipe()>. The call idiom 405is: 406 407 my ($pid, $in, $out, $ctx) = $r->command_bidi_pipe('cat-file --batch-check'); 408 print "000000000\n" $out; 409 while (<$in>) { ... } 410 $r->command_close_bidi_pipe($pid, $in, $out, $ctx); 411 412Note that you should not rely on whatever actually is in C<CTX>; 413currently it is simply the command name but in future the context might 414have more complicated structure. 415 416=cut 417 418sub command_close_bidi_pipe { 419my($pid,$in,$out,$ctx) =@_; 420foreachmy$fh($in,$out) { 421unless(close$fh) { 422if($!) { 423 carp "error closing pipe:$!"; 424}elsif($?>>8) { 425 throw Git::Error::Command($ctx,$?>>8); 426} 427} 428} 429 430waitpid$pid,0; 431 432if($?>>8) { 433 throw Git::Error::Command($ctx,$?>>8); 434} 435} 436 437 438=item command_noisy ( COMMAND [, ARGUMENTS... ] ) 439 440Execute the given C<COMMAND> in the same way as command() does but do not 441capture the command output - the standard output is not redirected and goes 442to the standard output of the caller application. 443 444While the method is called command_noisy(), you might want to as well use 445it for the most silent Git commands which you know will never pollute your 446stdout but you want to avoid the overhead of the pipe setup when calling them. 447 448The function returns only after the command has finished running. 449 450=cut 451 452sub command_noisy { 453my($self,$cmd,@args) = _maybe_self(@_); 454 _check_valid_cmd($cmd); 455 456my$pid=fork; 457if(not defined$pid) { 458 throw Error::Simple("fork failed:$!"); 459}elsif($pid==0) { 460 _cmd_exec($self,$cmd,@args); 461} 462if(waitpid($pid,0) >0and$?>>8!=0) { 463 throw Git::Error::Command(join(' ',$cmd,@args),$?>>8); 464} 465} 466 467 468=item version () 469 470Return the Git version in use. 471 472=cut 473 474sub version { 475my$verstr= command_oneline('--version'); 476$verstr=~s/^git version //; 477$verstr; 478} 479 480 481=item exec_path () 482 483Return path to the Git sub-command executables (the same as 484C<git --exec-path>). Useful mostly only internally. 485 486=cut 487 488sub exec_path { command_oneline('--exec-path') } 489 490 491=item repo_path () 492 493Return path to the git repository. Must be called on a repository instance. 494 495=cut 496 497sub repo_path {$_[0]->{opts}->{Repository} } 498 499 500=item wc_path () 501 502Return path to the working copy. Must be called on a repository instance. 503 504=cut 505 506sub wc_path {$_[0]->{opts}->{WorkingCopy} } 507 508 509=item wc_subdir () 510 511Return path to the subdirectory inside of a working copy. Must be called 512on a repository instance. 513 514=cut 515 516sub wc_subdir {$_[0]->{opts}->{WorkingSubdir} ||=''} 517 518 519=item wc_chdir ( SUBDIR ) 520 521Change the working copy subdirectory to work within. The C<SUBDIR> is 522relative to the working copy root directory (not the current subdirectory). 523Must be called on a repository instance attached to a working copy 524and the directory must exist. 525 526=cut 527 528sub wc_chdir { 529my($self,$subdir) =@_; 530$self->wc_path() 531or throw Error::Simple("bare repository"); 532 533-d $self->wc_path().'/'.$subdir 534or throw Error::Simple("subdir not found:$!"); 535# Of course we will not "hold" the subdirectory so anyone 536# can delete it now and we will never know. But at least we tried. 537 538$self->{opts}->{WorkingSubdir} =$subdir; 539} 540 541 542=item config ( VARIABLE ) 543 544Retrieve the configuration C<VARIABLE> in the same manner as C<config> 545does. In scalar context requires the variable to be set only one time 546(exception is thrown otherwise), in array context returns allows the 547variable to be set multiple times and returns all the values. 548 549This currently wraps command('config') so it is not so fast. 550 551=cut 552 553sub config { 554my($self,$var) = _maybe_self(@_); 555 556try{ 557my@cmd= ('config'); 558unshift@cmd,$selfif$self; 559if(wantarray) { 560return command(@cmd,'--get-all',$var); 561}else{ 562return command_oneline(@cmd,'--get',$var); 563} 564} catch Git::Error::Command with { 565my$E=shift; 566if($E->value() ==1) { 567# Key not found. 568returnundef; 569}else{ 570 throw $E; 571} 572}; 573} 574 575 576=item config_bool ( VARIABLE ) 577 578Retrieve the bool configuration C<VARIABLE>. The return value 579is usable as a boolean in perl (and C<undef> if it's not defined, 580of course). 581 582This currently wraps command('config') so it is not so fast. 583 584=cut 585 586sub config_bool { 587my($self,$var) = _maybe_self(@_); 588 589try{ 590my@cmd= ('config','--bool','--get',$var); 591unshift@cmd,$selfif$self; 592my$val= command_oneline(@cmd); 593returnundefunlessdefined$val; 594return$valeq'true'; 595} catch Git::Error::Command with { 596my$E=shift; 597if($E->value() ==1) { 598# Key not found. 599returnundef; 600}else{ 601 throw $E; 602} 603}; 604} 605 606=item config_int ( VARIABLE ) 607 608Retrieve the integer configuration C<VARIABLE>. The return value 609is simple decimal number. An optional value suffix of 'k', 'm', 610or 'g' in the config file will cause the value to be multiplied 611by 1024, 1048576 (1024^2), or 1073741824 (1024^3) prior to output. 612It would return C<undef> if configuration variable is not defined, 613 614This currently wraps command('config') so it is not so fast. 615 616=cut 617 618sub config_int { 619my($self,$var) = _maybe_self(@_); 620 621try{ 622my@cmd= ('config','--int','--get',$var); 623unshift@cmd,$selfif$self; 624return command_oneline(@cmd); 625} catch Git::Error::Command with { 626my$E=shift; 627if($E->value() ==1) { 628# Key not found. 629returnundef; 630}else{ 631 throw $E; 632} 633}; 634} 635 636=item get_colorbool ( NAME ) 637 638Finds if color should be used for NAMEd operation from the configuration, 639and returns boolean (true for "use color", false for "do not use color"). 640 641=cut 642 643sub get_colorbool { 644my($self,$var) =@_; 645my$stdout_to_tty= (-t STDOUT) ?"true":"false"; 646my$use_color=$self->command_oneline('config','--get-colorbool', 647$var,$stdout_to_tty); 648return($use_coloreq'true'); 649} 650 651=item get_color ( SLOT, COLOR ) 652 653Finds color for SLOT from the configuration, while defaulting to COLOR, 654and returns the ANSI color escape sequence: 655 656 print $repo->get_color("color.interactive.prompt", "underline blue white"); 657 print "some text"; 658 print $repo->get_color("", "normal"); 659 660=cut 661 662sub get_color { 663my($self,$slot,$default) =@_; 664my$color=$self->command_oneline('config','--get-color',$slot,$default); 665if(!defined$color) { 666$color=""; 667} 668return$color; 669} 670 671=item ident ( TYPE | IDENTSTR ) 672 673=item ident_person ( TYPE | IDENTSTR | IDENTARRAY ) 674 675This suite of functions retrieves and parses ident information, as stored 676in the commit and tag objects or produced by C<var GIT_type_IDENT> (thus 677C<TYPE> can be either I<author> or I<committer>; case is insignificant). 678 679The C<ident> method retrieves the ident information from C<git-var> 680and either returns it as a scalar string or as an array with the fields parsed. 681Alternatively, it can take a prepared ident string (e.g. from the commit 682object) and just parse it. 683 684C<ident_person> returns the person part of the ident - name and email; 685it can take the same arguments as C<ident> or the array returned by C<ident>. 686 687The synopsis is like: 688 689 my ($name, $email, $time_tz) = ident('author'); 690 "$name <$email>" eq ident_person('author'); 691 "$name <$email>" eq ident_person($name); 692 $time_tz =~ /^\d+ [+-]\d{4}$/; 693 694=cut 695 696sub ident { 697my($self,$type) = _maybe_self(@_); 698my$identstr; 699if(lc$typeeq lc'committer'or lc$typeeq lc'author') { 700my@cmd= ('var','GIT_'.uc($type).'_IDENT'); 701unshift@cmd,$selfif$self; 702$identstr= command_oneline(@cmd); 703}else{ 704$identstr=$type; 705} 706if(wantarray) { 707return$identstr=~/^(.*) <(.*)> (\d+ [+-]\d{4})$/; 708}else{ 709return$identstr; 710} 711} 712 713sub ident_person { 714my($self,@ident) = _maybe_self(@_); 715$#ident==0and@ident=$self?$self->ident($ident[0]) : ident($ident[0]); 716return"$ident[0] <$ident[1]>"; 717} 718 719 720=item hash_object ( TYPE, FILENAME ) 721 722Compute the SHA1 object id of the given C<FILENAME> (or data waiting in 723C<FILEHANDLE>) considering it is of the C<TYPE> object type (C<blob>, 724C<commit>, C<tree>). 725 726The method can be called without any instance or on a specified Git repository, 727it makes zero difference. 728 729The function returns the SHA1 hash. 730 731=cut 732 733# TODO: Support for passing FILEHANDLE instead of FILENAME 734sub hash_object { 735my($self,$type,$file) = _maybe_self(@_); 736 command_oneline('hash-object','-t',$type,$file); 737} 738 739 740=item hash_and_insert_object ( FILENAME ) 741 742Compute the SHA1 object id of the given C<FILENAME> and add the object to the 743object database. 744 745The function returns the SHA1 hash. 746 747=cut 748 749# TODO: Support for passing FILEHANDLE instead of FILENAME 750sub hash_and_insert_object { 751my($self,$filename) =@_; 752 753 carp "Bad filename\"$filename\""if$filename=~/[\r\n]/; 754 755$self->_open_hash_and_insert_object_if_needed(); 756my($in,$out) = ($self->{hash_object_in},$self->{hash_object_out}); 757 758unless(print$out $filename,"\n") { 759$self->_close_hash_and_insert_object(); 760 throw Error::Simple("out pipe went bad"); 761} 762 763chomp(my$hash= <$in>); 764unless(defined($hash)) { 765$self->_close_hash_and_insert_object(); 766 throw Error::Simple("in pipe went bad"); 767} 768 769return$hash; 770} 771 772sub _open_hash_and_insert_object_if_needed { 773my($self) =@_; 774 775return ifdefined($self->{hash_object_pid}); 776 777($self->{hash_object_pid},$self->{hash_object_in}, 778$self->{hash_object_out},$self->{hash_object_ctx}) = 779 command_bidi_pipe(qw(hash-object -w --stdin-paths)); 780} 781 782sub _close_hash_and_insert_object { 783my($self) =@_; 784 785return unlessdefined($self->{hash_object_pid}); 786 787my@vars=map{'hash_object_'.$_}qw(pid in out ctx); 788 789 command_close_bidi_pipe($self->{@vars}); 790delete$self->{@vars}; 791} 792 793=item cat_blob ( SHA1, FILEHANDLE ) 794 795Prints the contents of the blob identified by C<SHA1> to C<FILEHANDLE> and 796returns the number of bytes printed. 797 798=cut 799 800sub cat_blob { 801my($self,$sha1,$fh) =@_; 802 803$self->_open_cat_blob_if_needed(); 804my($in,$out) = ($self->{cat_blob_in},$self->{cat_blob_out}); 805 806unless(print$out $sha1,"\n") { 807$self->_close_cat_blob(); 808 throw Error::Simple("out pipe went bad"); 809} 810 811my$description= <$in>; 812if($description=~/ missing$/) { 813 carp "$sha1doesn't exist in the repository"; 814return0; 815} 816 817if($description!~/^[0-9a-fA-F]{40} \S+ (\d+)$/) { 818 carp "Unexpected result returned from git cat-file"; 819return0; 820} 821 822my$size=$1; 823 824my$blob; 825my$bytesRead=0; 826 827while(1) { 828my$bytesLeft=$size-$bytesRead; 829last unless$bytesLeft; 830 831my$bytesToRead=$bytesLeft<1024?$bytesLeft:1024; 832my$read=read($in,$blob,$bytesToRead,$bytesRead); 833unless(defined($read)) { 834$self->_close_cat_blob(); 835 throw Error::Simple("in pipe went bad"); 836} 837 838$bytesRead+=$read; 839} 840 841# Skip past the trailing newline. 842my$newline; 843my$read=read($in,$newline,1); 844unless(defined($read)) { 845$self->_close_cat_blob(); 846 throw Error::Simple("in pipe went bad"); 847} 848unless($read==1&&$newlineeq"\n") { 849$self->_close_cat_blob(); 850 throw Error::Simple("didn't find newline after blob"); 851} 852 853unless(print$fh $blob) { 854$self->_close_cat_blob(); 855 throw Error::Simple("couldn't write to passed in filehandle"); 856} 857 858return$size; 859} 860 861sub _open_cat_blob_if_needed { 862my($self) =@_; 863 864return ifdefined($self->{cat_blob_pid}); 865 866($self->{cat_blob_pid},$self->{cat_blob_in}, 867$self->{cat_blob_out},$self->{cat_blob_ctx}) = 868 command_bidi_pipe(qw(cat-file --batch)); 869} 870 871sub _close_cat_blob { 872my($self) =@_; 873 874return unlessdefined($self->{cat_blob_pid}); 875 876my@vars=map{'cat_blob_'.$_}qw(pid in out ctx); 877 878 command_close_bidi_pipe($self->{@vars}); 879delete$self->{@vars}; 880} 881 882=back 883 884=head1 ERROR HANDLING 885 886All functions are supposed to throw Perl exceptions in case of errors. 887See the L<Error> module on how to catch those. Most exceptions are mere 888L<Error::Simple> instances. 889 890However, the C<command()>, C<command_oneline()> and C<command_noisy()> 891functions suite can throw C<Git::Error::Command> exceptions as well: those are 892thrown when the external command returns an error code and contain the error 893code as well as access to the captured command's output. The exception class 894provides the usual C<stringify> and C<value> (command's exit code) methods and 895in addition also a C<cmd_output> method that returns either an array or a 896string with the captured command output (depending on the original function 897call context; C<command_noisy()> returns C<undef>) and $<cmdline> which 898returns the command and its arguments (but without proper quoting). 899 900Note that the C<command_*_pipe()> functions cannot throw this exception since 901it has no idea whether the command failed or not. You will only find out 902at the time you C<close> the pipe; if you want to have that automated, 903use C<command_close_pipe()>, which can throw the exception. 904 905=cut 906 907{ 908package Git::Error::Command; 909 910@Git::Error::Command::ISA =qw(Error); 911 912sub new { 913my$self=shift; 914my$cmdline=''.shift; 915my$value=0+shift; 916my$outputref=shift; 917my(@args) = (); 918 919local$Error::Depth =$Error::Depth +1; 920 921push(@args,'-cmdline',$cmdline); 922push(@args,'-value',$value); 923push(@args,'-outputref',$outputref); 924 925$self->SUPER::new(-text =>'command returned error',@args); 926} 927 928sub stringify { 929my$self=shift; 930my$text=$self->SUPER::stringify; 931$self->cmdline() .': '.$text.': '.$self->value() ."\n"; 932} 933 934sub cmdline { 935my$self=shift; 936$self->{'-cmdline'}; 937} 938 939sub cmd_output { 940my$self=shift; 941my$ref=$self->{'-outputref'}; 942defined$refor undef; 943if(ref$refeq'ARRAY') { 944return@$ref; 945}else{# SCALAR 946return$$ref; 947} 948} 949} 950 951=over 4 952 953=item git_cmd_try { CODE } ERRMSG 954 955This magical statement will automatically catch any C<Git::Error::Command> 956exceptions thrown by C<CODE> and make your program die with C<ERRMSG> 957on its lips; the message will have %s substituted for the command line 958and %d for the exit status. This statement is useful mostly for producing 959more user-friendly error messages. 960 961In case of no exception caught the statement returns C<CODE>'s return value. 962 963Note that this is the only auto-exported function. 964 965=cut 966 967sub git_cmd_try(&$) { 968my($code,$errmsg) =@_; 969my@result; 970my$err; 971my$array=wantarray; 972try{ 973if($array) { 974@result= &$code; 975}else{ 976$result[0] = &$code; 977} 978} catch Git::Error::Command with { 979my$E=shift; 980$err=$errmsg; 981$err=~s/\%s/$E->cmdline()/ge; 982$err=~s/\%d/$E->value()/ge; 983# We can't croak here since Error.pm would mangle 984# that to Error::Simple. 985}; 986$errand croak $err; 987return$array?@result:$result[0]; 988} 989 990 991=back 992 993=head1 COPYRIGHT 994 995Copyright 2006 by Petr Baudis E<lt>pasky@suse.czE<gt>. 996 997This module is free software; it may be used, copied, modified 998and distributed under the terms of the GNU General Public Licence, 999either version 2, or (at your option) any later version.10001001=cut100210031004# Take raw method argument list and return ($obj, @args) in case1005# the method was called upon an instance and (undef, @args) if1006# it was called directly.1007sub _maybe_self {1008# This breaks inheritance. Oh well.1009ref$_[0]eq'Git'?@_: (undef,@_);1010}10111012# Check if the command id is something reasonable.1013sub _check_valid_cmd {1014my($cmd) =@_;1015$cmd=~/^[a-z0-9A-Z_-]+$/or throw Error::Simple("bad command:$cmd");1016}10171018# Common backend for the pipe creators.1019sub _command_common_pipe {1020my$direction=shift;1021my($self,@p) = _maybe_self(@_);1022my(%opts,$cmd,@args);1023if(ref$p[0]) {1024($cmd,@args) = @{shift@p};1025%opts=ref$p[0] ? %{$p[0]} :@p;1026}else{1027($cmd,@args) =@p;1028}1029 _check_valid_cmd($cmd);10301031my$fh;1032if($^Oeq'MSWin32') {1033# ActiveState Perl1034#defined $opts{STDERR} and1035# warn 'ignoring STDERR option - running w/ ActiveState';1036$directioneq'-|'or1037die'input pipe for ActiveState not implemented';1038# the strange construction with *ACPIPE is just to1039# explain the tie below that we want to bind to1040# a handle class, not scalar. It is not known if1041# it is something specific to ActiveState Perl or1042# just a Perl quirk.1043 tie (*ACPIPE,'Git::activestate_pipe',$cmd,@args);1044$fh= *ACPIPE;10451046}else{1047my$pid=open($fh,$direction);1048if(not defined$pid) {1049 throw Error::Simple("open failed:$!");1050}elsif($pid==0) {1051if(defined$opts{STDERR}) {1052close STDERR;1053}1054if($opts{STDERR}) {1055open(STDERR,'>&',$opts{STDERR})1056or die"dup failed:$!";1057}1058 _cmd_exec($self,$cmd,@args);1059}1060}1061returnwantarray? ($fh,join(' ',$cmd,@args)) :$fh;1062}10631064# When already in the subprocess, set up the appropriate state1065# for the given repository and execute the git command.1066sub _cmd_exec {1067my($self,@args) =@_;1068if($self) {1069$self->repo_path()and$ENV{'GIT_DIR'} =$self->repo_path();1070$self->wc_path()and chdir($self->wc_path());1071$self->wc_subdir()and chdir($self->wc_subdir());1072}1073 _execv_git_cmd(@args);1074dieqq[exec "@args" failed:$!];1075}10761077# Execute the given Git command ($_[0]) with arguments ($_[1..])1078# by searching for it at proper places.1079sub _execv_git_cmd {exec('git',@_); }10801081# Close pipe to a subprocess.1082sub _cmd_close {1083my($fh,$ctx) =@_;1084if(not close$fh) {1085if($!) {1086# It's just close, no point in fatalities1087 carp "error closing pipe:$!";1088}elsif($?>>8) {1089# The caller should pepper this.1090 throw Git::Error::Command($ctx,$?>>8);1091}1092# else we might e.g. closed a live stream; the command1093# dying of SIGPIPE would drive us here.1094}1095}109610971098sub DESTROY {1099my($self) =@_;1100$self->_close_hash_and_insert_object();1101$self->_close_cat_blob();1102}110311041105# Pipe implementation for ActiveState Perl.11061107package Git::activestate_pipe;1108use strict;11091110sub TIEHANDLE {1111my($class,@params) =@_;1112# FIXME: This is probably horrible idea and the thing will explode1113# at the moment you give it arguments that require some quoting,1114# but I have no ActiveState clue... --pasky1115# Let's just hope ActiveState Perl does at least the quoting1116# correctly.1117my@data=qx{git@params};1118bless{ i =>0, data => \@data},$class;1119}11201121sub READLINE {1122my$self=shift;1123if($self->{i} >=scalar@{$self->{data}}) {1124returnundef;1125}1126my$i=$self->{i};1127if(wantarray) {1128$self->{i} =$#{$self->{'data'}} +1;1129returnsplice(@{$self->{'data'}},$i);1130}1131$self->{i} =$i+1;1132return$self->{'data'}->[$i];1133}11341135sub CLOSE {1136my$self=shift;1137delete$self->{data};1138delete$self->{i};1139}11401141sub EOF {1142my$self=shift;1143return($self->{i} >=scalar@{$self->{data}});1144}1145114611471;# Famous last words