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