1=head1 NAME 2 3Git - Perl interface to the Git version control system 4 5=cut 6 7 8package Git; 9 10use5.008; 11use strict; 12 13 14BEGIN{ 15 16our($VERSION,@ISA,@EXPORT,@EXPORT_OK); 17 18# Totally unstable API. 19$VERSION='0.01'; 20 21 22=head1 SYNOPSIS 23 24 use Git; 25 26 my $version = Git::command_oneline('version'); 27 28 git_cmd_try { Git::command_noisy('update-server-info') } 29 '%s failed w/ code %d'; 30 31 my $repo = Git->repository (Directory => '/srv/git/cogito.git'); 32 33 34 my @revs = $repo->command('rev-list', '--since=last monday', '--all'); 35 36 my ($fh, $c) = $repo->command_output_pipe('rev-list', '--since=last monday', '--all'); 37 my $lastrev = <$fh>; chomp $lastrev; 38 $repo->command_close_pipe($fh, $c); 39 40 my $lastrev = $repo->command_oneline( [ 'rev-list', '--all' ], 41 STDERR => 0 ); 42 43 my $sha1 = $repo->hash_and_insert_object('file.txt'); 44 my $tempfile = tempfile(); 45 my $size = $repo->cat_blob($sha1, $tempfile); 46 47=cut 48 49 50require Exporter; 51 52@ISA=qw(Exporter); 53 54@EXPORT=qw(git_cmd_try); 55 56# Methods which can be called as standalone functions as well: 57@EXPORT_OK=qw(command command_oneline command_noisy 58 command_output_pipe command_input_pipe command_close_pipe 59 command_bidi_pipe command_close_bidi_pipe 60 version exec_path html_path hash_object git_cmd_try 61 remote_refs prompt 62 credential credential_read credential_write 63 temp_acquire temp_release temp_reset temp_path); 64 65 66=head1 DESCRIPTION 67 68This module provides Perl scripts easy way to interface the Git version control 69system. The modules have an easy and well-tested way to call arbitrary Git 70commands; in the future, the interface will also provide specialized methods 71for doing easily operations which are not totally trivial to do over 72the generic command interface. 73 74While some commands can be executed outside of any context (e.g. 'version' 75or 'init'), most operations require a repository context, which in practice 76means getting an instance of the Git object using the repository() constructor. 77(In the future, we will also get a new_repository() constructor.) All commands 78called as methods of the object are then executed in the context of the 79repository. 80 81Part of the "repository state" is also information about path to the attached 82working copy (unless you work with a bare repository). You can also navigate 83inside of the working copy using the C<wc_chdir()> method. (Note that 84the repository object is self-contained and will not change working directory 85of your process.) 86 87TODO: In the future, we might also do 88 89 my $remoterepo = $repo->remote_repository (Name => 'cogito', Branch => 'master'); 90 $remoterepo ||= Git->remote_repository ('http://git.or.cz/cogito.git/'); 91 my @refs = $remoterepo->refs(); 92 93Currently, the module merely wraps calls to external Git tools. In the future, 94it will provide a much faster way to interact with Git by linking directly 95to libgit. This should be completely opaque to the user, though (performance 96increase notwithstanding). 97 98=cut 99 100 101use Carp qw(carp croak);# but croak is bad - throw instead 102use Error qw(:try); 103use Cwd qw(abs_path cwd); 104use IPC::Open2 qw(open2); 105use Fcntl qw(SEEK_SET SEEK_CUR); 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 { 156my$class=shift; 157my@args=@_; 158my%opts= (); 159my$self; 160 161if(defined$args[0]) { 162if($#args%2!=1) { 163# Not a hash. 164$#args==0or throw Error::Simple("bad usage"); 165%opts= ( Directory =>$args[0] ); 166}else{ 167%opts=@args; 168} 169} 170 171if(not defined$opts{Repository}and not defined$opts{WorkingCopy} 172and not defined$opts{Directory}) { 173$opts{Directory} ='.'; 174} 175 176if(defined$opts{Directory}) { 177-d $opts{Directory}or throw Error::Simple("Directory not found:$opts{Directory}$!"); 178 179my$search= Git->repository(WorkingCopy =>$opts{Directory}); 180my$dir; 181try{ 182$dir=$search->command_oneline(['rev-parse','--git-dir'], 183 STDERR =>0); 184} catch Git::Error::Command with { 185$dir=undef; 186}; 187 188if($dir) { 189$dir=~ m#^/# or $dir = $opts{Directory} . '/' . $dir; 190$opts{Repository} = abs_path($dir); 191 192# If --git-dir went ok, this shouldn't die either. 193my$prefix=$search->command_oneline('rev-parse','--show-prefix'); 194$dir= abs_path($opts{Directory}) .'/'; 195if($prefix) { 196if(substr($dir, -length($prefix))ne$prefix) { 197 throw Error::Simple("rev-parse confused me -$dirdoes not have trailing$prefix"); 198} 199substr($dir, -length($prefix)) =''; 200} 201$opts{WorkingCopy} =$dir; 202$opts{WorkingSubdir} =$prefix; 203 204}else{ 205# A bare repository? Let's see... 206$dir=$opts{Directory}; 207 208unless(-d "$dir/refs"and-d "$dir/objects"and-e "$dir/HEAD") { 209# Mimic git-rev-parse --git-dir error message: 210 throw Error::Simple("fatal: Not a git repository:$dir"); 211} 212my$search= Git->repository(Repository =>$dir); 213try{ 214$search->command('symbolic-ref','HEAD'); 215} catch Git::Error::Command with { 216# Mimic git-rev-parse --git-dir error message: 217 throw Error::Simple("fatal: Not a git repository:$dir"); 218} 219 220$opts{Repository} = abs_path($dir); 221} 222 223delete$opts{Directory}; 224} 225 226$self= { opts => \%opts}; 227bless$self,$class; 228} 229 230=back 231 232=head1 METHODS 233 234=over 4 235 236=item command ( COMMAND [, ARGUMENTS... ] ) 237 238=item command ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } ) 239 240Execute the given Git C<COMMAND> (specify it without the 'git-' 241prefix), optionally with the specified extra C<ARGUMENTS>. 242 243The second more elaborate form can be used if you want to further adjust 244the command execution. Currently, only one option is supported: 245 246B<STDERR> - How to deal with the command's error output. By default (C<undef>) 247it is delivered to the caller's C<STDERR>. A false value (0 or '') will cause 248it to be thrown away. If you want to process it, you can get it in a filehandle 249you specify, but you must be extremely careful; if the error output is not 250very short and you want to read it in the same process as where you called 251C<command()>, you are set up for a nice deadlock! 252 253The method can be called without any instance or on a specified Git repository 254(in that case the command will be run in the repository context). 255 256In scalar context, it returns all the command output in a single string 257(verbatim). 258 259In array context, it returns an array containing lines printed to the 260command's stdout (without trailing newlines). 261 262In both cases, the command's stdin and stderr are the same as the caller's. 263 264=cut 265 266sub command { 267my($fh,$ctx) = command_output_pipe(@_); 268 269if(not defined wantarray) { 270# Nothing to pepper the possible exception with. 271 _cmd_close($ctx,$fh); 272 273}elsif(not wantarray) { 274local$/; 275my$text= <$fh>; 276try{ 277 _cmd_close($ctx,$fh); 278} catch Git::Error::Command with { 279# Pepper with the output: 280my$E=shift; 281$E->{'-outputref'} = \$text; 282 throw $E; 283}; 284return$text; 285 286}else{ 287my@lines= <$fh>; 288defined and chompfor@lines; 289try{ 290 _cmd_close($ctx,$fh); 291} catch Git::Error::Command with { 292my$E=shift; 293$E->{'-outputref'} = \@lines; 294 throw $E; 295}; 296return@lines; 297} 298} 299 300 301=item command_oneline ( COMMAND [, ARGUMENTS... ] ) 302 303=item command_oneline ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } ) 304 305Execute the given C<COMMAND> in the same way as command() 306does but always return a scalar string containing the first line 307of the command's standard output. 308 309=cut 310 311sub command_oneline { 312my($fh,$ctx) = command_output_pipe(@_); 313 314my$line= <$fh>; 315defined$lineand chomp$line; 316try{ 317 _cmd_close($ctx,$fh); 318} catch Git::Error::Command with { 319# Pepper with the output: 320my$E=shift; 321$E->{'-outputref'} = \$line; 322 throw $E; 323}; 324return$line; 325} 326 327 328=item command_output_pipe ( COMMAND [, ARGUMENTS... ] ) 329 330=item command_output_pipe ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } ) 331 332Execute the given C<COMMAND> in the same way as command() 333does but return a pipe filehandle from which the command output can be 334read. 335 336The function can return C<($pipe, $ctx)> in array context. 337See C<command_close_pipe()> for details. 338 339=cut 340 341sub command_output_pipe { 342 _command_common_pipe('-|',@_); 343} 344 345 346=item command_input_pipe ( COMMAND [, ARGUMENTS... ] ) 347 348=item command_input_pipe ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } ) 349 350Execute the given C<COMMAND> in the same way as command_output_pipe() 351does but return an input pipe filehandle instead; the command output 352is not captured. 353 354The function can return C<($pipe, $ctx)> in array context. 355See C<command_close_pipe()> for details. 356 357=cut 358 359sub command_input_pipe { 360 _command_common_pipe('|-',@_); 361} 362 363 364=item command_close_pipe ( PIPE [, CTX ] ) 365 366Close the C<PIPE> as returned from C<command_*_pipe()>, checking 367whether the command finished successfully. The optional C<CTX> argument 368is required if you want to see the command name in the error message, 369and it is the second value returned by C<command_*_pipe()> when 370called in array context. The call idiom is: 371 372 my ($fh, $ctx) = $r->command_output_pipe('status'); 373 while (<$fh>) { ... } 374 $r->command_close_pipe($fh, $ctx); 375 376Note that you should not rely on whatever actually is in C<CTX>; 377currently it is simply the command name but in future the context might 378have more complicated structure. 379 380=cut 381 382sub command_close_pipe { 383my($self,$fh,$ctx) = _maybe_self(@_); 384$ctx||='<unknown>'; 385 _cmd_close($ctx,$fh); 386} 387 388=item command_bidi_pipe ( COMMAND [, ARGUMENTS... ] ) 389 390Execute the given C<COMMAND> in the same way as command_output_pipe() 391does but return both an input pipe filehandle and an output pipe filehandle. 392 393The function will return return C<($pid, $pipe_in, $pipe_out, $ctx)>. 394See C<command_close_bidi_pipe()> for details. 395 396=cut 397 398sub command_bidi_pipe { 399my($pid,$in,$out); 400my($self) = _maybe_self(@_); 401local%ENV=%ENV; 402my$cwd_save=undef; 403if($self) { 404shift; 405$cwd_save= cwd(); 406 _setup_git_cmd_env($self); 407} 408$pid= open2($in,$out,'git',@_); 409chdir($cwd_save)if$cwd_save; 410return($pid,$in,$out,join(' ',@_)); 411} 412 413=item command_close_bidi_pipe ( PID, PIPE_IN, PIPE_OUT [, CTX] ) 414 415Close the C<PIPE_IN> and C<PIPE_OUT> as returned from C<command_bidi_pipe()>, 416checking whether the command finished successfully. The optional C<CTX> 417argument is required if you want to see the command name in the error message, 418and it is the fourth value returned by C<command_bidi_pipe()>. The call idiom 419is: 420 421 my ($pid, $in, $out, $ctx) = $r->command_bidi_pipe('cat-file --batch-check'); 422 print $out "000000000\n"; 423 while (<$in>) { ... } 424 $r->command_close_bidi_pipe($pid, $in, $out, $ctx); 425 426Note that you should not rely on whatever actually is in C<CTX>; 427currently it is simply the command name but in future the context might 428have more complicated structure. 429 430C<PIPE_IN> and C<PIPE_OUT> may be C<undef> if they have been closed prior to 431calling this function. This may be useful in a query-response type of 432commands where caller first writes a query and later reads response, eg: 433 434 my ($pid, $in, $out, $ctx) = $r->command_bidi_pipe('cat-file --batch-check'); 435 print $out "000000000\n"; 436 close $out; 437 while (<$in>) { ... } 438 $r->command_close_bidi_pipe($pid, $in, undef, $ctx); 439 440This idiom may prevent potential dead locks caused by data sent to the output 441pipe not being flushed and thus not reaching the executed command. 442 443=cut 444 445sub command_close_bidi_pipe { 446local$?; 447my($self,$pid,$in,$out,$ctx) = _maybe_self(@_); 448 _cmd_close($ctx, (grep{defined} ($in,$out))); 449waitpid$pid,0; 450if($?>>8) { 451 throw Git::Error::Command($ctx,$?>>8); 452} 453} 454 455 456=item command_noisy ( COMMAND [, ARGUMENTS... ] ) 457 458Execute the given C<COMMAND> in the same way as command() does but do not 459capture the command output - the standard output is not redirected and goes 460to the standard output of the caller application. 461 462While the method is called command_noisy(), you might want to as well use 463it for the most silent Git commands which you know will never pollute your 464stdout but you want to avoid the overhead of the pipe setup when calling them. 465 466The function returns only after the command has finished running. 467 468=cut 469 470sub command_noisy { 471my($self,$cmd,@args) = _maybe_self(@_); 472 _check_valid_cmd($cmd); 473 474my$pid=fork; 475if(not defined$pid) { 476 throw Error::Simple("fork failed:$!"); 477}elsif($pid==0) { 478 _cmd_exec($self,$cmd,@args); 479} 480if(waitpid($pid,0) >0and$?>>8!=0) { 481 throw Git::Error::Command(join(' ',$cmd,@args),$?>>8); 482} 483} 484 485 486=item version () 487 488Return the Git version in use. 489 490=cut 491 492sub version { 493my$verstr= command_oneline('--version'); 494$verstr=~s/^git version //; 495$verstr; 496} 497 498 499=item exec_path () 500 501Return path to the Git sub-command executables (the same as 502C<git --exec-path>). Useful mostly only internally. 503 504=cut 505 506sub exec_path { command_oneline('--exec-path') } 507 508 509=item html_path () 510 511Return path to the Git html documentation (the same as 512C<git --html-path>). Useful mostly only internally. 513 514=cut 515 516sub html_path { command_oneline('--html-path') } 517 518=item prompt ( PROMPT , ISPASSWORD ) 519 520Query user C<PROMPT> and return answer from user. 521 522Honours GIT_ASKPASS and SSH_ASKPASS environment variables for querying 523the user. If no *_ASKPASS variable is set or an error occoured, 524the terminal is tried as a fallback. 525If C<ISPASSWORD> is set and true, the terminal disables echo. 526 527=cut 528 529sub prompt { 530my($prompt,$isPassword) =@_; 531my$ret; 532if(exists$ENV{'GIT_ASKPASS'}) { 533$ret= _prompt($ENV{'GIT_ASKPASS'},$prompt); 534} 535if(!defined$ret&&exists$ENV{'SSH_ASKPASS'}) { 536$ret= _prompt($ENV{'SSH_ASKPASS'},$prompt); 537} 538if(!defined$ret) { 539print STDERR $prompt; 540 STDERR->flush; 541if(defined$isPassword&&$isPassword) { 542require Term::ReadKey; 543 Term::ReadKey::ReadMode('noecho'); 544$ret=''; 545while(defined(my$key= Term::ReadKey::ReadKey(0))) { 546last if$key=~/[\012\015]/;# \n\r 547$ret.=$key; 548} 549 Term::ReadKey::ReadMode('restore'); 550print STDERR "\n"; 551 STDERR->flush; 552}else{ 553chomp($ret= <STDIN>); 554} 555} 556return$ret; 557} 558 559sub _prompt { 560my($askpass,$prompt) =@_; 561return unlesslength$askpass; 562$prompt=~s/\n/ /g; 563my$ret; 564open my$fh,"-|",$askpass,$promptorreturn; 565$ret= <$fh>; 566$ret=~s/[\015\012]//g;# strip \r\n, chomp does not work on all systems (i.e. windows) as expected 567close($fh); 568return$ret; 569} 570 571=item repo_path () 572 573Return path to the git repository. Must be called on a repository instance. 574 575=cut 576 577sub repo_path {$_[0]->{opts}->{Repository} } 578 579 580=item wc_path () 581 582Return path to the working copy. Must be called on a repository instance. 583 584=cut 585 586sub wc_path {$_[0]->{opts}->{WorkingCopy} } 587 588 589=item wc_subdir () 590 591Return path to the subdirectory inside of a working copy. Must be called 592on a repository instance. 593 594=cut 595 596sub wc_subdir {$_[0]->{opts}->{WorkingSubdir} ||=''} 597 598 599=item wc_chdir ( SUBDIR ) 600 601Change the working copy subdirectory to work within. The C<SUBDIR> is 602relative to the working copy root directory (not the current subdirectory). 603Must be called on a repository instance attached to a working copy 604and the directory must exist. 605 606=cut 607 608sub wc_chdir { 609my($self,$subdir) =@_; 610$self->wc_path() 611or throw Error::Simple("bare repository"); 612 613-d $self->wc_path().'/'.$subdir 614or throw Error::Simple("subdir not found:$subdir$!"); 615# Of course we will not "hold" the subdirectory so anyone 616# can delete it now and we will never know. But at least we tried. 617 618$self->{opts}->{WorkingSubdir} =$subdir; 619} 620 621 622=item config ( VARIABLE ) 623 624Retrieve the configuration C<VARIABLE> in the same manner as C<config> 625does. In scalar context requires the variable to be set only one time 626(exception is thrown otherwise), in array context returns allows the 627variable to be set multiple times and returns all the values. 628 629=cut 630 631sub config { 632return _config_common({},@_); 633} 634 635 636=item config_bool ( VARIABLE ) 637 638Retrieve the bool configuration C<VARIABLE>. The return value 639is usable as a boolean in perl (and C<undef> if it's not defined, 640of course). 641 642=cut 643 644sub config_bool { 645my$val=scalar _config_common({'kind'=>'--bool'},@_); 646 647# Do not rewrite this as return (defined $val && $val eq 'true') 648# as some callers do care what kind of falsehood they receive. 649if(!defined$val) { 650returnundef; 651}else{ 652return$valeq'true'; 653} 654} 655 656 657=item config_path ( VARIABLE ) 658 659Retrieve the path configuration C<VARIABLE>. The return value 660is an expanded path or C<undef> if it's not defined. 661 662=cut 663 664sub config_path { 665return _config_common({'kind'=>'--path'},@_); 666} 667 668 669=item config_int ( VARIABLE ) 670 671Retrieve the integer configuration C<VARIABLE>. The return value 672is simple decimal number. An optional value suffix of 'k', 'm', 673or 'g' in the config file will cause the value to be multiplied 674by 1024, 1048576 (1024^2), or 1073741824 (1024^3) prior to output. 675It would return C<undef> if configuration variable is not defined, 676 677=cut 678 679sub config_int { 680returnscalar _config_common({'kind'=>'--int'},@_); 681} 682 683# Common subroutine to implement bulk of what the config* family of methods 684# do. This curently wraps command('config') so it is not so fast. 685sub _config_common { 686my($opts) =shift@_; 687my($self,$var) = _maybe_self(@_); 688 689try{ 690my@cmd= ('config',$opts->{'kind'} ?$opts->{'kind'} : ()); 691unshift@cmd,$selfif$self; 692if(wantarray) { 693return command(@cmd,'--get-all',$var); 694}else{ 695return command_oneline(@cmd,'--get',$var); 696} 697} catch Git::Error::Command with { 698my$E=shift; 699if($E->value() ==1) { 700# Key not found. 701return; 702}else{ 703 throw $E; 704} 705}; 706} 707 708=item get_colorbool ( NAME ) 709 710Finds if color should be used for NAMEd operation from the configuration, 711and returns boolean (true for "use color", false for "do not use color"). 712 713=cut 714 715sub get_colorbool { 716my($self,$var) =@_; 717my$stdout_to_tty= (-t STDOUT) ?"true":"false"; 718my$use_color=$self->command_oneline('config','--get-colorbool', 719$var,$stdout_to_tty); 720return($use_coloreq'true'); 721} 722 723=item get_color ( SLOT, COLOR ) 724 725Finds color for SLOT from the configuration, while defaulting to COLOR, 726and returns the ANSI color escape sequence: 727 728 print $repo->get_color("color.interactive.prompt", "underline blue white"); 729 print "some text"; 730 print $repo->get_color("", "normal"); 731 732=cut 733 734sub get_color { 735my($self,$slot,$default) =@_; 736my$color=$self->command_oneline('config','--get-color',$slot,$default); 737if(!defined$color) { 738$color=""; 739} 740return$color; 741} 742 743=item remote_refs ( REPOSITORY [, GROUPS [, REFGLOBS ] ] ) 744 745This function returns a hashref of refs stored in a given remote repository. 746The hash is in the format C<refname =\> hash>. For tags, the C<refname> entry 747contains the tag object while a C<refname^{}> entry gives the tagged objects. 748 749C<REPOSITORY> has the same meaning as the appropriate C<git-ls-remote> 750argument; either a URL or a remote name (if called on a repository instance). 751C<GROUPS> is an optional arrayref that can contain 'tags' to return all the 752tags and/or 'heads' to return all the heads. C<REFGLOB> is an optional array 753of strings containing a shell-like glob to further limit the refs returned in 754the hash; the meaning is again the same as the appropriate C<git-ls-remote> 755argument. 756 757This function may or may not be called on a repository instance. In the former 758case, remote names as defined in the repository are recognized as repository 759specifiers. 760 761=cut 762 763sub remote_refs { 764my($self,$repo,$groups,$refglobs) = _maybe_self(@_); 765my@args; 766if(ref$groupseq'ARRAY') { 767foreach(@$groups) { 768if($_eq'heads') { 769push(@args,'--heads'); 770}elsif($_eq'tags') { 771push(@args,'--tags'); 772}else{ 773# Ignore unknown groups for future 774# compatibility 775} 776} 777} 778push(@args,$repo); 779if(ref$refglobseq'ARRAY') { 780push(@args,@$refglobs); 781} 782 783my@self=$self? ($self) : ();# Ultra trickery 784my($fh,$ctx) = Git::command_output_pipe(@self,'ls-remote',@args); 785my%refs; 786while(<$fh>) { 787chomp; 788my($hash,$ref) =split(/\t/,$_,2); 789$refs{$ref} =$hash; 790} 791 Git::command_close_pipe(@self,$fh,$ctx); 792return \%refs; 793} 794 795 796=item ident ( TYPE | IDENTSTR ) 797 798=item ident_person ( TYPE | IDENTSTR | IDENTARRAY ) 799 800This suite of functions retrieves and parses ident information, as stored 801in the commit and tag objects or produced by C<var GIT_type_IDENT> (thus 802C<TYPE> can be either I<author> or I<committer>; case is insignificant). 803 804The C<ident> method retrieves the ident information from C<git var> 805and either returns it as a scalar string or as an array with the fields parsed. 806Alternatively, it can take a prepared ident string (e.g. from the commit 807object) and just parse it. 808 809C<ident_person> returns the person part of the ident - name and email; 810it can take the same arguments as C<ident> or the array returned by C<ident>. 811 812The synopsis is like: 813 814 my ($name, $email, $time_tz) = ident('author'); 815 "$name <$email>" eq ident_person('author'); 816 "$name <$email>" eq ident_person($name); 817 $time_tz =~ /^\d+ [+-]\d{4}$/; 818 819=cut 820 821sub ident { 822my($self,$type) = _maybe_self(@_); 823my$identstr; 824if(lc$typeeq lc'committer'or lc$typeeq lc'author') { 825my@cmd= ('var','GIT_'.uc($type).'_IDENT'); 826unshift@cmd,$selfif$self; 827$identstr= command_oneline(@cmd); 828}else{ 829$identstr=$type; 830} 831if(wantarray) { 832return$identstr=~/^(.*) <(.*)> (\d+ [+-]\d{4})$/; 833}else{ 834return$identstr; 835} 836} 837 838sub ident_person { 839my($self,@ident) = _maybe_self(@_); 840$#ident==0and@ident=$self?$self->ident($ident[0]) : ident($ident[0]); 841return"$ident[0] <$ident[1]>"; 842} 843 844 845=item hash_object ( TYPE, FILENAME ) 846 847Compute the SHA1 object id of the given C<FILENAME> considering it is 848of the C<TYPE> object type (C<blob>, C<commit>, C<tree>). 849 850The method can be called without any instance or on a specified Git repository, 851it makes zero difference. 852 853The function returns the SHA1 hash. 854 855=cut 856 857# TODO: Support for passing FILEHANDLE instead of FILENAME 858sub hash_object { 859my($self,$type,$file) = _maybe_self(@_); 860 command_oneline('hash-object','-t',$type,$file); 861} 862 863 864=item hash_and_insert_object ( FILENAME ) 865 866Compute the SHA1 object id of the given C<FILENAME> and add the object to the 867object database. 868 869The function returns the SHA1 hash. 870 871=cut 872 873# TODO: Support for passing FILEHANDLE instead of FILENAME 874sub hash_and_insert_object { 875my($self,$filename) =@_; 876 877 carp "Bad filename\"$filename\""if$filename=~/[\r\n]/; 878 879$self->_open_hash_and_insert_object_if_needed(); 880my($in,$out) = ($self->{hash_object_in},$self->{hash_object_out}); 881 882unless(print$out $filename,"\n") { 883$self->_close_hash_and_insert_object(); 884 throw Error::Simple("out pipe went bad"); 885} 886 887chomp(my$hash= <$in>); 888unless(defined($hash)) { 889$self->_close_hash_and_insert_object(); 890 throw Error::Simple("in pipe went bad"); 891} 892 893return$hash; 894} 895 896sub _open_hash_and_insert_object_if_needed { 897my($self) =@_; 898 899return ifdefined($self->{hash_object_pid}); 900 901($self->{hash_object_pid},$self->{hash_object_in}, 902$self->{hash_object_out},$self->{hash_object_ctx}) = 903$self->command_bidi_pipe(qw(hash-object -w --stdin-paths --no-filters)); 904} 905 906sub _close_hash_and_insert_object { 907my($self) =@_; 908 909return unlessdefined($self->{hash_object_pid}); 910 911my@vars=map{'hash_object_'.$_}qw(pid in out ctx); 912 913 command_close_bidi_pipe(@$self{@vars}); 914delete@$self{@vars}; 915} 916 917=item cat_blob ( SHA1, FILEHANDLE ) 918 919Prints the contents of the blob identified by C<SHA1> to C<FILEHANDLE> and 920returns the number of bytes printed. 921 922=cut 923 924sub cat_blob { 925my($self,$sha1,$fh) =@_; 926 927$self->_open_cat_blob_if_needed(); 928my($in,$out) = ($self->{cat_blob_in},$self->{cat_blob_out}); 929 930unless(print$out $sha1,"\n") { 931$self->_close_cat_blob(); 932 throw Error::Simple("out pipe went bad"); 933} 934 935my$description= <$in>; 936if($description=~/ missing$/) { 937 carp "$sha1doesn't exist in the repository"; 938return-1; 939} 940 941if($description!~/^[0-9a-fA-F]{40} \S+ (\d+)$/) { 942 carp "Unexpected result returned from git cat-file"; 943return-1; 944} 945 946my$size=$1; 947 948my$blob; 949my$bytesRead=0; 950 951while(1) { 952my$bytesLeft=$size-$bytesRead; 953last unless$bytesLeft; 954 955my$bytesToRead=$bytesLeft<1024?$bytesLeft:1024; 956my$read=read($in,$blob,$bytesToRead,$bytesRead); 957unless(defined($read)) { 958$self->_close_cat_blob(); 959 throw Error::Simple("in pipe went bad"); 960} 961 962$bytesRead+=$read; 963} 964 965# Skip past the trailing newline. 966my$newline; 967my$read=read($in,$newline,1); 968unless(defined($read)) { 969$self->_close_cat_blob(); 970 throw Error::Simple("in pipe went bad"); 971} 972unless($read==1&&$newlineeq"\n") { 973$self->_close_cat_blob(); 974 throw Error::Simple("didn't find newline after blob"); 975} 976 977unless(print$fh $blob) { 978$self->_close_cat_blob(); 979 throw Error::Simple("couldn't write to passed in filehandle"); 980} 981 982return$size; 983} 984 985sub _open_cat_blob_if_needed { 986my($self) =@_; 987 988return ifdefined($self->{cat_blob_pid}); 989 990($self->{cat_blob_pid},$self->{cat_blob_in}, 991$self->{cat_blob_out},$self->{cat_blob_ctx}) = 992$self->command_bidi_pipe(qw(cat-file --batch)); 993} 994 995sub _close_cat_blob { 996my($self) =@_; 997 998return unlessdefined($self->{cat_blob_pid}); 9991000my@vars=map{'cat_blob_'.$_}qw(pid in out ctx);10011002 command_close_bidi_pipe(@$self{@vars});1003delete@$self{@vars};1004}100510061007=item credential_read( FILEHANDLE )10081009Reads credential key-value pairs from C<FILEHANDLE>. Reading stops at EOF or1010when an empty line is encountered. Each line must be of the form C<key=value>1011with a non-empty key. Function returns hash with all read values. Any white1012space (other than new-line character) is preserved.10131014=cut10151016sub credential_read {1017my($self,$reader) = _maybe_self(@_);1018my%credential;1019while(<$reader>) {1020chomp;1021if($_eq'') {1022last;1023}elsif(!/^([^=]+)=(.*)$/) {1024 throw Error::Simple("unable to parse git credential data:\n$_");1025}1026$credential{$1} =$2;1027}1028return%credential;1029}10301031=item credential_write( FILEHANDLE, CREDENTIAL_HASHREF )10321033Writes credential key-value pairs from hash referenced by1034C<CREDENTIAL_HASHREF> to C<FILEHANDLE>. Keys and values cannot contain1035new-lines or NUL bytes characters, and key cannot contain equal signs nor be1036empty (if they do Error::Simple is thrown). Any white space is preserved. If1037value for a key is C<undef>, it will be skipped.10381039If C<'url'> key exists it will be written first. (All the other key-value1040pairs are written in sorted order but you should not depend on that). Once1041all lines are written, an empty line is printed.10421043=cut10441045sub credential_write {1046my($self,$writer,$credential) = _maybe_self(@_);1047my($key,$value);10481049# Check if $credential is valid prior to writing anything1050while(($key,$value) =each%$credential) {1051if(!defined$key|| !length$key) {1052 throw Error::Simple("credential key empty or undefined");1053}elsif($key=~/[=\n\0]/) {1054 throw Error::Simple("credential key contains invalid characters:$key");1055}elsif(defined$value&&$value=~/[\n\0]/) {1056 throw Error::Simple("credential value for key=$keycontains invalid characters:$value");1057}1058}10591060for$key(sort{1061# url overwrites other fields, so it must come first1062return-1if$aeq'url';1063return1if$beq'url';1064return$acmp$b;1065}keys%$credential) {1066if(defined$credential->{$key}) {1067print$writer $key,'=',$credential->{$key},"\n";1068}1069}1070print$writer"\n";1071}10721073sub _credential_run {1074my($self,$credential,$op) = _maybe_self(@_);1075my($pid,$reader,$writer,$ctx) = command_bidi_pipe('credential',$op);10761077 credential_write $writer,$credential;1078close$writer;10791080if($opeq"fill") {1081%$credential= credential_read $reader;1082}1083if(<$reader>) {1084 throw Error::Simple("unexpected output from git credential$opresponse:\n$_\n");1085}10861087 command_close_bidi_pipe($pid,$reader,undef,$ctx);1088}10891090=item credential( CREDENTIAL_HASHREF [, OPERATION ] )10911092=item credential( CREDENTIAL_HASHREF, CODE )10931094Executes C<git credential> for a given set of credentials and specified1095operation. In both forms C<CREDENTIAL_HASHREF> needs to be a reference to1096a hash which stores credentials. Under certain conditions the hash can1097change.10981099In the first form, C<OPERATION> can be C<'fill'>, C<'approve'> or C<'reject'>,1100and function will execute corresponding C<git credential> sub-command. If1101it's omitted C<'fill'> is assumed. In case of C<'fill'> the values stored in1102C<CREDENTIAL_HASHREF> will be changed to the ones returned by the C<git1103credential fill> command. The usual usage would look something like:11041105 my %cred = (1106 'protocol' => 'https',1107 'host' => 'example.com',1108 'username' => 'bob'1109 );1110 Git::credential \%cred;1111 if (try_to_authenticate($cred{'username'}, $cred{'password'})) {1112 Git::credential \%cred, 'approve';1113 ... do more stuff ...1114 } else {1115 Git::credential \%cred, 'reject';1116 }11171118In the second form, C<CODE> needs to be a reference to a subroutine. The1119function will execute C<git credential fill> to fill the provided credential1120hash, then call C<CODE> with C<CREDENTIAL_HASHREF> as the sole argument. If1121C<CODE>'s return value is defined, the function will execute C<git credential1122approve> (if return value yields true) or C<git credential reject> (if return1123value is false). If the return value is undef, nothing at all is executed;1124this is useful, for example, if the credential could neither be verified nor1125rejected due to an unrelated network error. The return value is the same as1126what C<CODE> returns. With this form, the usage might look as follows:11271128 if (Git::credential {1129 'protocol' => 'https',1130 'host' => 'example.com',1131 'username' => 'bob'1132 }, sub {1133 my $cred = shift;1134 return !!try_to_authenticate($cred->{'username'},1135 $cred->{'password'});1136 }) {1137 ... do more stuff ...1138 }11391140=cut11411142sub credential {1143my($self,$credential,$op_or_code) = (_maybe_self(@_),'fill');11441145if('CODE'eq ref$op_or_code) {1146 _credential_run $credential,'fill';1147my$ret=$op_or_code->($credential);1148if(defined$ret) {1149 _credential_run $credential,$ret?'approve':'reject';1150}1151return$ret;1152}else{1153 _credential_run $credential,$op_or_code;1154}1155}11561157{# %TEMP_* Lexical Context11581159my(%TEMP_FILEMAP,%TEMP_FILES);11601161=item temp_acquire ( NAME )11621163Attempts to retreive the temporary file mapped to the string C<NAME>. If an1164associated temp file has not been created this session or was closed, it is1165created, cached, and set for autoflush and binmode.11661167Internally locks the file mapped to C<NAME>. This lock must be released with1168C<temp_release()> when the temp file is no longer needed. Subsequent attempts1169to retrieve temporary files mapped to the same C<NAME> while still locked will1170cause an error. This locking mechanism provides a weak guarantee and is not1171threadsafe. It does provide some error checking to help prevent temp file refs1172writing over one another.11731174In general, the L<File::Handle> returned should not be closed by consumers as1175it defeats the purpose of this caching mechanism. If you need to close the temp1176file handle, then you should use L<File::Temp> or another temp file faculty1177directly. If a handle is closed and then requested again, then a warning will1178issue.11791180=cut11811182sub temp_acquire {1183my$temp_fd= _temp_cache(@_);11841185$TEMP_FILES{$temp_fd}{locked} =1;1186$temp_fd;1187}11881189=item temp_release ( NAME )11901191=item temp_release ( FILEHANDLE )11921193Releases a lock acquired through C<temp_acquire()>. Can be called either with1194the C<NAME> mapping used when acquiring the temp file or with the C<FILEHANDLE>1195referencing a locked temp file.11961197Warns if an attempt is made to release a file that is not locked.11981199The temp file will be truncated before being released. This can help to reduce1200disk I/O where the system is smart enough to detect the truncation while data1201is in the output buffers. Beware that after the temp file is released and1202truncated, any operations on that file may fail miserably until it is1203re-acquired. All contents are lost between each release and acquire mapped to1204the same string.12051206=cut12071208sub temp_release {1209my($self,$temp_fd,$trunc) = _maybe_self(@_);12101211if(exists$TEMP_FILEMAP{$temp_fd}) {1212$temp_fd=$TEMP_FILES{$temp_fd};1213}1214unless($TEMP_FILES{$temp_fd}{locked}) {1215 carp "Attempt to release temp file '",1216$temp_fd,"' that has not been locked";1217}1218 temp_reset($temp_fd)if$truncand$temp_fd->opened;12191220$TEMP_FILES{$temp_fd}{locked} =0;1221undef;1222}12231224sub _temp_cache {1225my($self,$name) = _maybe_self(@_);12261227 _verify_require();12281229my$temp_fd= \$TEMP_FILEMAP{$name};1230if(defined$$temp_fdand$$temp_fd->opened) {1231if($TEMP_FILES{$$temp_fd}{locked}) {1232 throw Error::Simple("Temp file with moniker '".1233$name."' already in use");1234}1235}else{1236if(defined$$temp_fd) {1237# then we're here because of a closed handle.1238 carp "Temp file '",$name,1239"' was closed. Opening replacement.";1240}1241my$fname;12421243my$tmpdir;1244if(defined$self) {1245$tmpdir=$self->repo_path();1246}12471248($$temp_fd,$fname) = File::Temp->tempfile(1249'Git_XXXXXX', UNLINK =>1, DIR =>$tmpdir,1250)or throw Error::Simple("couldn't open new temp file");12511252$$temp_fd->autoflush;1253binmode$$temp_fd;1254$TEMP_FILES{$$temp_fd}{fname} =$fname;1255}1256$$temp_fd;1257}12581259sub _verify_require {1260eval{require File::Temp;require File::Spec; };1261$@and throw Error::Simple($@);1262}12631264=item temp_reset ( FILEHANDLE )12651266Truncates and resets the position of the C<FILEHANDLE>.12671268=cut12691270sub temp_reset {1271my($self,$temp_fd) = _maybe_self(@_);12721273truncate$temp_fd,01274or throw Error::Simple("couldn't truncate file");1275sysseek($temp_fd,0, SEEK_SET)and seek($temp_fd,0, SEEK_SET)1276or throw Error::Simple("couldn't seek to beginning of file");1277sysseek($temp_fd,0, SEEK_CUR) ==0and tell($temp_fd) ==01278or throw Error::Simple("expected file position to be reset");1279}12801281=item temp_path ( NAME )12821283=item temp_path ( FILEHANDLE )12841285Returns the filename associated with the given tempfile.12861287=cut12881289sub temp_path {1290my($self,$temp_fd) = _maybe_self(@_);12911292if(exists$TEMP_FILEMAP{$temp_fd}) {1293$temp_fd=$TEMP_FILEMAP{$temp_fd};1294}1295$TEMP_FILES{$temp_fd}{fname};1296}12971298sub END{1299unlink values%TEMP_FILEMAPif%TEMP_FILEMAP;1300}13011302}# %TEMP_* Lexical Context13031304=back13051306=head1 ERROR HANDLING13071308All functions are supposed to throw Perl exceptions in case of errors.1309See the L<Error> module on how to catch those. Most exceptions are mere1310L<Error::Simple> instances.13111312However, the C<command()>, C<command_oneline()> and C<command_noisy()>1313functions suite can throw C<Git::Error::Command> exceptions as well: those are1314thrown when the external command returns an error code and contain the error1315code as well as access to the captured command's output. The exception class1316provides the usual C<stringify> and C<value> (command's exit code) methods and1317in addition also a C<cmd_output> method that returns either an array or a1318string with the captured command output (depending on the original function1319call context; C<command_noisy()> returns C<undef>) and $<cmdline> which1320returns the command and its arguments (but without proper quoting).13211322Note that the C<command_*_pipe()> functions cannot throw this exception since1323it has no idea whether the command failed or not. You will only find out1324at the time you C<close> the pipe; if you want to have that automated,1325use C<command_close_pipe()>, which can throw the exception.13261327=cut13281329{1330package Git::Error::Command;13311332@Git::Error::Command::ISA =qw(Error);13331334sub new {1335my$self=shift;1336my$cmdline=''.shift;1337my$value=0+shift;1338my$outputref=shift;1339my(@args) = ();13401341local$Error::Depth =$Error::Depth +1;13421343push(@args,'-cmdline',$cmdline);1344push(@args,'-value',$value);1345push(@args,'-outputref',$outputref);13461347$self->SUPER::new(-text =>'command returned error',@args);1348}13491350sub stringify {1351my$self=shift;1352my$text=$self->SUPER::stringify;1353$self->cmdline() .': '.$text.': '.$self->value() ."\n";1354}13551356sub cmdline {1357my$self=shift;1358$self->{'-cmdline'};1359}13601361sub cmd_output {1362my$self=shift;1363my$ref=$self->{'-outputref'};1364defined$refor undef;1365if(ref$refeq'ARRAY') {1366return@$ref;1367}else{# SCALAR1368return$$ref;1369}1370}1371}13721373=over 413741375=item git_cmd_try { CODE } ERRMSG13761377This magical statement will automatically catch any C<Git::Error::Command>1378exceptions thrown by C<CODE> and make your program die with C<ERRMSG>1379on its lips; the message will have %s substituted for the command line1380and %d for the exit status. This statement is useful mostly for producing1381more user-friendly error messages.13821383In case of no exception caught the statement returns C<CODE>'s return value.13841385Note that this is the only auto-exported function.13861387=cut13881389sub git_cmd_try(&$) {1390my($code,$errmsg) =@_;1391my@result;1392my$err;1393my$array=wantarray;1394try{1395if($array) {1396@result= &$code;1397}else{1398$result[0] = &$code;1399}1400} catch Git::Error::Command with {1401my$E=shift;1402$err=$errmsg;1403$err=~s/\%s/$E->cmdline()/ge;1404$err=~s/\%d/$E->value()/ge;1405# We can't croak here since Error.pm would mangle1406# that to Error::Simple.1407};1408$errand croak $err;1409return$array?@result:$result[0];1410}141114121413=back14141415=head1 COPYRIGHT14161417Copyright 2006 by Petr Baudis E<lt>pasky@suse.czE<gt>.14181419This module is free software; it may be used, copied, modified1420and distributed under the terms of the GNU General Public Licence,1421either version 2, or (at your option) any later version.14221423=cut142414251426# Take raw method argument list and return ($obj, @args) in case1427# the method was called upon an instance and (undef, @args) if1428# it was called directly.1429sub _maybe_self {1430 UNIVERSAL::isa($_[0],'Git') ?@_: (undef,@_);1431}14321433# Check if the command id is something reasonable.1434sub _check_valid_cmd {1435my($cmd) =@_;1436$cmd=~/^[a-z0-9A-Z_-]+$/or throw Error::Simple("bad command:$cmd");1437}14381439# Common backend for the pipe creators.1440sub _command_common_pipe {1441my$direction=shift;1442my($self,@p) = _maybe_self(@_);1443my(%opts,$cmd,@args);1444if(ref$p[0]) {1445($cmd,@args) = @{shift@p};1446%opts=ref$p[0] ? %{$p[0]} :@p;1447}else{1448($cmd,@args) =@p;1449}1450 _check_valid_cmd($cmd);14511452my$fh;1453if($^Oeq'MSWin32') {1454# ActiveState Perl1455#defined $opts{STDERR} and1456# warn 'ignoring STDERR option - running w/ ActiveState';1457$directioneq'-|'or1458die'input pipe for ActiveState not implemented';1459# the strange construction with *ACPIPE is just to1460# explain the tie below that we want to bind to1461# a handle class, not scalar. It is not known if1462# it is something specific to ActiveState Perl or1463# just a Perl quirk.1464 tie (*ACPIPE,'Git::activestate_pipe',$cmd,@args);1465$fh= *ACPIPE;14661467}else{1468my$pid=open($fh,$direction);1469if(not defined$pid) {1470 throw Error::Simple("open failed:$!");1471}elsif($pid==0) {1472if(defined$opts{STDERR}) {1473close STDERR;1474}1475if($opts{STDERR}) {1476open(STDERR,'>&',$opts{STDERR})1477or die"dup failed:$!";1478}1479 _cmd_exec($self,$cmd,@args);1480}1481}1482returnwantarray? ($fh,join(' ',$cmd,@args)) :$fh;1483}14841485# When already in the subprocess, set up the appropriate state1486# for the given repository and execute the git command.1487sub _cmd_exec {1488my($self,@args) =@_;1489 _setup_git_cmd_env($self);1490 _execv_git_cmd(@args);1491dieqq[exec "@args" failed:$!];1492}14931494# set up the appropriate state for git command1495sub _setup_git_cmd_env {1496my$self=shift;1497if($self) {1498$self->repo_path()and$ENV{'GIT_DIR'} =$self->repo_path();1499$self->repo_path()and$self->wc_path()1500and$ENV{'GIT_WORK_TREE'} =$self->wc_path();1501$self->wc_path()and chdir($self->wc_path());1502$self->wc_subdir()and chdir($self->wc_subdir());1503}1504}15051506# Execute the given Git command ($_[0]) with arguments ($_[1..])1507# by searching for it at proper places.1508sub _execv_git_cmd {exec('git',@_); }15091510# Close pipe to a subprocess.1511sub _cmd_close {1512my$ctx=shift@_;1513foreachmy$fh(@_) {1514if(close$fh) {1515# nop1516}elsif($!) {1517# It's just close, no point in fatalities1518 carp "error closing pipe:$!";1519}elsif($?>>8) {1520# The caller should pepper this.1521 throw Git::Error::Command($ctx,$?>>8);1522}1523# else we might e.g. closed a live stream; the command1524# dying of SIGPIPE would drive us here.1525}1526}152715281529sub DESTROY {1530my($self) =@_;1531$self->_close_hash_and_insert_object();1532$self->_close_cat_blob();1533}153415351536# Pipe implementation for ActiveState Perl.15371538package Git::activestate_pipe;1539use strict;15401541sub TIEHANDLE {1542my($class,@params) =@_;1543# FIXME: This is probably horrible idea and the thing will explode1544# at the moment you give it arguments that require some quoting,1545# but I have no ActiveState clue... --pasky1546# Let's just hope ActiveState Perl does at least the quoting1547# correctly.1548my@data=qx{git@params};1549bless{ i =>0, data => \@data},$class;1550}15511552sub READLINE {1553my$self=shift;1554if($self->{i} >=scalar@{$self->{data}}) {1555returnundef;1556}1557my$i=$self->{i};1558if(wantarray) {1559$self->{i} =$#{$self->{'data'}} +1;1560returnsplice(@{$self->{'data'}},$i);1561}1562$self->{i} =$i+1;1563return$self->{'data'}->[$i];1564}15651566sub CLOSE {1567my$self=shift;1568delete$self->{data};1569delete$self->{i};1570}15711572sub EOF {1573my$self=shift;1574return($self->{i} >=scalar@{$self->{data}});1575}1576157715781;# Famous last words