diff options
Diffstat (limited to 'perl')
| -rw-r--r-- | perl/.gitignore | 9 | ||||
| -rw-r--r-- | perl/Git.pm | 182 | ||||
| -rw-r--r-- | perl/Git/Error.pm | 46 | ||||
| -rw-r--r-- | perl/Git/FromCPAN/Error.pm (renamed from perl/private-Error.pm) | 0 | ||||
| -rw-r--r-- | perl/Git/FromCPAN/Mail/Address.pm | 276 | ||||
| -rw-r--r-- | perl/Git/I18N.pm | 21 | ||||
| -rwxr-xr-x | perl/Git/Mail/Address.pm | 24 | ||||
| -rw-r--r-- | perl/Git/Packet.pm | 173 | ||||
| -rw-r--r-- | perl/Git/SVN.pm | 70 | ||||
| -rw-r--r-- | perl/Git/SVN/Editor.pm | 12 | ||||
| -rw-r--r-- | perl/Git/SVN/Fetcher.pm | 15 | ||||
| -rw-r--r-- | perl/Git/SVN/Migration.pm | 37 | ||||
| -rw-r--r-- | perl/Git/SVN/Ra.pm | 2 | ||||
| -rw-r--r-- | perl/Makefile | 89 | ||||
| -rw-r--r-- | perl/Makefile.PL | 62 |
15 files changed, 730 insertions, 288 deletions
diff --git a/perl/.gitignore b/perl/.gitignore index 0f1fc27f86..84c048a73c 100644 --- a/perl/.gitignore +++ b/perl/.gitignore @@ -1,8 +1 @@ -perl.mak -perl.mak.old -MYMETA.json -MYMETA.yml -blib -blibdirs -pm_to_blib -PM.stamp +/build/ diff --git a/perl/Git.pm b/perl/Git.pm index 49eb88af8d..9d60d7948b 100644 --- a/perl/Git.pm +++ b/perl/Git.pm @@ -59,9 +59,10 @@ require Exporter; command_bidi_pipe command_close_bidi_pipe version exec_path html_path hash_object git_cmd_try remote_refs prompt - get_tz_offset + get_tz_offset get_record credential credential_read credential_write - temp_acquire temp_is_locked temp_release temp_reset temp_path); + temp_acquire temp_is_locked temp_release temp_reset temp_path + unquote_path); =head1 DESCRIPTION @@ -100,7 +101,7 @@ increase notwithstanding). use Carp qw(carp croak); # but croak is bad - throw instead -use Error qw(:try); +use Git::Error qw(:try); use Cwd qw(abs_path cwd); use IPC::Open2 qw(open2); use Fcntl qw(SEEK_SET SEEK_CUR); @@ -393,7 +394,7 @@ sub command_close_pipe { Execute the given C<COMMAND> in the same way as command_output_pipe() does but return both an input pipe filehandle and an output pipe filehandle. -The function will return return C<($pid, $pipe_in, $pipe_out, $ctx)>. +The function will return C<($pid, $pipe_in, $pipe_out, $ctx)>. See C<command_close_bidi_pipe()> for details. =cut @@ -531,13 +532,27 @@ 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. + # some systems 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 get_record ( FILEHANDLE, INPUT_RECORD_SEPARATOR ) + +Read one record from FILEHANDLE delimited by INPUT_RECORD_SEPARATOR, +removing any trailing INPUT_RECORD_SEPARATOR. + +=cut + +sub get_record { + my ($fh, $rs) = @_; + local $/ = $rs; + my $rec = <$fh>; + chomp $rec if defined $rs; + $rec; +} =item prompt ( PROMPT , ISPASSWORD ) @@ -865,74 +880,6 @@ 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 ) Compute the SHA1 object id of the given C<FILENAME> considering it is @@ -1421,6 +1368,95 @@ sub END { } # %TEMP_* Lexical Context +=item prefix_lines ( PREFIX, STRING [, STRING... ]) + +Prefixes lines in C<STRING> with C<PREFIX>. + +=cut + +sub prefix_lines { + my $prefix = shift; + my $string = join("\n", @_); + $string =~ s/^/$prefix/mg; + return $string; +} + +=item unquote_path ( PATH ) + +Unquote a quoted path containing c-escapes as returned by ls-files etc. +when not using -z or when parsing the output of diff -u. + +=cut + +{ + my %cquote_map = ( + "a" => chr(7), + "b" => chr(8), + "t" => chr(9), + "n" => chr(10), + "v" => chr(11), + "f" => chr(12), + "r" => chr(13), + "\\" => "\\", + "\042" => "\042", + ); + + sub unquote_path { + local ($_) = @_; + my ($retval, $remainder); + if (!/^\042(.*)\042$/) { + return $_; + } + ($_, $retval) = ($1, ""); + while (/^([^\\]*)\\(.*)$/) { + $remainder = $2; + $retval .= $1; + for ($remainder) { + if (/^([0-3][0-7][0-7])(.*)$/) { + $retval .= chr(oct($1)); + $_ = $2; + last; + } + if (/^([\\\042abtnvfr])(.*)$/) { + $retval .= $cquote_map{$1}; + $_ = $2; + last; + } + # This is malformed + throw Error::Simple("invalid quoted path $_[0]"); + } + $_ = $remainder; + } + $retval .= $_; + return $retval; + } +} + +=item get_comment_line_char ( ) + +Gets the core.commentchar configuration value. +The value falls-back to '#' if core.commentchar is set to 'auto'. + +=cut + +sub get_comment_line_char { + my $comment_line_char = config("core.commentchar") || '#'; + $comment_line_char = '#' if ($comment_line_char eq 'auto'); + $comment_line_char = '#' if (length($comment_line_char) != 1); + return $comment_line_char; +} + +=item comment_lines ( STRING [, STRING... ]) + +Comments lines following core.commentchar configuration. + +=cut + +sub comment_lines { + my $comment_line_char = get_comment_line_char; + return prefix_lines("$comment_line_char ", @_); +} + =back =head1 ERROR HANDLING diff --git a/perl/Git/Error.pm b/perl/Git/Error.pm new file mode 100644 index 0000000000..09bbc97390 --- /dev/null +++ b/perl/Git/Error.pm @@ -0,0 +1,46 @@ +package Git::Error; +use 5.008; +use strict; +use warnings; + +=head1 NAME + +Git::Error - Wrapper for the L<Error> module, in case it's not installed + +=head1 DESCRIPTION + +Wraps the import function for the L<Error> module. + +This module is only intended to be used for code shipping in the +C<git.git> repository. Use it for anything else at your peril! + +=cut + +sub import { + shift; + my $caller = caller; + + eval { + require Error; + 1; + } or do { + my $error = $@ || "Zombie Error"; + + my $Git_Error_pm_path = $INC{"Git/Error.pm"} || die "BUG: Should have our own path from %INC!"; + + require File::Basename; + my $Git_Error_pm_root = File::Basename::dirname($Git_Error_pm_path) || die "BUG: Can't figure out lib/Git dirname from '$Git_Error_pm_path'!"; + + require File::Spec; + my $Git_pm_FromCPAN_root = File::Spec->catdir($Git_Error_pm_root, 'FromCPAN'); + die "BUG: '$Git_pm_FromCPAN_root' should be a directory!" unless -d $Git_pm_FromCPAN_root; + + local @INC = ($Git_pm_FromCPAN_root, @INC); + require Error; + }; + + unshift @_, $caller; + goto &Error::import; +} + +1; diff --git a/perl/private-Error.pm b/perl/Git/FromCPAN/Error.pm index 6098135ae2..6098135ae2 100644 --- a/perl/private-Error.pm +++ b/perl/Git/FromCPAN/Error.pm diff --git a/perl/Git/FromCPAN/Mail/Address.pm b/perl/Git/FromCPAN/Mail/Address.pm new file mode 100644 index 0000000000..13b2ff7d05 --- /dev/null +++ b/perl/Git/FromCPAN/Mail/Address.pm @@ -0,0 +1,276 @@ +# Copyrights 1995-2017 by [Mark Overmeer <perl@overmeer.net>]. +# For other contributors see ChangeLog. +# See the manual pages for details on the licensing terms. +# Pod stripped from pm file by OODoc 2.02. +package Mail::Address; +use vars '$VERSION'; +$VERSION = '2.19'; + +use strict; + +use Carp; + +# use locale; removed in version 1.78, because it causes taint problems + +sub Version { our $VERSION } + + + +# given a comment, attempt to extract a person's name +sub _extract_name +{ # This function can be called as method as well + my $self = @_ && ref $_[0] ? shift : undef; + + local $_ = shift + or return ''; + + # Using encodings, too hard. See Mail::Message::Field::Full. + return '' if m/\=\?.*?\?\=/; + + # trim whitespace + s/^\s+//; + s/\s+$//; + s/\s+/ /; + + # Disregard numeric names (e.g. 123456.1234@compuserve.com) + return "" if /^[\d ]+$/; + + s/^\((.*)\)$/$1/; # remove outermost parenthesis + s/^"(.*)"$/$1/; # remove outer quotation marks + s/\(.*?\)//g; # remove minimal embedded comments + s/\\//g; # remove all escapes + s/^"(.*)"$/$1/; # remove internal quotation marks + s/^([^\s]+) ?, ?(.*)$/$2 $1/; # reverse "Last, First M." if applicable + s/,.*//; + + # Change casing only when the name contains only upper or only + # lower cased characters. + unless( m/[A-Z]/ && m/[a-z]/ ) + { # Set the case of the name to first char upper rest lower + s/\b(\w+)/\L\u$1/igo; # Upcase first letter on name + s/\bMc(\w)/Mc\u$1/igo; # Scottish names such as 'McLeod' + s/\bo'(\w)/O'\u$1/igo; # Irish names such as 'O'Malley, O'Reilly' + s/\b(x*(ix)?v*(iv)?i*)\b/\U$1/igo; # Roman numerals, eg 'Level III Support' + } + + # some cleanup + s/\[[^\]]*\]//g; + s/(^[\s'"]+|[\s'"]+$)//g; + s/\s{2,}/ /g; + + $_; +} + +sub _tokenise +{ local $_ = join ',', @_; + my (@words,$snippet,$field); + + s/\A\s+//; + s/[\r\n]+/ /g; + + while ($_ ne '') + { $field = ''; + if(s/^\s*\(/(/ ) # (...) + { my $depth = 0; + + PAREN: while(s/^(\(([^\(\)\\]|\\.)*)//) + { $field .= $1; + $depth++; + while(s/^(([^\(\)\\]|\\.)*\)\s*)//) + { $field .= $1; + last PAREN unless --$depth; + $field .= $1 if s/^(([^\(\)\\]|\\.)+)//; + } + } + + carp "Unmatched () '$field' '$_'" + if $depth; + + $field =~ s/\s+\Z//; + push @words, $field; + + next; + } + + if( s/^("(?:[^"\\]+|\\.)*")\s*// # "..." + || s/^(\[(?:[^\]\\]+|\\.)*\])\s*// # [...] + || s/^([^\s()<>\@,;:\\".[\]]+)\s*// + || s/^([()<>\@,;:\\".[\]])\s*// + ) + { push @words, $1; + next; + } + + croak "Unrecognised line: $_"; + } + + push @words, ","; + \@words; +} + +sub _find_next +{ my ($idx, $tokens, $len) = @_; + + while($idx < $len) + { my $c = $tokens->[$idx]; + return $c if $c eq ',' || $c eq ';' || $c eq '<'; + $idx++; + } + + ""; +} + +sub _complete +{ my ($class, $phrase, $address, $comment) = @_; + + @$phrase || @$comment || @$address + or return undef; + + my $o = $class->new(join(" ",@$phrase), join("",@$address), join(" ",@$comment)); + @$phrase = @$address = @$comment = (); + $o; +} + +#------------ + +sub new(@) +{ my $class = shift; + bless [@_], $class; +} + + +sub parse(@) +{ my $class = shift; + my @line = grep {defined} @_; + my $line = join '', @line; + + my (@phrase, @comment, @address, @objs); + my ($depth, $idx) = (0, 0); + + my $tokens = _tokenise @line; + my $len = @$tokens; + my $next = _find_next $idx, $tokens, $len; + + local $_; + for(my $idx = 0; $idx < $len; $idx++) + { $_ = $tokens->[$idx]; + + if(substr($_,0,1) eq '(') { push @comment, $_ } + elsif($_ eq '<') { $depth++ } + elsif($_ eq '>') { $depth-- if $depth } + elsif($_ eq ',' || $_ eq ';') + { warn "Unmatched '<>' in $line" if $depth; + my $o = $class->_complete(\@phrase, \@address, \@comment); + push @objs, $o if defined $o; + $depth = 0; + $next = _find_next $idx+1, $tokens, $len; + } + elsif($depth) { push @address, $_ } + elsif($next eq '<') { push @phrase, $_ } + elsif( /^[.\@:;]$/ || !@address || $address[-1] =~ /^[.\@:;]$/ ) + { push @address, $_ } + else + { warn "Unmatched '<>' in $line" if $depth; + my $o = $class->_complete(\@phrase, \@address, \@comment); + push @objs, $o if defined $o; + $depth = 0; + push @address, $_; + } + } + @objs; +} + +#------------ + +sub phrase { shift->set_or_get(0, @_) } +sub address { shift->set_or_get(1, @_) } +sub comment { shift->set_or_get(2, @_) } + +sub set_or_get($) +{ my ($self, $i) = (shift, shift); + @_ or return $self->[$i]; + + my $val = $self->[$i]; + $self->[$i] = shift if @_; + $val; +} + + +my $atext = '[\-\w !#$%&\'*+/=?^`{|}~]'; +sub format +{ my @addrs; + + foreach (@_) + { my ($phrase, $email, $comment) = @$_; + my @addr; + + if(defined $phrase && length $phrase) + { push @addr + , $phrase =~ /^(?:\s*$atext\s*)+$/o ? $phrase + : $phrase =~ /(?<!\\)"/ ? $phrase + : qq("$phrase"); + + push @addr, "<$email>" + if defined $email && length $email; + } + elsif(defined $email && length $email) + { push @addr, $email; + } + + if(defined $comment && $comment =~ /\S/) + { $comment =~ s/^\s*\(?/(/; + $comment =~ s/\)?\s*$/)/; + } + + push @addr, $comment + if defined $comment && length $comment; + + push @addrs, join(" ", @addr) + if @addr; + } + + join ", ", @addrs; +} + +#------------ + +sub name +{ my $self = shift; + my $phrase = $self->phrase; + my $addr = $self->address; + + $phrase = $self->comment + unless defined $phrase && length $phrase; + + my $name = $self->_extract_name($phrase); + + # first.last@domain address + if($name eq '' && $addr =~ /([^\%\.\@_]+([\._][^\%\.\@_]+)+)[\@\%]/) + { ($name = $1) =~ s/[\._]+/ /g; + $name = _extract_name $name; + } + + if($name eq '' && $addr =~ m#/g=#i) # X400 style address + { my ($f) = $addr =~ m#g=([^/]*)#i; + my ($l) = $addr =~ m#s=([^/]*)#i; + $name = _extract_name "$f $l"; + } + + length $name ? $name : undef; +} + + +sub host +{ my $addr = shift->address || ''; + my $i = rindex $addr, '@'; + $i >= 0 ? substr($addr, $i+1) : undef; +} + + +sub user +{ my $addr = shift->address || ''; + my $i = rindex $addr, '@'; + $i >= 0 ? substr($addr,0,$i) : $addr; +} + +1; diff --git a/perl/Git/I18N.pm b/perl/Git/I18N.pm index f889fd6da9..dba96fff0a 100644 --- a/perl/Git/I18N.pm +++ b/perl/Git/I18N.pm @@ -13,12 +13,12 @@ BEGIN { } } -our @EXPORT = qw(__); +our @EXPORT = qw(__ __n N__); our @EXPORT_OK = @EXPORT; sub __bootstrap_locale_messages { our $TEXTDOMAIN = 'git'; - our $TEXTDOMAINDIR = $ENV{GIT_TEXTDOMAINDIR} || '++LOCALEDIR++'; + our $TEXTDOMAINDIR = $ENV{GIT_TEXTDOMAINDIR} || '@@LOCALEDIR@@'; require POSIX; POSIX->import(qw(setlocale)); @@ -44,6 +44,7 @@ BEGIN eval { __bootstrap_locale_messages(); *__ = \&Locale::Messages::gettext; + *__n = \&Locale::Messages::ngettext; 1; } or do { # Tell test.pl that we couldn't load the gettext library. @@ -51,7 +52,10 @@ BEGIN # Just a fall-through no-op *__ = sub ($) { $_[0] }; + *__n = sub ($$$) { $_[2] == 1 ? $_[0] : $_[1] }; }; + + sub N__($) { return shift; } } 1; @@ -70,6 +74,9 @@ Git::I18N - Perl interface to Git's Gettext localizations printf __("The following error occurred: %s\n"), $error; + printf __n("committed %d file\n", "committed %d files\n", $files), $files; + + =head1 DESCRIPTION Git's internal Perl interface to gettext via L<Locale::Messages>. If @@ -87,6 +94,16 @@ it. L<Locale::Messages>'s gettext function if all goes well, otherwise our passthrough fallback function. +=head2 __n($$$) + +L<Locale::Messages>'s ngettext function or passthrough fallback function. + +=head2 N__($) + +No-operation that only returns its argument. Use this if you want xgettext to +extract the text to the pot template but do not want to trigger retrival of the +translation at run time. + =head1 AUTHOR E<AElig>var ArnfjE<ouml>rE<eth> Bjarmason <avarab@gmail.com> diff --git a/perl/Git/Mail/Address.pm b/perl/Git/Mail/Address.pm new file mode 100755 index 0000000000..2ce3e84670 --- /dev/null +++ b/perl/Git/Mail/Address.pm @@ -0,0 +1,24 @@ +package Git::Mail::Address; +use 5.008; +use strict; +use warnings; + +=head1 NAME + +Git::Mail::Address - Wrapper for the L<Mail::Address> module, in case it's not installed + +=head1 DESCRIPTION + +This module is only intended to be used for code shipping in the +C<git.git> repository. Use it for anything else at your peril! + +=cut + +eval { + require Mail::Address; + 1; +} or do { + require Git::FromCPAN::Mail::Address; +}; + +1; diff --git a/perl/Git/Packet.pm b/perl/Git/Packet.pm new file mode 100644 index 0000000000..b75738bed4 --- /dev/null +++ b/perl/Git/Packet.pm @@ -0,0 +1,173 @@ +package Git::Packet; +use 5.008; +use strict; +use warnings; +BEGIN { + require Exporter; + if ($] < 5.008003) { + *import = \&Exporter::import; + } else { + # Exporter 5.57 which supports this invocation was + # released with perl 5.8.3 + Exporter->import('import'); + } +} + +our @EXPORT = qw( + packet_compare_lists + packet_bin_read + packet_txt_read + packet_key_val_read + packet_bin_write + packet_txt_write + packet_flush + packet_initialize + packet_read_capabilities + packet_read_and_check_capabilities + packet_check_and_write_capabilities + ); +our @EXPORT_OK = @EXPORT; + +sub packet_compare_lists { + my ($expect, @result) = @_; + my $ix; + if (scalar @$expect != scalar @result) { + return undef; + } + for ($ix = 0; $ix < $#result; $ix++) { + if ($expect->[$ix] ne $result[$ix]) { + return undef; + } + } + return 1; +} + +sub packet_bin_read { + my $buffer; + my $bytes_read = read STDIN, $buffer, 4; + if ( $bytes_read == 0 ) { + # EOF - Git stopped talking to us! + return ( -1, "" ); + } elsif ( $bytes_read != 4 ) { + die "invalid packet: '$buffer'"; + } + my $pkt_size = hex($buffer); + if ( $pkt_size == 0 ) { + return ( 1, "" ); + } elsif ( $pkt_size > 4 ) { + my $content_size = $pkt_size - 4; + $bytes_read = read STDIN, $buffer, $content_size; + if ( $bytes_read != $content_size ) { + die "invalid packet ($content_size bytes expected; $bytes_read bytes read)"; + } + return ( 0, $buffer ); + } else { + die "invalid packet size: $pkt_size"; + } +} + +sub remove_final_lf_or_die { + my $buf = shift; + if ( $buf =~ s/\n$// ) { + return $buf; + } + die "A non-binary line MUST be terminated by an LF.\n" + . "Received: '$buf'"; +} + +sub packet_txt_read { + my ( $res, $buf ) = packet_bin_read(); + if ( $res != -1 and $buf ne '' ) { + $buf = remove_final_lf_or_die($buf); + } + return ( $res, $buf ); +} + +# Read a text packet, expecting that it is in the form "key=value" for +# the given $key. An EOF does not trigger any error and is reported +# back to the caller (like packet_txt_read() does). Die if the "key" +# part of "key=value" does not match the given $key, or the value part +# is empty. +sub packet_key_val_read { + my ( $key ) = @_; + my ( $res, $buf ) = packet_txt_read(); + if ( $res == -1 or ( $buf =~ s/^$key=// and $buf ne '' ) ) { + return ( $res, $buf ); + } + die "bad $key: '$buf'"; +} + +sub packet_bin_write { + my $buf = shift; + print STDOUT sprintf( "%04x", length($buf) + 4 ); + print STDOUT $buf; + STDOUT->flush(); +} + +sub packet_txt_write { + packet_bin_write( $_[0] . "\n" ); +} + +sub packet_flush { + print STDOUT sprintf( "%04x", 0 ); + STDOUT->flush(); +} + +sub packet_initialize { + my ($name, $version) = @_; + + packet_compare_lists([0, $name . "-client"], packet_txt_read()) || + die "bad initialize"; + packet_compare_lists([0, "version=" . $version], packet_txt_read()) || + die "bad version"; + packet_compare_lists([1, ""], packet_bin_read()) || + die "bad version end"; + + packet_txt_write( $name . "-server" ); + packet_txt_write( "version=" . $version ); + packet_flush(); +} + +sub packet_read_capabilities { + my @cap; + while (1) { + my ( $res, $buf ) = packet_bin_read(); + if ( $res == -1 ) { + die "unexpected EOF when reading capabilities"; + } + return ( $res, @cap ) if ( $res != 0 ); + $buf = remove_final_lf_or_die($buf); + unless ( $buf =~ s/capability=// ) { + die "bad capability buf: '$buf'"; + } + push @cap, $buf; + } +} + +# Read remote capabilities and check them against capabilities we require +sub packet_read_and_check_capabilities { + my @required_caps = @_; + my ($res, @remote_caps) = packet_read_capabilities(); + my %remote_caps = map { $_ => 1 } @remote_caps; + foreach (@required_caps) { + unless (exists($remote_caps{$_})) { + die "required '$_' capability not available from remote" ; + } + } + return %remote_caps; +} + +# Check our capabilities we want to advertise against the remote ones +# and then advertise our capabilities +sub packet_check_and_write_capabilities { + my ($remote_caps, @our_caps) = @_; + foreach (@our_caps) { + unless (exists($remote_caps->{$_})) { + die "our capability '$_' is not available from remote" + } + packet_txt_write( "capability=" . $_ ); + } + packet_flush(); +} + +1; diff --git a/perl/Git/SVN.pm b/perl/Git/SVN.pm index b2c14e2ff5..bc4eed3d75 100644 --- a/perl/Git/SVN.pm +++ b/perl/Git/SVN.pm @@ -98,6 +98,11 @@ sub resolve_local_globs { " globbed: $refname\n"; } my $u = (::cmt_metadata("$refname"))[0]; + if (!defined($u)) { + warn +"W: $refname: no associated commit metadata from SVN, skipping\n"; + next; + } $u =~ s!^\Q$url\E(/|$)!! or die "$refname: '$url' not found in '$u'\n"; if ($pathname ne $u) { @@ -485,7 +490,7 @@ sub refname { # # Additionally, % must be escaped because it is used for escaping # and we want our escaped refname to be reversible - $refname =~ s{([ \%~\^:\?\*\[\t])}{sprintf('%%%02X',ord($1))}eg; + $refname =~ s{([ \%~\^:\?\*\[\t\\])}{sprintf('%%%02X',ord($1))}eg; # no slash-separated component can begin with a dot . # /.* becomes /%2E* @@ -802,10 +807,15 @@ sub get_fetch_range { (++$min, $max); } +sub svn_dir { + command_oneline(qw(rev-parse --git-path svn)); +} + sub tmp_config { my (@args) = @_; - my $old_def_config = "$ENV{GIT_DIR}/svn/config"; - my $config = "$ENV{GIT_DIR}/svn/.metadata"; + my $svn_dir = svn_dir(); + my $old_def_config = "$svn_dir/config"; + my $config = "$svn_dir/.metadata"; if (! -f $config && -f $old_def_config) { rename $old_def_config, $config or die "Failed rename $old_def_config => $config: $!\n"; @@ -1406,7 +1416,7 @@ sub parse_svn_date { delete $ENV{TZ}; } - my $our_TZ = get_tz_offset(); + my $our_TZ = get_tz_offset($epoch_in_UTC); # This converts $epoch_in_UTC into our local timezone. my ($sec, $min, $hour, $mday, $mon, $year, @@ -1653,7 +1663,17 @@ sub tie_for_persistent_memoization { if ($memo_backend > 0) { tie %$hash => 'Git::SVN::Memoize::YAML', "$path.yaml"; } else { - tie %$hash => 'Memoize::Storable', "$path.db", 'nstore'; + # first verify that any existing file can actually be loaded + # (it may have been saved by an incompatible version) + my $db = "$path.db"; + if (-e $db) { + use Storable qw(retrieve); + + if (!eval { retrieve($db); 1 }) { + unlink $db or die "unlink $db failed: $!"; + } + } + tie %$hash => 'Memoize::Storable', $db, 'nstore'; } } @@ -1666,7 +1686,7 @@ sub tie_for_persistent_memoization { return if $memoized; $memoized = 1; - my $cache_path = "$ENV{GIT_DIR}/svn/.caches/"; + my $cache_path = svn_dir() . '/.caches/'; mkpath([$cache_path]) unless -d $cache_path; my %lookup_svn_merge_cache; @@ -1707,7 +1727,7 @@ sub tie_for_persistent_memoization { sub clear_memoized_mergeinfo_caches { die "Only call this method in non-memoized context" if ($memoized); - my $cache_path = "$ENV{GIT_DIR}/svn/.caches/"; + my $cache_path = svn_dir() . '/.caches/'; return unless -d $cache_path; for my $cache_file (("$cache_path/lookup_svn_merge", @@ -1904,15 +1924,22 @@ sub make_log_entry { my @parents = @$parents; my $props = $ed->{dir_prop}{$self->path}; - if ( $props->{"svk:merge"} ) { - $self->find_extra_svk_parents($props->{"svk:merge"}, \@parents); - } - if ( $props->{"svn:mergeinfo"} ) { - my $mi_changes = $self->mergeinfo_changes - ($parent_path, $parent_rev, - $self->path, $rev, - $props->{"svn:mergeinfo"}); - $self->find_extra_svn_parents($mi_changes, \@parents); + if ($self->follow_parent) { + my $tickets = $props->{"svk:merge"}; + if ($tickets) { + $self->find_extra_svk_parents($tickets, \@parents); + } + + my $mergeinfo_prop = $props->{"svn:mergeinfo"}; + if ($mergeinfo_prop) { + my $mi_changes = $self->mergeinfo_changes( + $parent_path, + $parent_rev, + $self->path, + $rev, + $mergeinfo_prop); + $self->find_extra_svn_parents($mi_changes, \@parents); + } } open my $un, '>>', "$self->{dir}/unhandled.log" or croak $!; @@ -2434,12 +2461,13 @@ sub _new { "refs/remotes/$prefix$default_ref_id"; } $_[1] = $repo_id; - my $dir = "$ENV{GIT_DIR}/svn/$ref_id"; + my $svn_dir = svn_dir(); + my $dir = "$svn_dir/$ref_id"; - # Older repos imported by us used $GIT_DIR/svn/foo instead of - # $GIT_DIR/svn/refs/remotes/foo when tracking refs/remotes/foo + # Older repos imported by us used $svn_dir/foo instead of + # $svn_dir/refs/remotes/foo when tracking refs/remotes/foo if ($ref_id =~ m{^refs/remotes/(.+)}) { - my $old_dir = "$ENV{GIT_DIR}/svn/$1"; + my $old_dir = "$svn_dir/$1"; if (-d $old_dir && ! -d $dir) { $dir = $old_dir; } @@ -2449,7 +2477,7 @@ sub _new { mkpath([$dir]); my $obj = bless { ref_id => $ref_id, dir => $dir, index => "$dir/index", - config => "$ENV{GIT_DIR}/svn/config", + config => "$svn_dir/config", map_root => "$dir/.rev_map", repo_id => $repo_id }, $class; # Ensure it gets canonicalized diff --git a/perl/Git/SVN/Editor.pm b/perl/Git/SVN/Editor.pm index 4c4199afec..0df16ed726 100644 --- a/perl/Git/SVN/Editor.pm +++ b/perl/Git/SVN/Editor.pm @@ -7,7 +7,9 @@ use SVN::Delta; use Carp qw/croak/; use Git qw/command command_oneline command_noisy command_output_pipe command_input_pipe command_close_pipe - command_bidi_pipe command_close_bidi_pipe/; + command_bidi_pipe command_close_bidi_pipe + get_record/; + BEGIN { @ISA = qw(SVN::Delta::Editor); } @@ -57,11 +59,9 @@ sub generate_diff { push @diff_tree, "-l$_rename_limit" if defined $_rename_limit; push @diff_tree, $tree_a, $tree_b; my ($diff_fh, $ctx) = command_output_pipe(@diff_tree); - local $/ = "\0"; my $state = 'meta'; my @mods; - while (<$diff_fh>) { - chomp $_; # this gets rid of the trailing "\0" + while (defined($_ = get_record($diff_fh, "\0"))) { if ($state eq 'meta' && /^:(\d{6})\s(\d{6})\s ($::sha1)\s($::sha1)\s ([MTCRAD])\d*$/xo) { @@ -173,9 +173,7 @@ sub rmdirs { my ($fh, $ctx) = command_output_pipe(qw/ls-tree --name-only -r -z/, $self->{tree_b}); - local $/ = "\0"; - while (<$fh>) { - chomp; + while (defined($_ = get_record($fh, "\0"))) { my @dn = split m#/#, $_; while (pop @dn) { delete $rm->{join '/', @dn}; diff --git a/perl/Git/SVN/Fetcher.pm b/perl/Git/SVN/Fetcher.pm index d8c21ad915..64e900a0e9 100644 --- a/perl/Git/SVN/Fetcher.pm +++ b/perl/Git/SVN/Fetcher.pm @@ -9,7 +9,8 @@ use Carp qw/croak/; use File::Basename qw/dirname/; use Git qw/command command_oneline command_noisy command_output_pipe command_input_pipe command_close_pipe - command_bidi_pipe command_close_bidi_pipe/; + command_bidi_pipe command_close_bidi_pipe + get_record/; BEGIN { @ISA = qw(SVN::Delta::Editor); } @@ -86,11 +87,9 @@ sub _mark_empty_symlinks { my $printed_warning; chomp(my $empty_blob = `git hash-object -t blob --stdin < /dev/null`); my ($ls, $ctx) = command_output_pipe(qw/ls-tree -r -z/, $cmt); - local $/ = "\0"; my $pfx = defined($switch_path) ? $switch_path : $git_svn->path; $pfx .= '/' if length($pfx); - while (<$ls>) { - chomp; + while (defined($_ = get_record($ls, "\0"))) { s/\A100644 blob $empty_blob\t//o or next; unless ($printed_warning) { print STDERR "Scanning for empty symlinks, ", @@ -179,9 +178,7 @@ sub delete_entry { my ($ls, $ctx) = command_output_pipe(qw/ls-tree -r --name-only -z/, $tree); - local $/ = "\0"; - while (<$ls>) { - chomp; + while (defined($_ = get_record($ls, "\0"))) { my $rmpath = "$gpath/$_"; $self->{gii}->remove($rmpath); print "\tD\t$rmpath\n" unless $::_q; @@ -247,9 +244,7 @@ sub add_directory { my ($ls, $ctx) = command_output_pipe(qw/ls-tree -r --name-only -z/, $self->{c}); - local $/ = "\0"; - while (<$ls>) { - chomp; + while (defined($_ = get_record($ls, "\0"))) { $self->{gii}->remove($_); print "\tD\t$_\n" unless $::_q; push @deleted_gpath, $gpath; diff --git a/perl/Git/SVN/Migration.pm b/perl/Git/SVN/Migration.pm index cf6ffa7581..dc90f6a621 100644 --- a/perl/Git/SVN/Migration.pm +++ b/perl/Git/SVN/Migration.pm @@ -44,7 +44,9 @@ use Git qw( command_noisy command_output_pipe command_close_pipe + command_oneline ); +use Git::SVN; sub migrate_from_v0 { my $git_dir = $ENV{GIT_DIR}; @@ -55,7 +57,9 @@ sub migrate_from_v0 { chomp; my ($id, $orig_ref) = ($_, $_); next unless $id =~ s#^refs/heads/(.+)-HEAD$#$1#; - next unless -f "$git_dir/$id/info/url"; + my $info_url = command_oneline(qw(rev-parse --git-path), + "$id/info/url"); + next unless -f $info_url; my $new_ref = "refs/remotes/$id"; if (::verify_ref("$new_ref^0")) { print STDERR "W: $orig_ref is probably an old ", @@ -82,7 +86,7 @@ sub migrate_from_v1 { my $git_dir = $ENV{GIT_DIR}; my $migrated = 0; return $migrated unless -d $git_dir; - my $svn_dir = "$git_dir/svn"; + my $svn_dir = Git::SVN::svn_dir(); # just in case somebody used 'svn' as their $id at some point... return $migrated if -d $svn_dir && ! -f "$svn_dir/info/url"; @@ -97,27 +101,28 @@ sub migrate_from_v1 { my $x = $_; next unless $x =~ s#^refs/remotes/##; chomp $x; - next unless -f "$git_dir/$x/info/url"; - my $u = eval { ::file_to_s("$git_dir/$x/info/url") }; + my $info_url = command_oneline(qw(rev-parse --git-path), + "$x/info/url"); + next unless -f $info_url; + my $u = eval { ::file_to_s($info_url) }; next unless $u; - my $dn = dirname("$git_dir/svn/$x"); + my $dn = dirname("$svn_dir/$x"); mkpath([$dn]) unless -d $dn; if ($x eq 'svn') { # they used 'svn' as GIT_SVN_ID: - mkpath(["$git_dir/svn/svn"]); + mkpath(["$svn_dir/svn"]); print STDERR " - $git_dir/$x/info => ", - "$git_dir/svn/$x/info\n"; - rename "$git_dir/$x/info", "$git_dir/svn/$x/info" or + "$svn_dir/$x/info\n"; + rename "$git_dir/$x/info", "$svn_dir/$x/info" or croak "$!: $x"; # don't worry too much about these, they probably # don't exist with repos this old (save for index, # and we can easily regenerate that) foreach my $f (qw/unhandled.log index .rev_db/) { - rename "$git_dir/$x/$f", "$git_dir/svn/$x/$f"; + rename "$git_dir/$x/$f", "$svn_dir/$x/$f"; } } else { - print STDERR " - $git_dir/$x => $git_dir/svn/$x\n"; - rename "$git_dir/$x", "$git_dir/svn/$x" or - croak "$!: $x"; + print STDERR " - $git_dir/$x => $svn_dir/$x\n"; + rename "$git_dir/$x", "$svn_dir/$x" or croak "$!: $x"; } $migrated++; } @@ -139,9 +144,10 @@ sub read_old_urls { push @dir, $_; } } + my $svn_dir = Git::SVN::svn_dir(); foreach (@dir) { my $x = $_; - $x =~ s!^\Q$ENV{GIT_DIR}\E/svn/!!o; + $x =~ s!^\Q$svn_dir\E/!!o; read_old_urls($l_map, $x, $_); } } @@ -150,7 +156,7 @@ sub migrate_from_v2 { my @cfg = command(qw/config -l/); return if grep /^svn-remote\..+\.url=/, @cfg; my %l_map; - read_old_urls(\%l_map, '', "$ENV{GIT_DIR}/svn"); + read_old_urls(\%l_map, '', Git::SVN::svn_dir()); my $migrated = 0; require Git::SVN; @@ -239,7 +245,8 @@ sub minimize_connections { } } if (@emptied) { - my $file = $ENV{GIT_CONFIG} || "$ENV{GIT_DIR}/config"; + my $file = $ENV{GIT_CONFIG} || + command_oneline(qw(rev-parse --git-path config)); print STDERR <<EOF; The following [svn-remote] sections in your config file ($file) are empty and can be safely removed: diff --git a/perl/Git/SVN/Ra.pm b/perl/Git/SVN/Ra.pm index e764696801..56ad9870bc 100644 --- a/perl/Git/SVN/Ra.pm +++ b/perl/Git/SVN/Ra.pm @@ -606,7 +606,7 @@ sub minimize_url { my $latest = $ra->get_latest_revnum; $ra->get_log("", $latest, 0, 1, 0, 1, sub {}); }; - } while ($@ && ($c = shift @components)); + } while ($@ && defined($c = shift @components)); return canonicalize_url($url); } diff --git a/perl/Makefile b/perl/Makefile deleted file mode 100644 index 15d96fcc7a..0000000000 --- a/perl/Makefile +++ /dev/null @@ -1,89 +0,0 @@ -# -# Makefile for perl support modules and routine -# -makfile:=perl.mak -modules = - -PERL_PATH_SQ = $(subst ','\'',$(PERL_PATH)) -prefix_SQ = $(subst ','\'',$(prefix)) -localedir_SQ = $(subst ','\'',$(localedir)) - -ifndef V - QUIET = @ -endif - -all install instlibdir: $(makfile) - $(QUIET)$(MAKE) -f $(makfile) $@ - -clean: - $(QUIET)test -f $(makfile) && $(MAKE) -f $(makfile) $@ || exit 0 - $(RM) ppport.h - $(RM) $(makfile) - $(RM) $(makfile).old - $(RM) PM.stamp - -$(makfile): PM.stamp - -ifdef NO_PERL_MAKEMAKER -instdir_SQ = $(subst ','\'',$(prefix)/lib) - -modules += Git -modules += Git/I18N -modules += Git/IndexInfo -modules += Git/SVN -modules += Git/SVN/Memoize/YAML -modules += Git/SVN/Fetcher -modules += Git/SVN/Editor -modules += Git/SVN/GlobSpec -modules += Git/SVN/Log -modules += Git/SVN/Migration -modules += Git/SVN/Prompt -modules += Git/SVN/Ra -modules += Git/SVN/Utils - -$(makfile): ../GIT-CFLAGS Makefile - echo all: private-Error.pm Git.pm Git/I18N.pm > $@ - set -e; \ - for i in $(modules); \ - do \ - if test $$i = $${i%/*}; \ - then \ - subdir=; \ - else \ - subdir=/$${i%/*}; \ - fi; \ - echo ' $(RM) blib/lib/'$$i'.pm' >> $@; \ - echo ' mkdir -p blib/lib'$$subdir >> $@; \ - echo ' cp '$$i'.pm blib/lib/'$$i'.pm' >> $@; \ - done - echo ' $(RM) blib/lib/Error.pm' >> $@ - '$(PERL_PATH_SQ)' -MError -e 'exit($$Error::VERSION < 0.15009)' || \ - echo ' cp private-Error.pm blib/lib/Error.pm' >> $@ - echo install: >> $@ - set -e; \ - for i in $(modules); \ - do \ - if test $$i = $${i%/*}; \ - then \ - subdir=; \ - else \ - subdir=/$${i%/*}; \ - fi; \ - echo ' $(RM) "$$(DESTDIR)$(instdir_SQ)/'$$i'.pm"' >> $@; \ - echo ' mkdir -p "$$(DESTDIR)$(instdir_SQ)'$$subdir'"' >> $@; \ - echo ' cp '$$i'.pm "$$(DESTDIR)$(instdir_SQ)/'$$i'.pm"' >> $@; \ - done - echo ' $(RM) "$$(DESTDIR)$(instdir_SQ)/Error.pm"' >> $@ - '$(PERL_PATH_SQ)' -MError -e 'exit($$Error::VERSION < 0.15009)' || \ - echo ' cp private-Error.pm "$$(DESTDIR)$(instdir_SQ)/Error.pm"' >> $@ - echo instlibdir: >> $@ - echo ' echo $(instdir_SQ)' >> $@ -else -$(makfile): Makefile.PL ../GIT-CFLAGS - $(PERL_PATH) $< PREFIX='$(prefix_SQ)' INSTALL_BASE='' --localedir='$(localedir_SQ)' -endif - -# this is just added comfort for calling make directly in perl dir -# (even though GIT-CFLAGS aren't used yet. If ever) -../GIT-CFLAGS: - $(MAKE) -C .. GIT-CFLAGS diff --git a/perl/Makefile.PL b/perl/Makefile.PL deleted file mode 100644 index 3f29ba98a6..0000000000 --- a/perl/Makefile.PL +++ /dev/null @@ -1,62 +0,0 @@ -use strict; -use warnings; -use ExtUtils::MakeMaker; -use Getopt::Long; -use File::Find; - -# Don't forget to update the perl/Makefile, too. -# Don't forget to test with NO_PERL_MAKEMAKER=YesPlease - -# Sanity: die at first unknown option -Getopt::Long::Configure qw/ pass_through /; - -my $localedir = ''; -GetOptions("localedir=s" => \$localedir); - -sub MY::postamble { - return <<'MAKE_FRAG'; -instlibdir: - @echo '$(INSTALLSITELIB)' - -ifneq (,$(DESTDIR)) -ifeq (0,$(shell expr '$(MM_VERSION)' '>' 6.10)) -$(error ExtUtils::MakeMaker version "$(MM_VERSION)" is older than 6.11 and so \ - is likely incompatible with the DESTDIR mechanism. Try setting \ - NO_PERL_MAKEMAKER=1 instead) -endif -endif - -MAKE_FRAG -} - -# Find all the .pm files in "Git/" and Git.pm -my %pm; -find sub { - return unless /\.pm$/; - - # sometimes File::Find prepends a ./ Strip it. - my $pm_path = $File::Find::name; - $pm_path =~ s{^\./}{}; - - $pm{$pm_path} = '$(INST_LIBDIR)/'.$pm_path; -}, "Git", "Git.pm"; - - -# We come with our own bundled Error.pm. It's not in the set of default -# Perl modules so install it if it's not available on the system yet. -if ( !eval { require Error } || $Error::VERSION < 0.15009) { - $pm{'private-Error.pm'} = '$(INST_LIBDIR)/Error.pm'; -} - -# redirect stdout, otherwise the message "Writing perl.mak for Git" -# disrupts the output for the target 'instlibdir' -open STDOUT, ">&STDERR"; - -WriteMakefile( - NAME => 'Git', - VERSION_FROM => 'Git.pm', - PM => \%pm, - PM_FILTER => qq[\$(PERL) -pe "s<\\Q++LOCALEDIR++\\E><$localedir>"], - MAKEFILE => 'perl.mak', - INSTALLSITEMAN3DIR => '$(SITEPREFIX)/share/man/man3' -); |