GIT_EXEC_PATH=`pwd`
PATH=`pwd`:$PATH
- GITPERLLIB=`pwd`/perl/blib/lib
+ GITPERLLIB=`pwd`/perl/build/lib
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
+ libraries not being where you'd like them if they're expected to be
+ used by things other than Git itself.
+
+ Manually supplying a perllibdir prefix should fix this, if this is
+ a problem you care about, e.g.:
+
+ prefix=/usr perllibdir=/usr/$(/usr/bin/perl -MConfig -wle 'print substr $Config{installsitelib}, 1 + length $Config{siteprefixexp}')
+
+ 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.
+
- 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 PERL_PATH to the path of your Perl binary (usually /usr/bin/perl).
#
-# Define NO_PERL_MAKEMAKER if you cannot use Makefiles generated by perl's
-# MakeMaker (e.g. using ActiveState under Cygwin).
-#
# Define NO_PERL if you do not want Perl scripts or libraries at all.
#
# Define PYTHON_PATH to the path of your Python binary (often /usr/bin/python
mergetoolsdir = $(gitexecdir)/mergetools
sharedir = $(prefix)/share
gitwebdir = $(sharedir)/gitweb
+perllibdir = $(sharedir)/perl5
localedir = $(sharedir)/locale
template_dir = share/git-core/templates
htmldir = $(prefix)/share/doc/git-doc
infodir_relative = $(patsubst $(prefix)/%,%,$(infodir))
htmldir_relative = $(patsubst $(prefix)/%,%,$(htmldir))
-export prefix bindir sharedir sysconfdir gitwebdir localedir
+export prefix bindir sharedir sysconfdir gitwebdir perllibdir localedir
CC = cc
AR = ar
LIB_OBJS += compat/sha1-chunked.o
BASIC_CFLAGS += -DSHA1_MAX_BLOCK_SIZE="$(SHA1_MAX_BLOCK_SIZE)"
endif
-ifdef NO_PERL_MAKEMAKER
- export NO_PERL_MAKEMAKER
-endif
ifdef NO_HSTRERROR
COMPAT_CFLAGS += -DNO_HSTRERROR
COMPAT_OBJS += compat/hstrerror.o
DESTDIR_SQ = $(subst ','\'',$(DESTDIR))
bindir_SQ = $(subst ','\'',$(bindir))
bindir_relative_SQ = $(subst ','\'',$(bindir_relative))
+mandir_SQ = $(subst ','\'',$(mandir))
mandir_relative_SQ = $(subst ','\'',$(mandir_relative))
infodir_relative_SQ = $(subst ','\'',$(infodir_relative))
+perllibdir_SQ = $(subst ','\'',$(perllibdir))
localedir_SQ = $(subst ','\'',$(localedir))
gitexecdir_SQ = $(subst ','\'',$(gitexecdir))
template_dir_SQ = $(subst ','\'',$(template_dir))
ifndef NO_TCLTK
$(QUIET_SUBDIR0)git-gui $(QUIET_SUBDIR1) gitexecdir='$(gitexec_instdir_SQ)' all
$(QUIET_SUBDIR0)gitk-git $(QUIET_SUBDIR1) all
-endif
-ifndef NO_PERL
- $(QUIET_SUBDIR0)perl $(QUIET_SUBDIR1) PERL_PATH='$(PERL_PATH_SQ)' prefix='$(prefix_SQ)' localedir='$(localedir_SQ)' all
endif
$(QUIET_SUBDIR0)templates $(QUIET_SUBDIR1) SHELL_PATH='$(SHELL_PATH_SQ)' PERL_PATH='$(PERL_PATH_SQ)'
SCRIPT_DEFINES = $(SHELL_PATH_SQ):$(DIFF_SQ):$(GIT_VERSION):\
$(localedir_SQ):$(NO_CURL):$(USE_GETTEXT_SCHEME):$(SANE_TOOL_PATH_SQ):\
- $(gitwebdir_SQ):$(PERL_PATH_SQ):$(SANE_TEXT_GREP):$(PAGER_ENV)
+ $(gitwebdir_SQ):$(PERL_PATH_SQ):$(SANE_TEXT_GREP):$(PAGER_ENV):\
+ $(perllibdir_SQ)
define cmd_munge_script
$(RM) $@ $@+ && \
sed -e '1s|#!.*/sh|#!$(SHELL_PATH_SQ)|' \
$(SCRIPT_PERL_GEN): GIT-BUILD-OPTIONS
ifndef NO_PERL
-$(SCRIPT_PERL_GEN): perl/perl.mak
-
-perl/perl.mak: perl/PM.stamp
-
-perl/PM.stamp: FORCE
- @$(FIND) perl -type f -name '*.pm' | sort >$@+ && \
- $(PERL_PATH) -V >>$@+ && \
- { cmp $@+ $@ >/dev/null 2>/dev/null || mv $@+ $@; } && \
- $(RM) $@+
-
-perl/perl.mak: GIT-CFLAGS GIT-PREFIX perl/Makefile perl/Makefile.PL
- $(QUIET_SUBDIR0)perl $(QUIET_SUBDIR1) PERL_PATH='$(PERL_PATH_SQ)' prefix='$(prefix_SQ)' $(@F)
+$(SCRIPT_PERL_GEN):
-PERL_DEFINES = $(PERL_PATH_SQ):$(PERLLIB_EXTRA_SQ)
-$(SCRIPT_PERL_GEN): % : %.perl perl/perl.mak GIT-PERL-DEFINES GIT-VERSION-FILE
+PERL_DEFINES = $(PERL_PATH_SQ):$(PERLLIB_EXTRA_SQ):$(perllibdir_SQ)
+$(SCRIPT_PERL_GEN): % : %.perl GIT-PERL-DEFINES GIT-VERSION-FILE
$(QUIET_GEN)$(RM) $@ $@+ && \
- INSTLIBDIR=`MAKEFLAGS= $(MAKE) -C perl -s --no-print-directory instlibdir` && \
+ INSTLIBDIR='$(perllibdir_SQ)' && \
INSTLIBDIR_EXTRA='$(PERLLIB_EXTRA_SQ)' && \
INSTLIBDIR="$$INSTLIBDIR$${INSTLIBDIR_EXTRA:+:$$INSTLIBDIR_EXTRA}" && \
sed -e '1{' \
po/build/locale/%/LC_MESSAGES/git.mo: po/%.po
$(QUIET_MSGFMT)mkdir -p $(dir $@) && $(MSGFMT) -o $@ $<
+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))
+
+ifndef NO_PERL
+all:: $(LIB_PERL_GEN)
+endif
+
+perl/build/lib/%.pm: perl/%.pm
+ $(QUIET_GEN)mkdir -p $(dir $@) && \
+ sed -e 's|@@LOCALEDIR@@|$(localedir_SQ)|g' < $< > $@
+
+perl/build/man/man3/Git.3pm: perl/Git.pm
+ $(QUIET_GEN)mkdir -p $(dir $@) && \
+ pod2man $< $@
+
FIND_SOURCE_FILES = ( \
git ls-files \
'*.[hcS]' \
(cd '$(DESTDIR_SQ)$(localedir_SQ)' && umask 022 && $(TAR) xof -)
endif
ifndef NO_PERL
- $(MAKE) -C perl prefix='$(prefix_SQ)' DESTDIR='$(DESTDIR_SQ)' install
+ $(INSTALL) -d -m 755 '$(DESTDIR_SQ)$(perllibdir_SQ)'
+ (cd perl/build/lib && $(TAR) cf - .) | \
+ (cd '$(DESTDIR_SQ)$(perllibdir_SQ)' && umask 022 && $(TAR) xof -)
$(MAKE) -C gitweb install
endif
ifndef NO_TCLTK
install-gitweb:
$(MAKE) -C gitweb install
-install-doc:
+install-doc: install-man-perl
$(MAKE) -C Documentation install
-install-man:
+install-man: install-man-perl
$(MAKE) -C Documentation install-man
+install-man-perl: perl/build/man/man3/Git.3pm
+ $(INSTALL) -d -m 755 '$(DESTDIR_SQ)$(mandir_SQ)/man3'
+ (cd perl/build/man/man3 && $(TAR) cf - .) | \
+ (cd '$(DESTDIR_SQ)$(mandir_SQ)/man3' && umask 022 && $(TAR) xof -)
+
install-html:
$(MAKE) -C Documentation install-html
$(MAKE) -C Documentation/ clean
ifndef NO_PERL
$(MAKE) -C gitweb clean
- $(MAKE) -C perl clean
+ $(RM) -r perl/build/
endif
$(MAKE) -C templates/ clean
$(MAKE) -C t/ clean
use 5.008;
use strict;
use warnings;
-use Error qw(:try);
+use Git::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 Error qw(:try);
+use Git::Error qw(:try);
use Cwd qw(abs_path cwd);
use Git;
use Git::I18N;
-perl.mak
-perl.mak.old
-MYMETA.json
-MYMETA.yml
-blib
-blibdirs
-pm_to_blib
-PM.stamp
+/build/
use Carp qw(carp croak); # but croak is bad - throw instead
-use Error qw(:try);
+use Git::Error qw(:try);
use Cwd qw(abs_path cwd);
use IPC::Open2 qw(open2);
use Fcntl qw(SEEK_SET SEEK_CUR);
--- /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
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));
+++ /dev/null
-#
-# 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
+++ /dev/null
-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'
-);
+++ /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
#!/usr/bin/perl
-use lib '../../perl/blib/lib';
+use lib '../../perl/build/lib';
use strict;
use warnings;
use JSON;
fi
fi
-GITPERLLIB="$GIT_BUILD_DIR"/perl/blib/lib:"$GIT_BUILD_DIR"/perl/blib/arch/auto/Git
+GITPERLLIB="$GIT_BUILD_DIR"/perl/build/lib
export GITPERLLIB
test -d "$GIT_BUILD_DIR"/templates/blt || {
error "You haven't built things yet, have you?"
GIT_TEMPLATE_DIR='@@BUILD_DIR@@/templates/blt'
export GIT_TEMPLATE_DIR
fi
-GITPERLLIB='@@BUILD_DIR@@/perl/blib/lib'"${GITPERLLIB:+:$GITPERLLIB}"
+GITPERLLIB='@@BUILD_DIR@@/perl/build/lib'"${GITPERLLIB:+:$GITPERLLIB}"
GIT_TEXTDOMAINDIR='@@BUILD_DIR@@/po/build/locale'
PATH='@@BUILD_DIR@@/bin-wrappers:'"$PATH"