summaryrefslogtreecommitdiff
path: root/perl
diff options
context:
space:
mode:
Diffstat (limited to 'perl')
-rw-r--r--perl/.gitignore9
-rw-r--r--perl/FromCPAN/.gitattributes1
-rw-r--r--perl/FromCPAN/Error.pm (renamed from perl/private-Error.pm)295
-rw-r--r--perl/FromCPAN/Mail/Address.pm280
-rw-r--r--perl/Git.pm91
-rw-r--r--perl/Git/I18N.pm2
-rw-r--r--perl/Git/LoadCPAN.pm104
-rw-r--r--perl/Git/LoadCPAN/Error.pm10
-rw-r--r--perl/Git/LoadCPAN/Mail/Address.pm10
-rw-r--r--perl/Git/SVN.pm15
-rw-r--r--perl/Makefile90
-rw-r--r--perl/Makefile.PL62
-rw-r--r--perl/header_templates/fixed_prefix.template.pl1
-rw-r--r--perl/header_templates/runtime_prefix.template.pl42
14 files changed, 719 insertions, 293 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/FromCPAN/.gitattributes b/perl/FromCPAN/.gitattributes
new file mode 100644
index 0000000000..8b64fc5e22
--- /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 6098135ae2..8b95e2d73d 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 0000000000..683d490b2b
--- /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 ffa09ace92..d856930b2e 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 836a5c2382..bfb4fb67a1 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 0000000000..e5585e75e8
--- /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 0000000000..c6d2c45d80
--- /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 0000000000..f70a4f064c
--- /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 bc4eed3d75..76b2965905 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 f657de20e3..0000000000
--- 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 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'
-);
diff --git a/perl/header_templates/fixed_prefix.template.pl b/perl/header_templates/fixed_prefix.template.pl
new file mode 100644
index 0000000000..857b4391a4
--- /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 0000000000..9d28b3d863
--- /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.