diff options
Diffstat (limited to 'perl/Git.pm')
| -rw-r--r-- | perl/Git.pm | 304 |
1 files changed, 266 insertions, 38 deletions
diff --git a/perl/Git.pm b/perl/Git.pm index f7ce511bbb..7a252ef872 100644 --- a/perl/Git.pm +++ b/perl/Git.pm @@ -58,7 +58,9 @@ require Exporter; command_output_pipe command_input_pipe command_close_pipe command_bidi_pipe command_close_bidi_pipe version exec_path html_path hash_object git_cmd_try - remote_refs + remote_refs prompt + get_tz_offset + credential credential_read credential_write temp_acquire temp_release temp_reset temp_path); @@ -102,6 +104,7 @@ use Error qw(:try); use Cwd qw(abs_path cwd); use IPC::Open2 qw(open2); use Fcntl qw(SEEK_SET SEEK_CUR); +use Time::Local qw(timegm); } @@ -267,13 +270,13 @@ sub command { if (not defined wantarray) { # Nothing to pepper the possible exception with. - _cmd_close($fh, $ctx); + _cmd_close($ctx, $fh); } elsif (not wantarray) { local $/; my $text = <$fh>; try { - _cmd_close($fh, $ctx); + _cmd_close($ctx, $fh); } catch Git::Error::Command with { # Pepper with the output: my $E = shift; @@ -286,7 +289,7 @@ sub command { my @lines = <$fh>; defined and chomp for @lines; try { - _cmd_close($fh, $ctx); + _cmd_close($ctx, $fh); } catch Git::Error::Command with { my $E = shift; $E->{'-outputref'} = \@lines; @@ -313,7 +316,7 @@ sub command_oneline { my $line = <$fh>; defined $line and chomp $line; try { - _cmd_close($fh, $ctx); + _cmd_close($ctx, $fh); } catch Git::Error::Command with { # Pepper with the output: my $E = shift; @@ -381,7 +384,7 @@ have more complicated structure. sub command_close_pipe { my ($self, $fh, $ctx) = _maybe_self(@_); $ctx ||= '<unknown>'; - _cmd_close($fh, $ctx); + _cmd_close($ctx, $fh); } =item command_bidi_pipe ( COMMAND [, ARGUMENTS... ] ) @@ -418,7 +421,7 @@ and it is the fourth value returned by C<command_bidi_pipe()>. The call idiom is: my ($pid, $in, $out, $ctx) = $r->command_bidi_pipe('cat-file --batch-check'); - print "000000000\n" $out; + print $out "000000000\n"; while (<$in>) { ... } $r->command_close_bidi_pipe($pid, $in, $out, $ctx); @@ -426,23 +429,26 @@ Note that you should not rely on whatever actually is in C<CTX>; currently it is simply the command name but in future the context might have more complicated structure. +C<PIPE_IN> and C<PIPE_OUT> may be C<undef> if they have been closed prior to +calling this function. This may be useful in a query-response type of +commands where caller first writes a query and later reads response, eg: + + my ($pid, $in, $out, $ctx) = $r->command_bidi_pipe('cat-file --batch-check'); + print $out "000000000\n"; + close $out; + while (<$in>) { ... } + $r->command_close_bidi_pipe($pid, $in, undef, $ctx); + +This idiom may prevent potential dead locks caused by data sent to the output +pipe not being flushed and thus not reaching the executed command. + =cut sub command_close_bidi_pipe { local $?; - my ($pid, $in, $out, $ctx) = @_; - foreach my $fh ($in, $out) { - unless (close $fh) { - if ($!) { - carp "error closing pipe: $!"; - } elsif ($? >> 8) { - throw Git::Error::Command($ctx, $? >>8); - } - } - } - + my ($self, $pid, $in, $out, $ctx) = _maybe_self(@_); + _cmd_close($ctx, (grep { defined } ($in, $out))); waitpid $pid, 0; - if ($? >> 8) { throw Git::Error::Command($ctx, $? >>8); } @@ -512,6 +518,79 @@ C<git --html-path>). Useful mostly only internally. sub html_path { command_oneline('--html-path') } +=item get_tz_offset ( TIME ) + +Return the time zone offset from GMT in the form +/-HHMM where HH is +the number of hours from GMT and MM is the number of minutes. This is +the equivalent of what strftime("%z", ...) would provide on a GNU +platform. + +If TIME is not supplied, the current local time is used. + +=cut + +sub get_tz_offset { + # some systmes don't handle or mishandle %z, so be creative. + my $t = shift || time; + my $gm = timegm(localtime($t)); + my $sign = qw( + + - )[ $gm <=> $t ]; + return sprintf("%s%02d%02d", $sign, (gmtime(abs($t - $gm)))[2,1]); +} + + +=item prompt ( PROMPT , ISPASSWORD ) + +Query user C<PROMPT> and return answer from user. + +Honours GIT_ASKPASS and SSH_ASKPASS environment variables for querying +the user. If no *_ASKPASS variable is set or an error occoured, +the terminal is tried as a fallback. +If C<ISPASSWORD> is set and true, the terminal disables echo. + +=cut + +sub prompt { + my ($prompt, $isPassword) = @_; + my $ret; + if (exists $ENV{'GIT_ASKPASS'}) { + $ret = _prompt($ENV{'GIT_ASKPASS'}, $prompt); + } + if (!defined $ret && exists $ENV{'SSH_ASKPASS'}) { + $ret = _prompt($ENV{'SSH_ASKPASS'}, $prompt); + } + if (!defined $ret) { + print STDERR $prompt; + STDERR->flush; + if (defined $isPassword && $isPassword) { + require Term::ReadKey; + Term::ReadKey::ReadMode('noecho'); + $ret = ''; + while (defined(my $key = Term::ReadKey::ReadKey(0))) { + last if $key =~ /[\012\015]/; # \n\r + $ret .= $key; + } + Term::ReadKey::ReadMode('restore'); + print STDERR "\n"; + STDERR->flush; + } else { + chomp($ret = <STDIN>); + } + } + return $ret; +} + +sub _prompt { + my ($askpass, $prompt) = @_; + return unless length $askpass; + $prompt =~ s/\n/ /g; + my $ret; + open my $fh, "-|", $askpass, $prompt or return; + $ret = <$fh>; + $ret =~ s/[\015\012]//g; # strip \r\n, chomp does not work on all systems (i.e. windows) as expected + close ($fh); + return $ret; +} + =item repo_path () Return path to the git repository. Must be called on a repository instance. @@ -691,7 +770,7 @@ The hash is in the format C<refname =\> hash>. For tags, the C<refname> entry contains the tag object while a C<refname^{}> entry gives the tagged objects. C<REPOSITORY> has the same meaning as the appropriate C<git-ls-remote> -argument; either an URL or a remote name (if called on a repository instance). +argument; either a URL or a remote name (if called on a repository instance). C<GROUPS> is an optional arrayref that can contain 'tags' to return all the tags and/or 'heads' to return all the heads. C<REFGLOB> is an optional array of strings containing a shell-like glob to further limit the refs returned in @@ -890,20 +969,22 @@ sub cat_blob { my $size = $1; my $blob; - my $bytesRead = 0; + my $bytesLeft = $size; while (1) { - my $bytesLeft = $size - $bytesRead; last unless $bytesLeft; my $bytesToRead = $bytesLeft < 1024 ? $bytesLeft : 1024; - my $read = read($in, $blob, $bytesToRead, $bytesRead); + my $read = read($in, $blob, $bytesToRead); unless (defined($read)) { $self->_close_cat_blob(); throw Error::Simple("in pipe went bad"); } - - $bytesRead += $read; + unless (print $fh $blob) { + $self->_close_cat_blob(); + throw Error::Simple("couldn't write to passed in filehandle"); + } + $bytesLeft -= $read; } # Skip past the trailing newline. @@ -918,11 +999,6 @@ sub cat_blob { throw Error::Simple("didn't find newline after blob"); } - unless (print $fh $blob) { - $self->_close_cat_blob(); - throw Error::Simple("couldn't write to passed in filehandle"); - } - return $size; } @@ -948,13 +1024,163 @@ sub _close_cat_blob { } +=item credential_read( FILEHANDLE ) + +Reads credential key-value pairs from C<FILEHANDLE>. Reading stops at EOF or +when an empty line is encountered. Each line must be of the form C<key=value> +with a non-empty key. Function returns hash with all read values. Any white +space (other than new-line character) is preserved. + +=cut + +sub credential_read { + my ($self, $reader) = _maybe_self(@_); + my %credential; + while (<$reader>) { + chomp; + if ($_ eq '') { + last; + } elsif (!/^([^=]+)=(.*)$/) { + throw Error::Simple("unable to parse git credential data:\n$_"); + } + $credential{$1} = $2; + } + return %credential; +} + +=item credential_write( FILEHANDLE, CREDENTIAL_HASHREF ) + +Writes credential key-value pairs from hash referenced by +C<CREDENTIAL_HASHREF> to C<FILEHANDLE>. Keys and values cannot contain +new-lines or NUL bytes characters, and key cannot contain equal signs nor be +empty (if they do Error::Simple is thrown). Any white space is preserved. If +value for a key is C<undef>, it will be skipped. + +If C<'url'> key exists it will be written first. (All the other key-value +pairs are written in sorted order but you should not depend on that). Once +all lines are written, an empty line is printed. + +=cut + +sub credential_write { + my ($self, $writer, $credential) = _maybe_self(@_); + my ($key, $value); + + # Check if $credential is valid prior to writing anything + while (($key, $value) = each %$credential) { + if (!defined $key || !length $key) { + throw Error::Simple("credential key empty or undefined"); + } elsif ($key =~ /[=\n\0]/) { + throw Error::Simple("credential key contains invalid characters: $key"); + } elsif (defined $value && $value =~ /[\n\0]/) { + throw Error::Simple("credential value for key=$key contains invalid characters: $value"); + } + } + + for $key (sort { + # url overwrites other fields, so it must come first + return -1 if $a eq 'url'; + return 1 if $b eq 'url'; + return $a cmp $b; + } keys %$credential) { + if (defined $credential->{$key}) { + print $writer $key, '=', $credential->{$key}, "\n"; + } + } + print $writer "\n"; +} + +sub _credential_run { + my ($self, $credential, $op) = _maybe_self(@_); + my ($pid, $reader, $writer, $ctx) = command_bidi_pipe('credential', $op); + + credential_write $writer, $credential; + close $writer; + + if ($op eq "fill") { + %$credential = credential_read $reader; + } + if (<$reader>) { + throw Error::Simple("unexpected output from git credential $op response:\n$_\n"); + } + + command_close_bidi_pipe($pid, $reader, undef, $ctx); +} + +=item credential( CREDENTIAL_HASHREF [, OPERATION ] ) + +=item credential( CREDENTIAL_HASHREF, CODE ) + +Executes C<git credential> for a given set of credentials and specified +operation. In both forms C<CREDENTIAL_HASHREF> needs to be a reference to +a hash which stores credentials. Under certain conditions the hash can +change. + +In the first form, C<OPERATION> can be C<'fill'>, C<'approve'> or C<'reject'>, +and function will execute corresponding C<git credential> sub-command. If +it's omitted C<'fill'> is assumed. In case of C<'fill'> the values stored in +C<CREDENTIAL_HASHREF> will be changed to the ones returned by the C<git +credential fill> command. The usual usage would look something like: + + my %cred = ( + 'protocol' => 'https', + 'host' => 'example.com', + 'username' => 'bob' + ); + Git::credential \%cred; + if (try_to_authenticate($cred{'username'}, $cred{'password'})) { + Git::credential \%cred, 'approve'; + ... do more stuff ... + } else { + Git::credential \%cred, 'reject'; + } + +In the second form, C<CODE> needs to be a reference to a subroutine. The +function will execute C<git credential fill> to fill the provided credential +hash, then call C<CODE> with C<CREDENTIAL_HASHREF> as the sole argument. If +C<CODE>'s return value is defined, the function will execute C<git credential +approve> (if return value yields true) or C<git credential reject> (if return +value is false). If the return value is undef, nothing at all is executed; +this is useful, for example, if the credential could neither be verified nor +rejected due to an unrelated network error. The return value is the same as +what C<CODE> returns. With this form, the usage might look as follows: + + if (Git::credential { + 'protocol' => 'https', + 'host' => 'example.com', + 'username' => 'bob' + }, sub { + my $cred = shift; + return !!try_to_authenticate($cred->{'username'}, + $cred->{'password'}); + }) { + ... do more stuff ... + } + +=cut + +sub credential { + my ($self, $credential, $op_or_code) = (_maybe_self(@_), 'fill'); + + if ('CODE' eq ref $op_or_code) { + _credential_run $credential, 'fill'; + my $ret = $op_or_code->($credential); + if (defined $ret) { + _credential_run $credential, $ret ? 'approve' : 'reject'; + } + return $ret; + } else { + _credential_run $credential, $op_or_code; + } +} + { # %TEMP_* Lexical Context my (%TEMP_FILEMAP, %TEMP_FILES); =item temp_acquire ( NAME ) -Attempts to retreive the temporary file mapped to the string C<NAME>. If an +Attempts to retrieve the temporary file mapped to the string C<NAME>. If an associated temp file has not been created this session or was closed, it is created, cached, and set for autoflush and binmode. @@ -1039,7 +1265,7 @@ sub _temp_cache { $tmpdir = $self->repo_path(); } - ($$temp_fd, $fname) = File::Temp->tempfile( + ($$temp_fd, $fname) = File::Temp::tempfile( 'Git_XXXXXX', UNLINK => 1, DIR => $tmpdir, ) or throw Error::Simple("couldn't open new temp file"); @@ -1263,12 +1489,12 @@ sub _command_common_pipe { if (not defined $pid) { throw Error::Simple("open failed: $!"); } elsif ($pid == 0) { - if (defined $opts{STDERR}) { - close STDERR; - } if ($opts{STDERR}) { open (STDERR, '>&', $opts{STDERR}) or die "dup failed: $!"; + } elsif (defined $opts{STDERR}) { + open (STDERR, '>', '/dev/null') + or die "opening /dev/null failed: $!"; } _cmd_exec($self, $cmd, @args); } @@ -1303,9 +1529,11 @@ sub _execv_git_cmd { exec('git', @_); } # Close pipe to a subprocess. sub _cmd_close { - my ($fh, $ctx) = @_; - if (not close $fh) { - if ($!) { + my $ctx = shift @_; + foreach my $fh (@_) { + if (close $fh) { + # nop + } elsif ($!) { # It's just close, no point in fatalities carp "error closing pipe: $!"; } elsif ($? >> 8) { |