diff options
Diffstat (limited to 'perl')
| -rw-r--r-- | perl/.gitignore | 9 | ||||
| -rw-r--r-- | perl/FromCPAN/.gitattributes | 1 | ||||
| -rw-r--r-- | perl/FromCPAN/Error.pm (renamed from perl/private-Error.pm) | 295 | ||||
| -rw-r--r-- | perl/FromCPAN/Mail/Address.pm | 280 | ||||
| -rw-r--r-- | perl/Git.pm | 91 | ||||
| -rw-r--r-- | perl/Git/I18N.pm | 2 | ||||
| -rw-r--r-- | perl/Git/LoadCPAN.pm | 104 | ||||
| -rw-r--r-- | perl/Git/LoadCPAN/Error.pm | 10 | ||||
| -rw-r--r-- | perl/Git/LoadCPAN/Mail/Address.pm | 10 | ||||
| -rw-r--r-- | perl/Git/SVN.pm | 15 | ||||
| -rw-r--r-- | perl/Makefile | 90 | ||||
| -rw-r--r-- | perl/Makefile.PL | 62 | ||||
| -rw-r--r-- | perl/header_templates/fixed_prefix.template.pl | 1 | ||||
| -rw-r--r-- | perl/header_templates/runtime_prefix.template.pl | 42 |
14 files changed, 719 insertions, 293 deletions
diff --git a/perl/.gitignore b/perl/.gitignore index 0f1fc27..84c048a 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/FromCPAN/.gitattributes b/perl/FromCPAN/.gitattributes new file mode 100644 index 0000000..8b64fc5 --- /dev/null +++ b/perl/FromCPAN/.gitattributes @@ -0,0 +1 @@ +/Error.pm whitespace=-blank-at-eof diff --git a/perl/private-Error.pm b/perl/FromCPAN/Error.pm index 6098135..8b95e2d 100644 --- a/perl/private-Error.pm +++ b/perl/FromCPAN/Error.pm @@ -12,10 +12,12 @@ package Error; use strict; +use warnings; + use vars qw($VERSION); use 5.004; -$VERSION = "0.15009"; +$VERSION = "0.17025"; use overload ( '""' => 'stringify', @@ -32,21 +34,35 @@ $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 +sub _throw_Error_Simple { my $args = shift; return Error::Simple->new($args->{'text'}); } -$Error::ObjectifyCallback = \&throw_Error_Simple; +$Error::ObjectifyCallback = \&_throw_Error_Simple; # Exported subs are defined in Error::subs +use Scalar::Util (); + sub import { shift; + my @tags = @_; local $Exporter::ExportLevel = $Exporter::ExportLevel + 1; - Error::subs->import(@_); + + @tags = grep { + if( $_ eq ':warndie' ) { + Error::WarnDie->import(); + 0; + } + else { + 1; + } + } @tags; + + Error::subs->import(@tags); } # I really want to use last for the name of this method, but it is a keyword @@ -107,10 +123,6 @@ sub stacktrace { $text; } -# Allow error propagation, ie -# -# $ber->encode(...) or -# return Error->prior($ber)->associate($ldap); sub associate { my $err = shift; @@ -130,6 +142,7 @@ sub associate { return; } + sub new { my $self = shift; my($pkg,$file,$line) = caller($Error::Depth); @@ -246,6 +259,10 @@ sub value { package Error::Simple; +use vars qw($VERSION); + +$VERSION = "0.17025"; + @Error::Simple::ISA = qw(Error); sub new { @@ -288,14 +305,6 @@ use vars qw(@EXPORT_OK @ISA %EXPORT_TAGS); @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; @@ -314,16 +323,17 @@ sub run_clauses ($$$\@) { my $pkg = $catch->[$i]; unless(defined $pkg) { #except - splice(@$catch,$i,2,$catch->[$i+1]->()); + splice(@$catch,$i,2,$catch->[$i+1]->($err)); $i -= 2; next CATCHLOOP; } - elsif(blessed($err) && $err->isa($pkg)) { + elsif(Scalar::Util::blessed($err) && $err->isa($pkg)) { $code = $catch->[$i+1]; while(1) { my $more = 0; - local($Error::THROWN); + local($Error::THROWN, $@); my $ok = eval { + $@ = $err; if($wantarray) { @{$result} = $code->($err,\$more); } @@ -341,10 +351,9 @@ sub run_clauses ($$$\@) { undef $err; } else { - $err = defined($Error::THROWN) - ? $Error::THROWN : $@; - $err = $Error::ObjectifyCallback->({'text' =>$err}) - unless ref($err); + $err = $@ || $Error::THROWN; + $err = $Error::ObjectifyCallback->({'text' =>$err}) + unless ref($err); } last CATCH; }; @@ -357,7 +366,9 @@ sub run_clauses ($$$\@) { if(defined($owise = $clauses->{'otherwise'})) { my $code = $clauses->{'otherwise'}; my $more = 0; + local($Error::THROWN, $@); my $ok = eval { + $@ = $err; if($wantarray) { @{$result} = $code->($err,\$more); } @@ -374,11 +385,10 @@ sub run_clauses ($$$\@) { undef $err; } else { - $err = defined($Error::THROWN) - ? $Error::THROWN : $@; + $err = $@ || $Error::THROWN; - $err = $Error::ObjectifyCallback->({'text' =>$err}) - unless ref($err); + $err = $Error::ObjectifyCallback->({'text' =>$err}) + unless ref($err); } } } @@ -398,7 +408,7 @@ sub try (&;$) { do { local $Error::THROWN = undef; - local $@ = undef; + local $@ = undef; $ok = eval { if($wantarray) { @@ -413,21 +423,21 @@ sub try (&;$) { 1; }; - $err = defined($Error::THROWN) ? $Error::THROWN : $@ + $err = $@ || $Error::THROWN unless $ok; }; shift @Error::STACK; $err = run_clauses($clauses,$err,wantarray,@result) - unless($ok); + unless($ok); $clauses->{'finally'}->() if(defined($clauses->{'finally'})); if (defined($err)) { - if (blessed($err) && $err->can('throw')) + if (Scalar::Util::blessed($err) && $err->can('throw')) { throw $err; } @@ -506,12 +516,116 @@ sub otherwise (&;$) { } 1; + +package Error::WarnDie; + +sub gen_callstack($) +{ + my ( $start ) = @_; + + require Carp; + local $Carp::CarpLevel = $start; + my $trace = Carp::longmess(""); + # 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; + my @callstack = split( m/\n/, $trace ); + return @callstack; +} + +my $old_DIE; +my $old_WARN; + +sub DEATH +{ + my ( $e ) = @_; + + local $SIG{__DIE__} = $old_DIE if( defined $old_DIE ); + + die @_ if $^S; + + my ( $etype, $message, $location, @callstack ); + if ( ref($e) && $e->isa( "Error" ) ) { + $etype = "exception of type " . ref( $e ); + $message = $e->text; + $location = $e->file . ":" . $e->line; + @callstack = split( m/\n/, $e->stacktrace ); + } + else { + # Don't apply subsequent layer of message formatting + die $e if( $e =~ m/^\nUnhandled perl error caught at toplevel:\n\n/ ); + $etype = "perl error"; + my $stackdepth = 0; + while( caller( $stackdepth ) =~ m/^Error(?:$|::)/ ) { + $stackdepth++ + } + + @callstack = gen_callstack( $stackdepth + 1 ); + + $message = "$e"; + chomp $message; + + if ( $message =~ s/ at (.*?) line (\d+)\.$// ) { + $location = $1 . ":" . $2; + } + else { + my @caller = caller( $stackdepth ); + $location = $caller[1] . ":" . $caller[2]; + } + } + + shift @callstack; + # Do it this way in case there are no elements; we don't print a spurious \n + my $callstack = join( "", map { "$_\n"} @callstack ); + + die "\nUnhandled $etype caught at toplevel:\n\n $message\n\nThrown from: $location\n\nFull stack trace:\n\n$callstack\n"; +} + +sub TAXES +{ + my ( $message ) = @_; + + local $SIG{__WARN__} = $old_WARN if( defined $old_WARN ); + + $message =~ s/ at .*? line \d+\.$//; + chomp $message; + + my @callstack = gen_callstack( 1 ); + my $location = shift @callstack; + + # $location already starts in a leading space + $message .= $location; + + # Do it this way in case there are no elements; we don't print a spurious \n + my $callstack = join( "", map { "$_\n"} @callstack ); + + warn "$message:\n$callstack"; +} + +sub import +{ + $old_DIE = $SIG{__DIE__}; + $old_WARN = $SIG{__WARN__}; + + $SIG{__DIE__} = \&DEATH; + $SIG{__WARN__} = \&TAXES; +} + +1; + __END__ =head1 NAME Error - Error/exception handling in an OO-ish way +=head1 WARNING + +Using the "Error" module is B<no longer recommended> due to the black-magical +nature of its syntactic sugar, which often tends to break. Its maintainers +have stopped actively writing code that uses it, and discourage people +from doing so. See the "SEE ALSO" section below for better recommendations. + =head1 SYNOPSIS use Error qw(:try); @@ -529,7 +643,7 @@ Error - Error/exception handling in an OO-ish way try { do_some_stuff(); die "error!" if $condition; - throw Error::Simple -text => "Oops!" if $other_condition; + throw Error::Simple "Oops!" if $other_condition; } catch Error::IO with { my $E = shift; @@ -587,7 +701,7 @@ 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. +found. The error will also be available in C<$@>. To propagate the error the catch block may call C<$err-E<gt>throw> @@ -608,7 +722,7 @@ type. 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. +error being processed. The error will also be available in C<$@>. Only one otherwise block may be specified per try block @@ -625,12 +739,25 @@ Only one finally block may be specified per try block =back +=head1 COMPATIBILITY + +L<Moose> exports a keyword called C<with> which clashes with Error's. This +example returns a prototype mismatch error: + + package MyTest; + + use warnings; + use Moose; + use Error qw(:try); + +(Thanks to C<maik.hentsche@amd.com> for the report.). + =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 +with the arguments that are passed to it's constructor. The elements that are used by, or are retrievable by the C<Error> class are listed below, other classes may add to these. @@ -655,6 +782,10 @@ an object blessed into that package as the C<-object> argument. =over 4 +=item Error->new() + +See the Error::Simple documentation. + =item throw ( [ ARGS ] ) Create a new C<Error> object and throw an error, which will be caught @@ -730,6 +861,13 @@ The line where the constructor of this error was called from The text of the error +=item $err->associate($obj) + +Associates an error with an object to allow error propagation. I.e: + + $ber->encode(...) or + return Error->prior($ber)->associate($ldap); + =back =head2 OVERLOAD METHODS @@ -759,11 +897,9 @@ to the constructor. =head1 PRE-DEFINED ERROR CLASSES -=over 4 - -=item Error::Simple +=head2 Error::Simple -This class can be used to hold simple error strings and values. Its +This class can be used to hold simple error strings and values. It's 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. @@ -775,7 +911,6 @@ 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 @@ -804,6 +939,76 @@ class MyError::Bar by default: # Error handling here. } +=cut + +=head1 MESSAGE HANDLERS + +C<Error> also provides handlers to extend the output of the C<warn()> perl +function, and to handle the printing of a thrown C<Error> that is not caught +or otherwise handled. These are not installed by default, but are requested +using the C<:warndie> tag in the C<use> line. + + use Error qw( :warndie ); + +These new error handlers are installed in C<$SIG{__WARN__}> and +C<$SIG{__DIE__}>. If these handlers are already defined when the tag is +imported, the old values are stored, and used during the new code. Thus, to +arrange for custom handling of warnings and errors, you will need to perform +something like the following: + + BEGIN { + $SIG{__WARN__} = sub { + print STDERR "My special warning handler: $_[0]" + }; + } + + use Error qw( :warndie ); + +Note that setting C<$SIG{__WARN__}> after the C<:warndie> tag has been +imported will overwrite the handler that C<Error> provides. If this cannot be +avoided, then the tag can be explicitly C<import>ed later + + use Error; + + $SIG{__WARN__} = ...; + + import Error qw( :warndie ); + +=head2 EXAMPLE + +The C<__DIE__> handler turns messages such as + + Can't call method "foo" on an undefined value at examples/warndie.pl line 16. + +into + + Unhandled perl error caught at toplevel: + + Can't call method "foo" on an undefined value + + Thrown from: examples/warndie.pl:16 + + Full stack trace: + + main::inner('undef') called at examples/warndie.pl line 20 + main::outer('undef') called at examples/warndie.pl line 23 + +=cut + +=head1 SEE ALSO + +See L<Exception::Class> for a different module providing Object-Oriented +exception handling, along with a convenient syntax for declaring hierarchies +for them. It doesn't provide Error's syntactic sugar of C<try { ... }>, +C<catch { ... }>, etc. which may be a good thing or a bad thing based +on what you want. (Because Error's syntactic sugar tends to break.) + +L<Error::Exception> aims to combine L<Error> and L<Exception::Class> +"with correct stringification". + +L<TryCatch> and L<Try::Tiny> are similar in concept to Error.pm only providing +a syntax that hopefully breaks less. + =head1 KNOWN BUGS None, but that does not mean there are not any. @@ -816,12 +1021,20 @@ 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>. +C<:warndie> handlers added by Paul Evans <leonerd@leonerd.org.uk> + =head1 MAINTAINER -Shlomi Fish <shlomif@iglu.org.il> +Shlomi Fish, L<http://www.shlomifish.org/> . =head1 PAST MAINTAINERS Arun Kumar U <u_arunkumar@yahoo.com> +=head1 COPYRIGHT + +Copyright (c) 1997-8 Graham Barr. All rights reserved. +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + =cut diff --git a/perl/FromCPAN/Mail/Address.pm b/perl/FromCPAN/Mail/Address.pm new file mode 100644 index 0000000..683d490 --- /dev/null +++ b/perl/FromCPAN/Mail/Address.pm @@ -0,0 +1,280 @@ +# Copyrights 1995-2018 by [Mark Overmeer]. +# For other contributors see ChangeLog. +# See the manual pages for details on the licensing terms. +# Pod stripped from pm file by OODoc 2.02. +# This code is part of the bundle MailTools. Meta-POD processed with +# OODoc into POD and HTML manual-pages. See README.md for Copyright. +# Licensed under the same terms as Perl itself. + +package Mail::Address; +use vars '$VERSION'; +$VERSION = '2.20'; + +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.pm b/perl/Git.pm index ffa09ac..d856930 100644 --- a/perl/Git.pm +++ b/perl/Git.pm @@ -9,7 +9,10 @@ package Git; use 5.008; use strict; +use warnings; +use File::Temp (); +use File::Spec (); BEGIN { @@ -101,7 +104,7 @@ increase notwithstanding). use Carp qw(carp croak); # but croak is bad - throw instead -use Error qw(:try); +use Git::LoadCPAN::Error qw(:try); use Cwd qw(abs_path cwd); use IPC::Open2 qw(open2); use Fcntl qw(SEEK_SET SEEK_CUR); @@ -189,7 +192,6 @@ sub repository { }; if ($dir) { - _verify_require(); File::Spec->file_name_is_absolute($dir) or $dir = $opts{Directory} . '/' . $dir; $opts{Repository} = abs_path($dir); @@ -534,7 +536,9 @@ If TIME is not supplied, the current local time is used. sub get_tz_offset { # some systems don't handle or mishandle %z, so be creative. my $t = shift || time; - my $gm = timegm(localtime($t)); + my @t = localtime($t); + $t[5] += 1900; + my $gm = timegm(@t); my $sign = qw( + + - )[ $gm <=> $t ]; return sprintf("%s%02d%02d", $sign, (gmtime(abs($t - $gm)))[2,1]); } @@ -550,7 +554,7 @@ sub get_record { my ($fh, $rs) = @_; local $/ = $rs; my $rec = <$fh>; - chomp $rec if defined $rs; + chomp $rec if defined $rec; $rec; } @@ -880,77 +884,6 @@ sub ident_person { return "$ident[0] <$ident[1]>"; } -=item parse_mailboxes - -Return an array of mailboxes extracted from a string. - -=cut - -# Very close to Mail::Address's parser, but we still have minor -# differences in some cases (see t9000 for examples). -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 } @_; - my $end_of_addr_seen = 0; - - # 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 ($end_of_addr_seen) { - push @phrase, @buffer; - } else { - push @address, @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 = (); - $end_of_addr_seen = 0; - } elsif ($token =~ /^\(/) { - push @comment, $token; - } elsif ($token eq "<") { - push @phrase, (splice @address), (splice @buffer); - } elsif ($token eq ">") { - $end_of_addr_seen = 1; - push @address, (splice @buffer); - } elsif ($token eq "@" && !$end_of_addr_seen) { - 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 @@ -1359,8 +1292,6 @@ sub temp_release { sub _temp_cache { my ($self, $name) = _maybe_self(@_); - _verify_require(); - my $temp_fd = \$TEMP_FILEMAP{$name}; if (defined $$temp_fd and $$temp_fd->opened) { if ($TEMP_FILES{$$temp_fd}{locked}) { @@ -1394,11 +1325,6 @@ sub _temp_cache { $$temp_fd; } -sub _verify_require { - eval { require File::Temp; require File::Spec; }; - $@ and throw Error::Simple($@); -} - =item temp_reset ( FILEHANDLE ) Truncates and resets the position of the C<FILEHANDLE>. @@ -1763,7 +1689,6 @@ sub DESTROY { # Pipe implementation for ActiveState Perl. package Git::activestate_pipe; -use strict; sub TIEHANDLE { my ($class, @params) = @_; diff --git a/perl/Git/I18N.pm b/perl/Git/I18N.pm index 836a5c2..bfb4fb6 100644 --- a/perl/Git/I18N.pm +++ b/perl/Git/I18N.pm @@ -18,7 +18,7 @@ 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)); diff --git a/perl/Git/LoadCPAN.pm b/perl/Git/LoadCPAN.pm new file mode 100644 index 0000000..e5585e7 --- /dev/null +++ b/perl/Git/LoadCPAN.pm @@ -0,0 +1,104 @@ +package Git::LoadCPAN; +use 5.008; +use strict; +use warnings; + +=head1 NAME + +Git::LoadCPAN - Wrapper for loading modules from the CPAN (OS) or Git's own copy + +=head1 DESCRIPTION + +The Perl code in Git depends on some modules from the CPAN, but we +don't want to make those a hard requirement for anyone building from +source. + +Therefore the L<Git::LoadCPAN> namespace shipped with Git contains +wrapper modules like C<Git::LoadCPAN::Module::Name> that will first +attempt to load C<Module::Name> from the OS, and if that doesn't work +will fall back on C<FromCPAN::Module::Name> shipped with Git itself. + +Usually distributors will not ship with Git's Git::FromCPAN tree at +all via the C<NO_PERL_CPAN_FALLBACKS> option, preferring to use their +own packaging of CPAN modules instead. + +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 + +# NO_PERL_CPAN_FALLBACKS_STR evades the sed search-replace from the +# Makefile, and allows for detecting whether the module is loaded from +# perl/Git as opposed to perl/build/Git, which is useful for one-off +# testing without having Error.pm et al installed. +use constant NO_PERL_CPAN_FALLBACKS_STR => '@@' . 'NO_PERL_CPAN_FALLBACKS' . '@@'; +use constant NO_PERL_CPAN_FALLBACKS => ( + q[@@NO_PERL_CPAN_FALLBACKS@@] ne '' + and + q[@@NO_PERL_CPAN_FALLBACKS@@] ne NO_PERL_CPAN_FALLBACKS_STR +); + +sub import { + shift; + my $caller = caller; + my %args = @_; + my $module = exists $args{module} ? delete $args{module} : die "BUG: Expected 'module' parameter!"; + my $import = exists $args{import} ? delete $args{import} : die "BUG: Expected 'import' parameter!"; + die "BUG: Too many arguments!" if keys %args; + + # Foo::Bar to Foo/Bar.pm + my $package_pm = $module; + $package_pm =~ s[::][/]g; + $package_pm .= '.pm'; + + eval { + require $package_pm; + 1; + } or do { + my $error = $@ || "Zombie Error"; + + if (NO_PERL_CPAN_FALLBACKS) { + chomp(my $error = sprintf <<'THEY_PROMISED', $module); +BUG: The '%s' module is not here, but NO_PERL_CPAN_FALLBACKS was set! + +Git needs this Perl module from the CPAN, and will by default ship +with a copy of it. This Git was built with NO_PERL_CPAN_FALLBACKS, +meaning that whoever built it promised to provide this module. + +You're seeing this error because they broke that promise, and we can't +load our fallback version, since we were asked not to install it. + +If you're seeing this error and didn't package Git yourself the +package you're using is broken, or your system is broken. This error +won't appear if Git is built without NO_PERL_CPAN_FALLBACKS (instead +we'll use our fallback version of the module). +THEY_PROMISED + die $error; + } + + my $Git_LoadCPAN_pm_path = $INC{"Git/LoadCPAN.pm"} || die "BUG: Should have our own path from %INC!"; + + require File::Basename; + my $Git_LoadCPAN_pm_root = File::Basename::dirname($Git_LoadCPAN_pm_path) || die "BUG: Can't figure out lib/Git dirname from '$Git_LoadCPAN_pm_path'!"; + + require File::Spec; + my $Git_pm_FromCPAN_root = File::Spec->catdir($Git_LoadCPAN_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 $package_pm; + }; + + if ($import) { + no strict 'refs'; + *{"${caller}::import"} = sub { + shift; + use strict 'refs'; + unshift @_, $module; + goto &{"${module}::import"}; + }; + use strict 'refs'; + } +} + +1; diff --git a/perl/Git/LoadCPAN/Error.pm b/perl/Git/LoadCPAN/Error.pm new file mode 100644 index 0000000..c6d2c45 --- /dev/null +++ b/perl/Git/LoadCPAN/Error.pm @@ -0,0 +1,10 @@ +package Git::LoadCPAN::Error; +use 5.008; +use strict; +use warnings; +use Git::LoadCPAN ( + module => 'Error', + import => 1, +); + +1; diff --git a/perl/Git/LoadCPAN/Mail/Address.pm b/perl/Git/LoadCPAN/Mail/Address.pm new file mode 100644 index 0000000..f70a4f0 --- /dev/null +++ b/perl/Git/LoadCPAN/Mail/Address.pm @@ -0,0 +1,10 @@ +package Git::LoadCPAN::Mail::Address; +use 5.008; +use strict; +use warnings; +use Git::LoadCPAN ( + module => 'Mail::Address', + import => 0, +); + +1; diff --git a/perl/Git/SVN.pm b/perl/Git/SVN.pm index bc4eed3..76b2965 100644 --- a/perl/Git/SVN.pm +++ b/perl/Git/SVN.pm @@ -1405,7 +1405,7 @@ sub parse_svn_date { $ENV{TZ} = 'UTC'; my $epoch_in_UTC = - Time::Local::timelocal($S, $M, $H, $d, $m - 1, $Y - 1900); + Time::Local::timelocal($S, $M, $H, $d, $m - 1, $Y); # Determine our local timezone (including DST) at the # time of $epoch_in_UTC. $Git::SVN::Log::TZ stored the @@ -1482,7 +1482,6 @@ sub call_authors_prog { } if ($author =~ /^\s*(.+?)\s*<(.*)>\s*$/) { my ($name, $email) = ($1, $2); - $email = undef if length $2 == 0; return [$name, $email]; } else { die "Author: $orig_author: $::_authors_prog returned " @@ -2020,8 +2019,8 @@ sub make_log_entry { remove_username($full_url); $log_entry{metadata} = "$full_url\@$r $uuid"; $log_entry{svm_revision} = $r; - $email ||= "$author\@$uuid"; - $commit_email ||= "$author\@$uuid"; + $email = "$author\@$uuid" unless defined $email; + $commit_email = "$author\@$uuid" unless defined $commit_email; } elsif ($self->use_svnsync_props) { my $full_url = canonicalize_url( add_path_to_url( $self->svnsync->{url}, $self->path ) @@ -2029,15 +2028,15 @@ sub make_log_entry { remove_username($full_url); my $uuid = $self->svnsync->{uuid}; $log_entry{metadata} = "$full_url\@$rev $uuid"; - $email ||= "$author\@$uuid"; - $commit_email ||= "$author\@$uuid"; + $email = "$author\@$uuid" unless defined $email; + $commit_email = "$author\@$uuid" unless defined $commit_email; } else { my $url = $self->metadata_url; remove_username($url); my $uuid = $self->rewrite_uuid || $self->ra->get_uuid; $log_entry{metadata} = "$url\@$rev " . $uuid; - $email ||= "$author\@" . $uuid; - $commit_email ||= "$author\@" . $uuid; + $email = "$author\@$uuid" unless defined $email; + $commit_email = "$author\@$uuid" unless defined $commit_email; } $log_entry{name} = $name; $log_entry{email} = $email; diff --git a/perl/Makefile b/perl/Makefile deleted file mode 100644 index f657de2..0000000 --- a/perl/Makefile +++ /dev/null @@ -1,90 +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/Packet -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 3f29ba9..0000000 --- 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' -); diff --git a/perl/header_templates/fixed_prefix.template.pl b/perl/header_templates/fixed_prefix.template.pl new file mode 100644 index 0000000..857b439 --- /dev/null +++ b/perl/header_templates/fixed_prefix.template.pl @@ -0,0 +1 @@ +use lib (split(/@@PATHSEP@@/, $ENV{GITPERLLIB} || '@@INSTLIBDIR@@')); diff --git a/perl/header_templates/runtime_prefix.template.pl b/perl/header_templates/runtime_prefix.template.pl new file mode 100644 index 0000000..9d28b3d --- /dev/null +++ b/perl/header_templates/runtime_prefix.template.pl @@ -0,0 +1,42 @@ +# BEGIN RUNTIME_PREFIX generated code. +# +# This finds our Git::* libraries relative to the script's runtime path. +sub __git_system_path { + my ($relpath) = @_; + my $gitexecdir_relative = '@@GITEXECDIR_REL@@'; + + # GIT_EXEC_PATH is supplied by `git` or the test suite. + my $exec_path; + if (exists $ENV{GIT_EXEC_PATH}) { + $exec_path = $ENV{GIT_EXEC_PATH}; + } else { + # This can happen if this script is being directly invoked instead of run + # by "git". + require FindBin; + $exec_path = $FindBin::Bin; + } + + # Trim off the relative gitexecdir path to get the system path. + (my $prefix = $exec_path) =~ s/\Q$gitexecdir_relative\E$//; + + require File::Spec; + return File::Spec->catdir($prefix, $relpath); +} + +BEGIN { + use lib split /@@PATHSEP@@/, + ( + $ENV{GITPERLLIB} || + do { + my $perllibdir = __git_system_path('@@PERLLIBDIR_REL@@'); + (-e $perllibdir) || die("Invalid system path ($relpath): $path"); + $perllibdir; + } + ); + + # Export the system locale directory to the I18N module. The locale directory + # is only installed if NO_GETTEXT is set. + $Git::I18N::TEXTDOMAINDIR = __git_system_path('@@LOCALEDIR_REL@@'); +} + +# END RUNTIME_PREFIX generated code. |