summaryrefslogtreecommitdiff
path: root/perl/Git
diff options
context:
space:
mode:
Diffstat (limited to 'perl/Git')
-rw-r--r--perl/Git/Error.pm46
-rw-r--r--perl/Git/FromCPAN/Error.pm827
-rw-r--r--perl/Git/FromCPAN/Mail/Address.pm276
-rw-r--r--perl/Git/I18N.pm21
-rwxr-xr-xperl/Git/Mail/Address.pm24
-rw-r--r--perl/Git/Packet.pm173
-rw-r--r--perl/Git/SVN.pm70
-rw-r--r--perl/Git/SVN/Editor.pm12
-rw-r--r--perl/Git/SVN/Fetcher.pm15
-rw-r--r--perl/Git/SVN/Migration.pm37
-rw-r--r--perl/Git/SVN/Ra.pm2
11 files changed, 1447 insertions, 56 deletions
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/Git/FromCPAN/Error.pm b/perl/Git/FromCPAN/Error.pm
new file mode 100644
index 0000000000..6098135ae2
--- /dev/null
+++ b/perl/Git/FromCPAN/Error.pm
@@ -0,0 +1,827 @@
+# Error.pm
+#
+# Copyright (c) 1997-8 Graham Barr <gbarr@ti.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+#
+# Based on my original Error.pm, and Exceptions.pm by Peter Seibel
+# <peter@weblogic.com> and adapted by Jesse Glick <jglick@sig.bsh.com>.
+#
+# but modified ***significantly***
+
+package Error;
+
+use strict;
+use vars qw($VERSION);
+use 5.004;
+
+$VERSION = "0.15009";
+
+use overload (
+ '""' => 'stringify',
+ '0+' => 'value',
+ 'bool' => sub { return 1; },
+ 'fallback' => 1
+);
+
+$Error::Depth = 0; # Depth to pass to caller()
+$Error::Debug = 0; # Generate verbose stack traces
+@Error::STACK = (); # Clause stack for try
+$Error::THROWN = undef; # last error thrown, a workaround until die $ref works
+
+my $LAST; # Last error created
+my %ERROR; # Last error associated with package
+
+sub throw_Error_Simple
+{
+ my $args = shift;
+ return Error::Simple->new($args->{'text'});
+}
+
+$Error::ObjectifyCallback = \&throw_Error_Simple;
+
+
+# Exported subs are defined in Error::subs
+
+sub import {
+ shift;
+ local $Exporter::ExportLevel = $Exporter::ExportLevel + 1;
+ Error::subs->import(@_);
+}
+
+# I really want to use last for the name of this method, but it is a keyword
+# which prevent the syntax last Error
+
+sub prior {
+ shift; # ignore
+
+ return $LAST unless @_;
+
+ my $pkg = shift;
+ return exists $ERROR{$pkg} ? $ERROR{$pkg} : undef
+ unless ref($pkg);
+
+ my $obj = $pkg;
+ my $err = undef;
+ if($obj->isa('HASH')) {
+ $err = $obj->{'__Error__'}
+ if exists $obj->{'__Error__'};
+ }
+ elsif($obj->isa('GLOB')) {
+ $err = ${*$obj}{'__Error__'}
+ if exists ${*$obj}{'__Error__'};
+ }
+
+ $err;
+}
+
+sub flush {
+ shift; #ignore
+
+ unless (@_) {
+ $LAST = undef;
+ return;
+ }
+
+ my $pkg = shift;
+ return unless ref($pkg);
+
+ undef $ERROR{$pkg} if defined $ERROR{$pkg};
+}
+
+# Return as much information as possible about where the error
+# happened. The -stacktrace element only exists if $Error::DEBUG
+# was set when the error was created
+
+sub stacktrace {
+ my $self = shift;
+
+ return $self->{'-stacktrace'}
+ if exists $self->{'-stacktrace'};
+
+ my $text = exists $self->{'-text'} ? $self->{'-text'} : "Died";
+
+ $text .= sprintf(" at %s line %d.\n", $self->file, $self->line)
+ unless($text =~ /\n$/s);
+
+ $text;
+}
+
+# Allow error propagation, ie
+#
+# $ber->encode(...) or
+# return Error->prior($ber)->associate($ldap);
+
+sub associate {
+ my $err = shift;
+ my $obj = shift;
+
+ return unless ref($obj);
+
+ if($obj->isa('HASH')) {
+ $obj->{'__Error__'} = $err;
+ }
+ elsif($obj->isa('GLOB')) {
+ ${*$obj}{'__Error__'} = $err;
+ }
+ $obj = ref($obj);
+ $ERROR{ ref($obj) } = $err;
+
+ return;
+}
+
+sub new {
+ my $self = shift;
+ my($pkg,$file,$line) = caller($Error::Depth);
+
+ my $err = bless {
+ '-package' => $pkg,
+ '-file' => $file,
+ '-line' => $line,
+ @_
+ }, $self;
+
+ $err->associate($err->{'-object'})
+ if(exists $err->{'-object'});
+
+ # To always create a stacktrace would be very inefficient, so
+ # we only do it if $Error::Debug is set
+
+ if($Error::Debug) {
+ require Carp;
+ local $Carp::CarpLevel = $Error::Depth;
+ my $text = defined($err->{'-text'}) ? $err->{'-text'} : "Error";
+ my $trace = Carp::longmess($text);
+ # Remove try calls from the trace
+ $trace =~ s/(\n\s+\S+__ANON__[^\n]+)?\n\s+eval[^\n]+\n\s+Error::subs::try[^\n]+(?=\n)//sog;
+ $trace =~ s/(\n\s+\S+__ANON__[^\n]+)?\n\s+eval[^\n]+\n\s+Error::subs::run_clauses[^\n]+\n\s+Error::subs::try[^\n]+(?=\n)//sog;
+ $err->{'-stacktrace'} = $trace
+ }
+
+ $@ = $LAST = $ERROR{$pkg} = $err;
+}
+
+# Throw an error. this contains some very gory code.
+
+sub throw {
+ my $self = shift;
+ local $Error::Depth = $Error::Depth + 1;
+
+ # if we are not rethrow-ing then create the object to throw
+ $self = $self->new(@_) unless ref($self);
+
+ die $Error::THROWN = $self;
+}
+
+# syntactic sugar for
+#
+# die with Error( ... );
+
+sub with {
+ my $self = shift;
+ local $Error::Depth = $Error::Depth + 1;
+
+ $self->new(@_);
+}
+
+# syntactic sugar for
+#
+# record Error( ... ) and return;
+
+sub record {
+ my $self = shift;
+ local $Error::Depth = $Error::Depth + 1;
+
+ $self->new(@_);
+}
+
+# catch clause for
+#
+# try { ... } catch CLASS with { ... }
+
+sub catch {
+ my $pkg = shift;
+ my $code = shift;
+ my $clauses = shift || {};
+ my $catch = $clauses->{'catch'} ||= [];
+
+ unshift @$catch, $pkg, $code;
+
+ $clauses;
+}
+
+# Object query methods
+
+sub object {
+ my $self = shift;
+ exists $self->{'-object'} ? $self->{'-object'} : undef;
+}
+
+sub file {
+ my $self = shift;
+ exists $self->{'-file'} ? $self->{'-file'} : undef;
+}
+
+sub line {
+ my $self = shift;
+ exists $self->{'-line'} ? $self->{'-line'} : undef;
+}
+
+sub text {
+ my $self = shift;
+ exists $self->{'-text'} ? $self->{'-text'} : undef;
+}
+
+# overload methods
+
+sub stringify {
+ my $self = shift;
+ defined $self->{'-text'} ? $self->{'-text'} : "Died";
+}
+
+sub value {
+ my $self = shift;
+ exists $self->{'-value'} ? $self->{'-value'} : undef;
+}
+
+package Error::Simple;
+
+@Error::Simple::ISA = qw(Error);
+
+sub new {
+ my $self = shift;
+ my $text = "" . shift;
+ my $value = shift;
+ my(@args) = ();
+
+ local $Error::Depth = $Error::Depth + 1;
+
+ @args = ( -file => $1, -line => $2)
+ if($text =~ s/\s+at\s+(\S+)\s+line\s+(\d+)(?:,\s*<[^>]*>\s+line\s+\d+)?\.?\n?$//s);
+ push(@args, '-value', 0 + $value)
+ if defined($value);
+
+ $self->SUPER::new(-text => $text, @args);
+}
+
+sub stringify {
+ my $self = shift;
+ my $text = $self->SUPER::stringify;
+ $text .= sprintf(" at %s line %d.\n", $self->file, $self->line)
+ unless($text =~ /\n$/s);
+ $text;
+}
+
+##########################################################################
+##########################################################################
+
+# Inspired by code from Jesse Glick <jglick@sig.bsh.com> and
+# Peter Seibel <peter@weblogic.com>
+
+package Error::subs;
+
+use Exporter ();
+use vars qw(@EXPORT_OK @ISA %EXPORT_TAGS);
+
+@EXPORT_OK = qw(try with finally except otherwise);
+%EXPORT_TAGS = (try => \@EXPORT_OK);
+
+@ISA = qw(Exporter);
+
+
+sub blessed {
+ my $item = shift;
+ local $@; # don't kill an outer $@
+ ref $item and eval { $item->can('can') };
+}
+
+
+sub run_clauses ($$$\@) {
+ my($clauses,$err,$wantarray,$result) = @_;
+ my $code = undef;
+
+ $err = $Error::ObjectifyCallback->({'text' =>$err}) unless ref($err);
+
+ CATCH: {
+
+ # catch
+ my $catch;
+ if(defined($catch = $clauses->{'catch'})) {
+ my $i = 0;
+
+ CATCHLOOP:
+ for( ; $i < @$catch ; $i += 2) {
+ my $pkg = $catch->[$i];
+ unless(defined $pkg) {
+ #except
+ splice(@$catch,$i,2,$catch->[$i+1]->());
+ $i -= 2;
+ next CATCHLOOP;
+ }
+ elsif(blessed($err) && $err->isa($pkg)) {
+ $code = $catch->[$i+1];
+ while(1) {
+ my $more = 0;
+ local($Error::THROWN);
+ my $ok = eval {
+ if($wantarray) {
+ @{$result} = $code->($err,\$more);
+ }
+ elsif(defined($wantarray)) {
+ @{$result} = ();
+ $result->[0] = $code->($err,\$more);
+ }
+ else {
+ $code->($err,\$more);
+ }
+ 1;
+ };
+ if( $ok ) {
+ next CATCHLOOP if $more;
+ undef $err;
+ }
+ else {
+ $err = defined($Error::THROWN)
+ ? $Error::THROWN : $@;
+ $err = $Error::ObjectifyCallback->({'text' =>$err})
+ unless ref($err);
+ }
+ last CATCH;
+ };
+ }
+ }
+ }
+
+ # otherwise
+ my $owise;
+ if(defined($owise = $clauses->{'otherwise'})) {
+ my $code = $clauses->{'otherwise'};
+ my $more = 0;
+ my $ok = eval {
+ if($wantarray) {
+ @{$result} = $code->($err,\$more);
+ }
+ elsif(defined($wantarray)) {
+ @{$result} = ();
+ $result->[0] = $code->($err,\$more);
+ }
+ else {
+ $code->($err,\$more);
+ }
+ 1;
+ };
+ if( $ok ) {
+ undef $err;
+ }
+ else {
+ $err = defined($Error::THROWN)
+ ? $Error::THROWN : $@;
+
+ $err = $Error::ObjectifyCallback->({'text' =>$err})
+ unless ref($err);
+ }
+ }
+ }
+ $err;
+}
+
+sub try (&;$) {
+ my $try = shift;
+ my $clauses = @_ ? shift : {};
+ my $ok = 0;
+ my $err = undef;
+ my @result = ();
+
+ unshift @Error::STACK, $clauses;
+
+ my $wantarray = wantarray();
+
+ do {
+ local $Error::THROWN = undef;
+ local $@ = undef;
+
+ $ok = eval {
+ if($wantarray) {
+ @result = $try->();
+ }
+ elsif(defined $wantarray) {
+ $result[0] = $try->();
+ }
+ else {
+ $try->();
+ }
+ 1;
+ };
+
+ $err = defined($Error::THROWN) ? $Error::THROWN : $@
+ unless $ok;
+ };
+
+ shift @Error::STACK;
+
+ $err = run_clauses($clauses,$err,wantarray,@result)
+ unless($ok);
+
+ $clauses->{'finally'}->()
+ if(defined($clauses->{'finally'}));
+
+ if (defined($err))
+ {
+ if (blessed($err) && $err->can('throw'))
+ {
+ throw $err;
+ }
+ else
+ {
+ die $err;
+ }
+ }
+
+ wantarray ? @result : $result[0];
+}
+
+# Each clause adds a sub to the list of clauses. The finally clause is
+# always the last, and the otherwise clause is always added just before
+# the finally clause.
+#
+# All clauses, except the finally clause, add a sub which takes one argument
+# this argument will be the error being thrown. The sub will return a code ref
+# if that clause can handle that error, otherwise undef is returned.
+#
+# The otherwise clause adds a sub which unconditionally returns the users
+# code reference, this is why it is forced to be last.
+#
+# The catch clause is defined in Error.pm, as the syntax causes it to
+# be called as a method
+
+sub with (&;$) {
+ @_
+}
+
+sub finally (&) {
+ my $code = shift;
+ my $clauses = { 'finally' => $code };
+ $clauses;
+}
+
+# The except clause is a block which returns a hashref or a list of
+# key-value pairs, where the keys are the classes and the values are subs.
+
+sub except (&;$) {
+ my $code = shift;
+ my $clauses = shift || {};
+ my $catch = $clauses->{'catch'} ||= [];
+
+ my $sub = sub {
+ my $ref;
+ my(@array) = $code->($_[0]);
+ if(@array == 1 && ref($array[0])) {
+ $ref = $array[0];
+ $ref = [ %$ref ]
+ if(UNIVERSAL::isa($ref,'HASH'));
+ }
+ else {
+ $ref = \@array;
+ }
+ @$ref
+ };
+
+ unshift @{$catch}, undef, $sub;
+
+ $clauses;
+}
+
+sub otherwise (&;$) {
+ my $code = shift;
+ my $clauses = shift || {};
+
+ if(exists $clauses->{'otherwise'}) {
+ require Carp;
+ Carp::croak("Multiple otherwise clauses");
+ }
+
+ $clauses->{'otherwise'} = $code;
+
+ $clauses;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Error - Error/exception handling in an OO-ish way
+
+=head1 SYNOPSIS
+
+ use Error qw(:try);
+
+ throw Error::Simple( "A simple error");
+
+ sub xyz {
+ ...
+ record Error::Simple("A simple error")
+ and return;
+ }
+
+ unlink($file) or throw Error::Simple("$file: $!",$!);
+
+ try {
+ do_some_stuff();
+ die "error!" if $condition;
+ throw Error::Simple -text => "Oops!" if $other_condition;
+ }
+ catch Error::IO with {
+ my $E = shift;
+ print STDERR "File ", $E->{'-file'}, " had a problem\n";
+ }
+ except {
+ my $E = shift;
+ my $general_handler=sub {send_message $E->{-description}};
+ return {
+ UserException1 => $general_handler,
+ UserException2 => $general_handler
+ };
+ }
+ otherwise {
+ print STDERR "Well I don't know what to say\n";
+ }
+ finally {
+ close_the_garage_door_already(); # Should be reliable
+ }; # Don't forget the trailing ; or you might be surprised
+
+=head1 DESCRIPTION
+
+The C<Error> package provides two interfaces. Firstly C<Error> provides
+a procedural interface to exception handling. Secondly C<Error> is a
+base class for errors/exceptions that can either be thrown, for
+subsequent catch, or can simply be recorded.
+
+Errors in the class C<Error> should not be thrown directly, but the
+user should throw errors from a sub-class of C<Error>.
+
+=head1 PROCEDURAL INTERFACE
+
+C<Error> exports subroutines to perform exception handling. These will
+be exported if the C<:try> tag is used in the C<use> line.
+
+=over 4
+
+=item try BLOCK CLAUSES
+
+C<try> is the main subroutine called by the user. All other subroutines
+exported are clauses to the try subroutine.
+
+The BLOCK will be evaluated and, if no error is throw, try will return
+the result of the block.
+
+C<CLAUSES> are the subroutines below, which describe what to do in the
+event of an error being thrown within BLOCK.
+
+=item catch CLASS with BLOCK
+
+This clauses will cause all errors that satisfy C<$err-E<gt>isa(CLASS)>
+to be caught and handled by evaluating C<BLOCK>.
+
+C<BLOCK> will be passed two arguments. The first will be the error
+being thrown. The second is a reference to a scalar variable. If this
+variable is set by the catch block then, on return from the catch
+block, try will continue processing as if the catch block was never
+found.
+
+To propagate the error the catch block may call C<$err-E<gt>throw>
+
+If the scalar reference by the second argument is not set, and the
+error is not thrown. Then the current try block will return with the
+result from the catch block.
+
+=item except BLOCK
+
+When C<try> is looking for a handler, if an except clause is found
+C<BLOCK> is evaluated. The return value from this block should be a
+HASHREF or a list of key-value pairs, where the keys are class names
+and the values are CODE references for the handler of errors of that
+type.
+
+=item otherwise BLOCK
+
+Catch any error by executing the code in C<BLOCK>
+
+When evaluated C<BLOCK> will be passed one argument, which will be the
+error being processed.
+
+Only one otherwise block may be specified per try block
+
+=item finally BLOCK
+
+Execute the code in C<BLOCK> either after the code in the try block has
+successfully completed, or if the try block throws an error then
+C<BLOCK> will be executed after the handler has completed.
+
+If the handler throws an error then the error will be caught, the
+finally block will be executed and the error will be re-thrown.
+
+Only one finally block may be specified per try block
+
+=back
+
+=head1 CLASS INTERFACE
+
+=head2 CONSTRUCTORS
+
+The C<Error> object is implemented as a HASH. This HASH is initialized
+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.
+
+ -file
+ -line
+ -text
+ -value
+ -object
+
+If C<-file> or C<-line> are not specified in the constructor arguments
+then these will be initialized with the file name and line number where
+the constructor was called from.
+
+If the error is associated with an object then the object should be
+passed as the C<-object> argument. This will allow the C<Error> package
+to associate the error with the object.
+
+The C<Error> package remembers the last error created, and also the
+last error associated with a package. This could either be the last
+error created by a sub in that package, or the last error which passed
+an object blessed into that package as the C<-object> argument.
+
+=over 4
+
+=item throw ( [ ARGS ] )
+
+Create a new C<Error> object and throw an error, which will be caught
+by a surrounding C<try> block, if there is one. Otherwise it will cause
+the program to exit.
+
+C<throw> may also be called on an existing error to re-throw it.
+
+=item with ( [ ARGS ] )
+
+Create a new C<Error> object and returns it. This is defined for
+syntactic sugar, eg
+
+ die with Some::Error ( ... );
+
+=item record ( [ ARGS ] )
+
+Create a new C<Error> object and returns it. This is defined for
+syntactic sugar, eg
+
+ record Some::Error ( ... )
+ and return;
+
+=back
+
+=head2 STATIC METHODS
+
+=over 4
+
+=item prior ( [ PACKAGE ] )
+
+Return the last error created, or the last error associated with
+C<PACKAGE>
+
+=item flush ( [ PACKAGE ] )
+
+Flush the last error created, or the last error associated with
+C<PACKAGE>.It is necessary to clear the error stack before exiting the
+package or uncaught errors generated using C<record> will be reported.
+
+ $Error->flush;
+
+=cut
+
+=back
+
+=head2 OBJECT METHODS
+
+=over 4
+
+=item stacktrace
+
+If the variable C<$Error::Debug> was non-zero when the error was
+created, then C<stacktrace> returns a string created by calling
+C<Carp::longmess>. If the variable was zero the C<stacktrace> returns
+the text of the error appended with the filename and line number of
+where the error was created, providing the text does not end with a
+newline.
+
+=item object
+
+The object this error was associated with
+
+=item file
+
+The file where the constructor of this error was called from
+
+=item line
+
+The line where the constructor of this error was called from
+
+=item text
+
+The text of the error
+
+=back
+
+=head2 OVERLOAD METHODS
+
+=over 4
+
+=item stringify
+
+A method that converts the object into a string. This method may simply
+return the same as the C<text> method, or it may append more
+information. For example the file name and line number.
+
+By default this method returns the C<-text> argument that was passed to
+the constructor, or the string C<"Died"> if none was given.
+
+=item value
+
+A method that will return a value that can be associated with the
+error. For example if an error was created due to the failure of a
+system call, then this may return the numeric value of C<$!> at the
+time.
+
+By default this method returns the C<-value> argument that was passed
+to the constructor.
+
+=back
+
+=head1 PRE-DEFINED ERROR CLASSES
+
+=over 4
+
+=item Error::Simple
+
+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 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
+that is a plain string. (Unless C<$Error::ObjectifyCallback> is modified)
+
+=back
+
+=head1 $Error::ObjectifyCallback
+
+This variable holds a reference to a subroutine that converts errors that
+are plain strings to objects. It is used by Error.pm to convert textual
+errors to objects, and can be overridden by the user.
+
+It accepts a single argument which is a hash reference to named parameters.
+Currently the only named parameter passed is C<'text'> which is the text
+of the error, but others may be available in the future.
+
+For example the following code will cause Error.pm to throw objects of the
+class MyError::Bar by default:
+
+ sub throw_MyError_Bar
+ {
+ my $args = shift;
+ my $err = MyError::Bar->new();
+ $err->{'MyBarText'} = $args->{'text'};
+ return $err;
+ }
+
+ {
+ local $Error::ObjectifyCallback = \&throw_MyError_Bar;
+
+ # Error handling here.
+ }
+
+=head1 KNOWN BUGS
+
+None, but that does not mean there are not any.
+
+=head1 AUTHORS
+
+Graham Barr <gbarr@pobox.com>
+
+The code that inspired me to write this was originally written by
+Peter Seibel <peter@weblogic.com> and adapted by Jesse Glick
+<jglick@sig.bsh.com>.
+
+=head1 MAINTAINER
+
+Shlomi Fish <shlomif@iglu.org.il>
+
+=head1 PAST MAINTAINERS
+
+Arun Kumar U <u_arunkumar@yahoo.com>
+
+=cut
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);
}
generated by cgit v1.2.3 (git 2.25.1) at 2024-09-25 10:21:33 +0000