Clean-up to various pieces of Perl code we have.
* ab/perl-fixes:
perl Git::LoadCPAN: emit better errors under NO_PERL_CPAN_FALLBACKS
Makefile: add NO_PERL_CPAN_FALLBACKS knob
perl: move the perl/Git/FromCPAN tree to perl/FromCPAN
perl: generalize the Git::LoadCPAN facility
perl: move CPAN loader wrappers to another namespace
perl: update our copy of Mail::Address
perl: update our ancient copy of Error.pm
git-send-email: unconditionally use Net::{SMTP,Domain}
Git.pm: hard-depend on the File::{Temp,Spec} modules
gitweb: hard-depend on the Digest::MD5 5.8 module
Git.pm: add the "use warnings" pragma
Git.pm: remove redundant "use strict" from sub-package
perl: *.pm files should not have the executable bit
export GIT_EXEC_PATH PATH GITPERLLIB
- By default (unless NO_PERL is provided) Git will ship various perl
- scripts & libraries it needs. However, for simplicity it doesn't
- use the ExtUtils::MakeMaker toolchain to decide where to place the
- perl libraries. Depending on the system this can result in the perl
+ scripts. However, for simplicity it doesn't use the
+ ExtUtils::MakeMaker toolchain to decide where to place the perl
+ libraries. Depending on the system this can result in the perl
libraries not being where you'd like them if they're expected to be
used by things other than Git itself.
Will result in e.g. perllibdir=/usr/share/perl/5.26.1 on Debian,
perllibdir=/usr/share/perl5 (which we'd use by default) on CentOS.
+ - Unless NO_PERL is provided Git will ship various perl libraries it
+ needs. Distributors of Git will usually want to set
+ NO_PERL_CPAN_FALLBACKS if NO_PERL is not provided to use their own
+ copies of the CPAN modules Git needs.
+
- Git is reasonably self-sufficient, but does depend on a few external
programs and libraries. Git can be used without most of them by adding
the approriate "NO_<LIBRARY>=YesPlease" to the make command line or
#
# Define NO_PERL if you do not want Perl scripts or libraries at all.
#
+# Define NO_PERL_CPAN_FALLBACKS if you do not want to install bundled
+# copies of CPAN modules that serve as a fallback in case the modules
+# are not available on the system. This option is intended for
+# distributions that want to use their packaged versions of Perl
+# modules, instead of the fallbacks shipped with Git.
+#
# Define PYTHON_PATH to the path of your Python binary (often /usr/bin/python
# but /usr/bin/python2.7 on some platforms).
#
LIB_PERL := $(wildcard perl/Git.pm perl/Git/*.pm perl/Git/*/*.pm perl/Git/*/*/*.pm)
LIB_PERL_GEN := $(patsubst perl/%.pm,perl/build/lib/%.pm,$(LIB_PERL))
+LIB_CPAN := $(wildcard perl/FromCPAN/*.pm perl/FromCPAN/*/*.pm)
+LIB_CPAN_GEN := $(patsubst perl/%.pm,perl/build/lib/%.pm,$(LIB_CPAN))
ifndef NO_PERL
all:: $(LIB_PERL_GEN)
+ifndef NO_PERL_CPAN_FALLBACKS
+all:: $(LIB_CPAN_GEN)
+endif
+NO_PERL_CPAN_FALLBACKS_SQ = $(subst ','\'',$(NO_PERL_CPAN_FALLBACKS))
endif
perl/build/lib/%.pm: perl/%.pm
$(QUIET_GEN)mkdir -p $(dir $@) && \
- sed -e 's|@@LOCALEDIR@@|$(localedir_SQ)|g' < $< > $@
+ sed -e 's|@@LOCALEDIR@@|$(localedir_SQ)|g' \
+ -e 's|@@NO_PERL_CPAN_FALLBACKS@@|$(NO_PERL_CPAN_FALLBACKS_SQ)|g' \
+ < $< > $@
perl/build/man/man3/Git.3pm: perl/Git.pm
$(QUIET_GEN)mkdir -p $(dir $@) && \
use 5.008;
use strict;
use warnings;
-use Git::Error qw(:try);
+use Git::LoadCPAN::Error qw(:try);
use File::Basename qw(dirname);
use File::Copy;
use File::Find;
use Term::ANSIColor;
use File::Temp qw/ tempdir tempfile /;
use File::Spec::Functions qw(catdir catfile);
-use Git::Error qw(:try);
+use Git::LoadCPAN::Error qw(:try);
use Cwd qw(abs_path cwd);
use Git;
use Git::I18N;
-use Git::Mail::Address;
+use Net::Domain ();
+use Net::SMTP ();
+use Git::LoadCPAN::Mail::Address;
Getopt::Long::Configure qw/ pass_through /;
sub maildomain_net {
my $maildomain;
- if (eval { require Net::Domain; 1 }) {
- my $domain = Net::Domain::domainname();
- $maildomain = $domain if valid_fqdn($domain);
- }
+ my $domain = Net::Domain::domainname();
+ $maildomain = $domain if valid_fqdn($domain);
return $maildomain;
}
sub maildomain_mta {
my $maildomain;
- if (eval { require Net::SMTP; 1 }) {
- for my $host (qw(mailhost localhost)) {
- my $smtp = Net::SMTP->new($host);
- if (defined $smtp) {
- my $domain = $smtp->domain;
- $smtp->quit;
+ for my $host (qw(mailhost localhost)) {
+ my $smtp = Net::SMTP->new($host);
+ if (defined $smtp) {
+ my $domain = $smtp->domain;
+ $smtp->quit;
- $maildomain = $domain if valid_fqdn($domain);
+ $maildomain = $domain if valid_fqdn($domain);
- last if $maildomain;
- }
+ last if $maildomain;
}
}
------------
- Core git tools
- - Perl
+ - Perl 5.8
- Perl modules: CGI, Encode, Fcntl, File::Find, File::Basename.
- web server
The following optional Perl modules are required for extra features
- - Digest::MD5 - for gravatar support
- CGI::Fast and FCGI - for running gitweb as FastCGI script
- HTML::TagCloud - for fancy tag cloud in project list view
- HTTP::Date or Time::ParseDate - to support If-Modified-Since for feeds
use File::Find qw();
use File::Basename qw(basename);
use Time::HiRes qw(gettimeofday tv_interval);
+use Digest::MD5 qw(md5_hex);
+
binmode STDOUT, ':utf8';
if (!defined($CGI::VERSION) || $CGI::VERSION < 4.08) {
# Currently available providers are gravatar and picon.
# If an unknown provider is specified, the feature is disabled.
- # Gravatar depends on Digest::MD5.
# Picon currently relies on the indiana.edu database.
# To enable system wide have in $GITWEB_CONFIG
our @snapshot_fmts = gitweb_get_feature('snapshot');
@snapshot_fmts = filter_snapshot_fmts(@snapshot_fmts);
- # check that the avatar feature is set to a known provider name,
- # and for each provider check if the dependencies are satisfied.
- # if the provider name is invalid or the dependencies are not met,
- # reset $git_avatar to the empty string.
our ($git_avatar) = gitweb_get_feature('avatar');
- if ($git_avatar eq 'gravatar') {
- $git_avatar = '' unless (eval { require Digest::MD5; 1; });
- } elsif ($git_avatar eq 'picon') {
- # no dependencies
- } else {
- $git_avatar = '';
- }
+ $git_avatar = '' unless $git_avatar =~ /^(?:gravatar|picon)$/s;
our @extra_branch_refs = gitweb_get_feature('extra-branch-refs');
@extra_branch_refs = filter_and_validate_refs (@extra_branch_refs);
my $size = shift;
$avatar_cache{$email} ||=
"//www.gravatar.com/avatar/" .
- Digest::MD5::md5_hex($email) . "?s=";
+ md5_hex($email) . "?s=";
return $avatar_cache{$email} . $size;
}
--- /dev/null
+/Error.pm whitespace=-blank-at-eof
--- /dev/null
+# 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 warnings;
+
+use vars qw($VERSION);
+use 5.004;
+
+$VERSION = "0.17025";
+
+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
+
+use Scalar::Util ();
+
+sub import {
+ shift;
+ my @tags = @_;
+ local $Exporter::ExportLevel = $Exporter::ExportLevel + 1;
+
+ @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
+# 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;
+}
+
+
+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;
+
+use vars qw($VERSION);
+
+$VERSION = "0.17025";
+
+@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 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]->($err));
+ $i -= 2;
+ next CATCHLOOP;
+ }
+ elsif(Scalar::Util::blessed($err) && $err->isa($pkg)) {
+ $code = $catch->[$i+1];
+ while(1) {
+ my $more = 0;
+ local($Error::THROWN, $@);
+ my $ok = eval {
+ $@ = $err;
+ 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 = $@ || $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;
+ local($Error::THROWN, $@);
+ my $ok = eval {
+ $@ = $err;
+ 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 = $@ || $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 = $@ || $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 (Scalar::Util::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;
+
+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);
+
+ 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 "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. The error will also be available in C<$@>.
+
+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. The error will also be available in C<$@>.
+
+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 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 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.
+
+ -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 Error->new()
+
+See the Error::Simple documentation.
+
+=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
+
+=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
+
+=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
+
+=head2 Error::Simple
+
+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.
+
+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)
+
+
+=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.
+ }
+
+=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.
+
+=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>.
+
+C<:warndie> handlers added by Paul Evans <leonerd@leonerd.org.uk>
+
+=head1 MAINTAINER
+
+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
--- /dev/null
+# 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;
use 5.008;
use strict;
+use warnings;
+use File::Temp ();
+use File::Spec ();
BEGIN {
use Carp qw(carp croak); # but croak is bad - throw instead
-use Git::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);
};
if ($dir) {
- _verify_require();
File::Spec->file_name_is_absolute($dir) or $dir = $opts{Directory} . '/' . $dir;
$opts{Repository} = abs_path($dir);
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}) {
$$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>.
# Pipe implementation for ActiveState Perl.
package Git::activestate_pipe;
-use strict;
sub TIEHANDLE {
my ($class, @params) = @_;
+++ /dev/null
-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;
+++ /dev/null
-# 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
+++ /dev/null
-# 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;
--- /dev/null
+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;
--- /dev/null
+package Git::LoadCPAN::Error;
+use 5.008;
+use strict;
+use warnings;
+use Git::LoadCPAN (
+ module => 'Error',
+ import => 1,
+);
+
+1;
--- /dev/null
+package Git::LoadCPAN::Mail::Address;
+use 5.008;
+use strict;
+use warnings;
+use Git::LoadCPAN (
+ module => 'Mail::Address',
+ import => 0,
+);
+
+1;
+++ /dev/null
-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;