summaryrefslogtreecommitdiff
path: root/perl/Git.pm
diff options
context:
space:
mode:
Diffstat (limited to 'perl/Git.pm')
-rw-r--r--perl/Git.pm279
1 files changed, 242 insertions, 37 deletions
diff --git a/perl/Git.pm b/perl/Git.pm
index 931047c51d..204fdc6737 100644
--- a/perl/Git.pm
+++ b/perl/Git.pm
@@ -59,7 +59,9 @@ require Exporter;
command_bidi_pipe command_close_bidi_pipe
version exec_path html_path hash_object git_cmd_try
remote_refs prompt
- temp_acquire temp_release temp_reset temp_path);
+ get_tz_offset
+ credential credential_read credential_write
+ temp_acquire temp_is_locked temp_release temp_reset temp_path);
=head1 DESCRIPTION
@@ -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);
}
@@ -511,6 +517,27 @@ 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.
@@ -942,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.
@@ -970,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;
}
@@ -1000,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.
@@ -1032,6 +1206,35 @@ sub temp_acquire {
$temp_fd;
}
+=item temp_is_locked ( NAME )
+
+Returns true if the internal lock created by a previous C<temp_acquire()>
+call with C<NAME> is still in effect.
+
+When temp_acquire is called on a C<NAME>, it internally locks the temporary
+file mapped to C<NAME>. That lock will not be released until C<temp_release()>
+is called with either the original C<NAME> or the L<File::Handle> that was
+returned from the original call to temp_acquire.
+
+Subsequent attempts to call C<temp_acquire()> with the same C<NAME> will fail
+unless there has been an intervening C<temp_release()> call for that C<NAME>
+(or its corresponding L<File::Handle> that was returned by the original
+C<temp_acquire()> call).
+
+If true is returned by C<temp_is_locked()> for a C<NAME>, an attempt to
+C<temp_acquire()> the same C<NAME> will cause an error unless
+C<temp_release> is first called on that C<NAME> (or its corresponding
+L<File::Handle> that was returned by the original C<temp_acquire()> call).
+
+=cut
+
+sub temp_is_locked {
+ my ($self, $name) = _maybe_self(@_);
+ my $temp_fd = \$TEMP_FILEMAP{$name};
+
+ defined $$temp_fd && $$temp_fd->opened && $TEMP_FILES{$$temp_fd}{locked};
+}
+
=item temp_release ( NAME )
=item temp_release ( FILEHANDLE )
@@ -1091,7 +1294,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");
@@ -1315,12 +1518,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);
}
@@ -1355,9 +1558,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) {
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-07 19:25:10 +0000