summaryrefslogtreecommitdiff
path: root/perl/Git.pm
diff options
context:
space:
mode:
Diffstat (limited to 'perl/Git.pm')
-rw-r--r--perl/Git.pm411
1 files changed, 369 insertions, 42 deletions
diff --git a/perl/Git.pm b/perl/Git.pm
index f7ce511bbb..19ef081103 100644
--- a/perl/Git.pm
+++ b/perl/Git.pm
@@ -58,8 +58,10 @@ 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
- temp_acquire temp_release temp_reset temp_path);
+ remote_refs prompt
+ 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);
}
@@ -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.
@@ -616,7 +695,7 @@ Retrieve the integer configuration C<VARIABLE>. The return value
is simple decimal number. An optional value suffix of 'k', 'm',
or 'g' in the config file will cause the value to be multiplied
by 1024, 1048576 (1024^2), or 1073741824 (1024^3) prior to output.
-It would return C<undef> if configuration variable is not defined,
+It would return C<undef> if configuration variable is not defined.
=cut
@@ -625,7 +704,7 @@ sub config_int {
}
# Common subroutine to implement bulk of what the config* family of methods
-# do. This curently wraps command('config') so it is not so fast.
+# do. This currently wraps command('config') so it is not so fast.
sub _config_common {
my ($opts) = shift @_;
my ($self, $var) = _maybe_self(@_);
@@ -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
@@ -785,6 +864,73 @@ sub ident_person {
return "$ident[0] <$ident[1]>";
}
+=item parse_mailboxes
+
+Return an array of mailboxes extracted from a string.
+
+=cut
+
+sub parse_mailboxes {
+ my $re_comment = qr/\((?:[^)]*)\)/;
+ my $re_quote = qr/"(?:[^\"\\]|\\.)*"/;
+ my $re_word = qr/(?:[^]["\s()<>:;@\\,.]|\\.)+/;
+
+ # divide the string in tokens of the above form
+ my $re_token = qr/(?:$re_quote|$re_word|$re_comment|\S)/;
+ my @tokens = map { $_ =~ /\s*($re_token)\s*/g } @_;
+
+ # add a delimiter to simplify treatment for the last mailbox
+ push @tokens, ",";
+
+ my (@addr_list, @phrase, @address, @comment, @buffer) = ();
+ foreach my $token (@tokens) {
+ if ($token =~ /^[,;]$/) {
+ # if buffer still contains undeterminated strings
+ # append it at the end of @address or @phrase
+ if (@address) {
+ push @address, @buffer;
+ } else {
+ push @phrase, @buffer;
+ }
+
+ my $str_phrase = join ' ', @phrase;
+ my $str_address = join '', @address;
+ my $str_comment = join ' ', @comment;
+
+ # quote are necessary if phrase contains
+ # special characters
+ if ($str_phrase =~ /[][()<>:;@\\,.\000-\037\177]/) {
+ $str_phrase =~ s/(^|[^\\])"/$1/g;
+ $str_phrase = qq["$str_phrase"];
+ }
+
+ # add "<>" around the address if necessary
+ if ($str_address ne "" && $str_phrase ne "") {
+ $str_address = qq[<$str_address>];
+ }
+
+ my $str_mailbox = "$str_phrase $str_address $str_comment";
+ $str_mailbox =~ s/^\s*|\s*$//g;
+ push @addr_list, $str_mailbox if ($str_mailbox);
+
+ @phrase = @address = @comment = @buffer = ();
+ } elsif ($token =~ /^\(/) {
+ push @comment, $token;
+ } elsif ($token eq "<") {
+ push @phrase, (splice @address), (splice @buffer);
+ } elsif ($token eq ">") {
+ push @address, (splice @buffer);
+ } elsif ($token eq "@") {
+ push @address, (splice @buffer), "@";
+ } elsif ($token eq ".") {
+ push @address, (splice @buffer), ".";
+ } else {
+ push @buffer, $token;
+ }
+ }
+
+ return @addr_list;
+}
=item hash_object ( TYPE, FILENAME )
@@ -890,20 +1036,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 +1066,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 +1091,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.
@@ -980,6 +1273,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 )
@@ -1039,8 +1361,11 @@ sub _temp_cache {
$tmpdir = $self->repo_path();
}
- ($$temp_fd, $fname) = File::Temp->tempfile(
- 'Git_XXXXXX', UNLINK => 1, DIR => $tmpdir,
+ my $n = $name;
+ $n =~ s/\W/_/g; # no strange chars
+
+ ($$temp_fd, $fname) = File::Temp::tempfile(
+ "Git_${n}_XXXXXX", UNLINK => 1, DIR => $tmpdir,
) or throw Error::Simple("couldn't open new temp file");
$$temp_fd->autoflush;
@@ -1263,12 +1588,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 +1628,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-12-04 13:47:18 +0000