diff options
Diffstat (limited to 'perl')
| -rw-r--r-- | perl/Git.pm | 256 | ||||
| -rw-r--r-- | perl/Git/I18N.pm | 2 | ||||
| -rw-r--r-- | perl/Git/SVN.pm | 41 | ||||
| -rw-r--r-- | perl/Git/SVN/Editor.pm | 12 | ||||
| -rw-r--r-- | perl/Git/SVN/Fetcher.pm | 24 | ||||
| -rw-r--r-- | perl/Git/SVN/Log.pm | 1 | ||||
| -rw-r--r-- | perl/Git/SVN/Prompt.pm | 2 | ||||
| -rw-r--r-- | perl/Git/SVN/Ra.pm | 12 | ||||
| -rw-r--r-- | perl/private-Error.pm | 6 |
9 files changed, 305 insertions, 51 deletions
diff --git a/perl/Git.pm b/perl/Git.pm index a56d1e76f7..204fdc6737 100644 --- a/perl/Git.pm +++ b/perl/Git.pm @@ -60,7 +60,8 @@ require Exporter; version exec_path html_path hash_object git_cmd_try remote_refs prompt get_tz_offset - temp_acquire temp_release temp_reset temp_path); + credential credential_read credential_write + temp_acquire temp_is_locked temp_release temp_reset temp_path); =head1 DESCRIPTION @@ -269,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; @@ -288,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; @@ -315,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; @@ -383,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... ] ) @@ -420,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); @@ -428,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); } @@ -965,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. @@ -993,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; } @@ -1023,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. @@ -1055,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 ) @@ -1114,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"); @@ -1338,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); } @@ -1378,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) { diff --git a/perl/Git/I18N.pm b/perl/Git/I18N.pm index 40dd897191..f889fd6da9 100644 --- a/perl/Git/I18N.pm +++ b/perl/Git/I18N.pm @@ -68,7 +68,7 @@ Git::I18N - Perl interface to Git's Gettext localizations print __("Welcome to Git!\n"); - printf __("The following error occured: %s\n"), $error; + printf __("The following error occurred: %s\n"), $error; =head1 DESCRIPTION diff --git a/perl/Git/SVN.pm b/perl/Git/SVN.pm index 5273ee8867..6e804a271c 100644 --- a/perl/Git/SVN.pm +++ b/perl/Git/SVN.pm @@ -1599,6 +1599,7 @@ sub tie_for_persistent_memoization { my %lookup_svn_merge_cache; my %check_cherry_pick_cache; my %has_no_changes_cache; + my %_rev_list_cache; tie_for_persistent_memoization(\%lookup_svn_merge_cache, "$cache_path/lookup_svn_merge"); @@ -1620,6 +1621,14 @@ sub tie_for_persistent_memoization { SCALAR_CACHE => ['HASH' => \%has_no_changes_cache], LIST_CACHE => 'FAULT', ; + + tie_for_persistent_memoization(\%_rev_list_cache, + "$cache_path/_rev_list"); + memoize '_rev_list', + SCALAR_CACHE => 'FAULT', + LIST_CACHE => ['HASH' => \%_rev_list_cache], + ; + } sub unmemoize_svn_mergeinfo_functions { @@ -1629,6 +1638,7 @@ sub tie_for_persistent_memoization { Memoize::unmemoize 'lookup_svn_merge'; Memoize::unmemoize 'check_cherry_pick'; Memoize::unmemoize 'has_no_changes'; + Memoize::unmemoize '_rev_list'; } sub clear_memoized_mergeinfo_caches { @@ -1959,11 +1969,25 @@ sub rebuild_from_rev_db { unlink $path or croak "unlink: $!"; } +#define a global associate map to record rebuild status +my %rebuild_status; +#define a global associate map to record rebuild verify status +my %rebuild_verify_status; + sub rebuild { my ($self) = @_; my $map_path = $self->map_path; my $partial = (-e $map_path && ! -z $map_path); - return unless ::verify_ref($self->refname.'^0'); + my $verify_key = $self->refname.'^0'; + if (!$rebuild_verify_status{$verify_key}) { + my $verify_result = ::verify_ref($verify_key); + if ($verify_result) { + $rebuild_verify_status{$verify_key} = 1; + } + } + if (!$rebuild_verify_status{$verify_key}) { + return; + } if (!$partial && ($self->use_svm_props || $self->no_metadata)) { my $rev_db = $self->rev_db_path; $self->rebuild_from_rev_db($rev_db); @@ -1977,10 +2001,21 @@ sub rebuild { print "Rebuilding $map_path ...\n" if (!$partial); my ($base_rev, $head) = ($partial ? $self->rev_map_max_norebuild(1) : (undef, undef)); + my $key_value = ($head ? "$head.." : "") . $self->refname; + if (exists $rebuild_status{$key_value}) { + print "Done rebuilding $map_path\n" if (!$partial || !$head); + my $rev_db_path = $self->rev_db_path; + if (-f $self->rev_db_path) { + unlink $self->rev_db_path or croak "unlink: $!"; + } + $self->unlink_rev_db_symlink; + return; + } my ($log, $ctx) = - command_output_pipe(qw/rev-list --pretty=raw --reverse/, - ($head ? "$head.." : "") . $self->refname, + command_output_pipe(qw/rev-list --pretty=raw --reverse/, + $key_value, '--'); + $rebuild_status{$key_value} = 1; my $metadata_url = $self->metadata_url; remove_username($metadata_url); my $svn_uuid = $self->rewrite_uuid || $self->ra_uuid; diff --git a/perl/Git/SVN/Editor.pm b/perl/Git/SVN/Editor.pm index fa0d3c6cdd..34e8af966c 100644 --- a/perl/Git/SVN/Editor.pm +++ b/perl/Git/SVN/Editor.pm @@ -304,8 +304,12 @@ sub C { my ($self, $m, $deletions) = @_; my ($dir, $file) = split_path($m->{file_b}); my $pbat = $self->ensure_path($dir, $deletions); + # workaround for a bug in svn serf backend (v1.8.5 and below): + # store third argument to ->add_file() in a local variable, to make it + # have the same lifetime as $fbat + my $upa = $self->url_path($m->{file_a}); my $fbat = $self->add_file($self->repo_path($m->{file_b}), $pbat, - $self->url_path($m->{file_a}), $self->{r}); + $upa, $self->{r}); print "\tC\t$m->{file_a} => $m->{file_b}\n" unless $::_q; $self->chg_file($fbat, $m); $self->close_file($fbat,undef,$self->{pool}); @@ -323,8 +327,10 @@ sub R { my ($self, $m, $deletions) = @_; my ($dir, $file) = split_path($m->{file_b}); my $pbat = $self->ensure_path($dir, $deletions); + # workaround for a bug in svn serf backend, see comment in C() above + my $upa = $self->url_path($m->{file_a}); my $fbat = $self->add_file($self->repo_path($m->{file_b}), $pbat, - $self->url_path($m->{file_a}), $self->{r}); + $upa, $self->{r}); print "\tR\t$m->{file_a} => $m->{file_b}\n" unless $::_q; $self->apply_autoprops($file, $fbat); $self->chg_file($fbat, $m); @@ -499,6 +505,8 @@ sub apply_diff { 1; __END__ +=head1 NAME + Git::SVN::Editor - commit driver for "git svn set-tree" and dcommit =head1 SYNOPSIS diff --git a/perl/Git/SVN/Fetcher.pm b/perl/Git/SVN/Fetcher.pm index 046a7a2f31..10edb27732 100644 --- a/perl/Git/SVN/Fetcher.pm +++ b/perl/Git/SVN/Fetcher.pm @@ -1,6 +1,7 @@ package Git::SVN::Fetcher; -use vars qw/@ISA $_ignore_regex $_preserve_empty_dirs $_placeholder_filename - @deleted_gpath %added_placeholder $repo_id/; +use vars qw/@ISA $_ignore_regex $_include_regex $_preserve_empty_dirs + $_placeholder_filename @deleted_gpath %added_placeholder + $repo_id/; use strict; use warnings; use SVN::Delta; @@ -33,6 +34,10 @@ sub new { my $v = eval { command_oneline('config', '--get', $k) }; $self->{ignore_regex} = $v; + $k = "svn-remote.$repo_id.include-paths"; + $v = eval { command_oneline('config', '--get', $k) }; + $self->{include_regex} = $v; + $k = "svn-remote.$repo_id.preserve-empty-dirs"; $v = eval { command_oneline('config', '--get', '--bool', $k) }; if ($v && $v eq 'true') { @@ -117,11 +122,18 @@ sub in_dot_git { } # return value: 0 -- don't ignore, 1 -- ignore +# This will also check whether the path is explicitly included sub is_path_ignored { my ($self, $path) = @_; return 1 if in_dot_git($path); return 1 if defined($self->{ignore_regex}) && $path =~ m!$self->{ignore_regex}!; + return 0 if defined($self->{include_regex}) && + $path =~ m!$self->{include_regex}!; + return 0 if defined($_include_regex) && + $path =~ m!$_include_regex!; + return 1 if defined($self->{include_regex}); + return 1 if defined($_include_regex); return 0 unless defined($_ignore_regex); return 1 if $path =~ m!$_ignore_regex!o; return 0; @@ -303,11 +315,13 @@ sub change_file_prop { sub apply_textdelta { my ($self, $fb, $exp) = @_; return undef if $self->is_path_ignored($fb->{path}); - my $fh = $::_repository->temp_acquire('svn_delta'); + my $suffix = 0; + ++$suffix while $::_repository->temp_is_locked("svn_delta_${$}_$suffix"); + my $fh = $::_repository->temp_acquire("svn_delta_${$}_$suffix"); # $fh gets auto-closed() by SVN::TxDelta::apply(), # (but $base does not,) so dup() it for reading in close_file open my $dup, '<&', $fh or croak $!; - my $base = $::_repository->temp_acquire('git_blob'); + my $base = $::_repository->temp_acquire("git_blob_${$}_$suffix"); if ($fb->{blob}) { my ($base_is_link, $size); @@ -512,6 +526,8 @@ sub stash_placeholder_list { 1; __END__ +=head1 NAME + Git::SVN::Fetcher - tree delta consumer for "git svn fetch" =head1 SYNOPSIS diff --git a/perl/Git/SVN/Log.pm b/perl/Git/SVN/Log.pm index 3f8350a57d..34f2869ab5 100644 --- a/perl/Git/SVN/Log.pm +++ b/perl/Git/SVN/Log.pm @@ -117,6 +117,7 @@ sub run_pager { } open STDIN, '<&', $rfd or fatal "Can't redirect stdin: $!"; $ENV{LESS} ||= 'FRSX'; + $ENV{LV} ||= '-c'; exec $pager or fatal "Can't run pager: $! ($pager)"; } diff --git a/perl/Git/SVN/Prompt.pm b/perl/Git/SVN/Prompt.pm index 74daa7a597..e940b08505 100644 --- a/perl/Git/SVN/Prompt.pm +++ b/perl/Git/SVN/Prompt.pm @@ -125,6 +125,8 @@ sub _read_password { 1; __END__ +=head1 NAME + Git::SVN::Prompt - authentication callbacks for git-svn =head1 SYNOPSIS diff --git a/perl/Git/SVN/Ra.pm b/perl/Git/SVN/Ra.pm index 049c97bfaf..a7b0119ee5 100644 --- a/perl/Git/SVN/Ra.pm +++ b/perl/Git/SVN/Ra.pm @@ -32,6 +32,14 @@ BEGIN { } } +# serf has a bug that leads to a coredump upon termination if the +# remote access object is left around (not fixed yet in serf 1.3.1). +# Explicitly free it to work around the issue. +END { + $RA = undef; + $ra_invalid = 1; +} + sub _auth_providers () { my @rv = ( SVN::Client::get_simple_provider(), @@ -295,7 +303,7 @@ sub gs_do_switch { my $full_url = add_path_to_url( $self->url, $path ); my ($ra, $reparented); - if ($old_url =~ m#^svn(\+ssh)?://# || + if ($old_url =~ m#^svn(\+\w+)?://# || ($full_url =~ m#^https?://# && canonicalize_url($full_url) ne $full_url)) { $_[0] = undef; @@ -627,6 +635,8 @@ sub skip_unknown_revs { 1; __END__ +=head1 NAME + Git::SVN::Ra - Subversion remote access functions for git-svn =head1 SYNOPSIS diff --git a/perl/private-Error.pm b/perl/private-Error.pm index 11e9cd9a02..6098135ae2 100644 --- a/perl/private-Error.pm +++ b/perl/private-Error.pm @@ -630,7 +630,7 @@ Only one finally block may be specified per try block =head2 CONSTRUCTORS The C<Error> object is implemented as a HASH. This HASH is initialized -with the arguments that are passed to it's constructor. The elements +with the arguments that are passed to its constructor. The elements that are used by, or are retrievable by the C<Error> class are listed below, other classes may add to these. @@ -763,13 +763,13 @@ to the constructor. =item Error::Simple -This class can be used to hold simple error strings and values. It's +This class can be used to hold simple error strings and values. Its constructor takes two arguments. The first is a text value, the second is a numeric value. These values are what will be returned by the overload methods. If the text value ends with C<at file line 1> as $@ strings do, then -this infomation will be used to set the C<-file> and C<-line> arguments +this information will be used to set the C<-file> and C<-line> arguments of the error object. This class is used internally if an eval'd block die's with an error |