From 20d2a30f8ffe14deb09b4e6fc7b70ead53b315f0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=C3=86var=20Arnfj=C3=B6r=C3=B0=20Bjarmason?= Date: Sun, 10 Dec 2017 21:13:33 +0000 Subject: Makefile: replace perl/Makefile.PL with simple make rules MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Replace the perl/Makefile.PL and the fallback perl/Makefile used under NO_PERL_MAKEMAKER=NoThanks with a much simpler implementation heavily inspired by how the i18n infrastructure's build process works[1]. The reason for having the Makefile.PL in the first place is that it was initially[2] building a perl C binding to interface with libgit, this functionality, that was removed[3] before Git.pm ever made it to the master branch. We've since since started maintaining a fallback perl/Makefile, as MakeMaker wouldn't work on some platforms[4]. That's just the tip of the iceberg. We have the PM.stamp hack in the top-level Makefile[5] to detect whether we need to regenerate the perl/perl.mak, which I fixed just recently to deal with issues like the perl version changing from under us[6]. There is absolutely no reason for why this needs to be so complex anymore. All we're getting out of this elaborate Rube Goldberg machine was copying perl/* to perl/blib/* as we do a string-replacement on the *.pm files to hardcode @@LOCALEDIR@@ in the source, as well as pod2man-ing Git.pm & friends. So replace the whole thing with something that's pretty much a copy of how we generate po/build/**.mo from po/*.po, just with a small sed(1) command instead of msgfmt. As that's being done rename the files from *.pm to *.pmc just to indicate that they're generated (see "perldoc -f require"). While I'm at it, change the fallback for Error.pm from being something where we'll ship our own Error.pm if one doesn't exist at build time to one where we just use a Git::Error wrapper that'll always prefer the system-wide Error.pm, only falling back to our own copy if it really doesn't exist at runtime. It's now shipped as Git::FromCPAN::Error, making it easy to add other modules to Git::FromCPAN::* in the future if that's needed. Functional changes: * This will not always install into perl's idea of its global "installsitelib". This only potentially matters for packagers that need to expose Git.pm for non-git use, and as explained in the INSTALL file there's a trivial workaround. * The scripts themselves will 'use lib' the target directory, but if INSTLIBDIR is set it overrides it. It doesn't have to be this way, it could be set in addition to INSTLIBDIR, but my reading of [7] is that this is the desired behavior. * We don't build man pages for all of the perl modules as we used to, only Git(3pm). As discussed on-list[8] that we were building installed manpages for purely internal APIs like Git::I18N or private-Error.pm was always a bug anyway, and all the Git::SVN::* ones say they're internal APIs. There are apparently external users of Git.pm, but I don't expect there to be any of the others. As a side-effect of these general changes the perl documentation now only installed by install-{doc,man}, not a mere "install" as before. 1. 5e9637c629 ("i18n: add infrastructure for translating Git with gettext", 2011-11-18) 2. b1edc53d06 ("Introduce Git.pm (v4)", 2006-06-24) 3. 18b0fc1ce1 ("Git.pm: Kill Git.xs for now", 2006-09-23) 4. f848718a69 ("Make perl/ build procedure ActiveState friendly.", 2006-12-04) 5. ee9be06770 ("perl: detect new files in MakeMaker builds", 2012-07-27) 6. c59c4939c2 ("perl: regenerate perl.mak if perl -V changes", 2017-03-29) 7. 0386dd37b1 ("Makefile: add PERLLIB_EXTRA variable that adds to default perl path", 2013-11-15) 8. 87bmjjv1pu.fsf@evledraar.booking.com ("Re: [PATCH] Makefile: replace perl/Makefile.PL with simple make rules" Signed-off-by: Ævar Arnfjörð Bjarmason Signed-off-by: Junio C Hamano diff --git a/INSTALL b/INSTALL index ffb071e..808e07b 100644 --- a/INSTALL +++ b/INSTALL @@ -84,9 +84,24 @@ Issues of note: 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_=YesPlease" to the make command line or diff --git a/Makefile b/Makefile index e53750c..ba6607b 100644 --- a/Makefile +++ b/Makefile @@ -295,9 +295,6 @@ all:: # # 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 @@ -473,6 +470,7 @@ gitexecdir = libexec/git-core 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 @@ -486,7 +484,7 @@ mandir_relative = $(patsubst $(prefix)/%,%,$(mandir)) 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 @@ -1525,9 +1523,6 @@ ifdef SHA1_MAX_BLOCK_SIZE 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 @@ -1714,8 +1709,10 @@ ETC_GITATTRIBUTES_SQ = $(subst ','\'',$(ETC_GITATTRIBUTES)) 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)) @@ -1825,9 +1822,6 @@ 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)' please_set_SHELL_PATH_to_a_more_modern_shell: @@ -1907,7 +1901,8 @@ common-cmds.h: $(wildcard Documentation/git-*.txt) 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)|' \ @@ -1951,29 +1946,17 @@ git.res: git.rc GIT-VERSION-FILE $(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_EXTRA='$(PERLLIB_EXTRA_SQ)' && \ INSTLIBDIR="$$INSTLIBDIR$${INSTLIBDIR_EXTRA:+:$$INSTLIBDIR_EXTRA}" && \ sed -e '1{' \ -e ' s|#!.*perl|#!$(PERL_PATH_SQ)|' \ -e ' h' \ - -e ' s=.*=use lib (split(/$(pathsep)/, $$ENV{GITPERLLIB} || "'"$$INSTLIBDIR"'"));=' \ + -e ' s=.*=use lib (split(/$(pathsep)/, $$ENV{GITPERLLIB} || "'"$$INSTLIBDIR"'" || "'"$(perllibdir_SQ)"'"));=' \ -e ' H' \ -e ' x' \ -e '}' \ @@ -2291,6 +2274,21 @@ endif po/build/locale/%/LC_MESSAGES/git.mo: po/%.po $(QUIET_MSGFMT)mkdir -p $(dir $@) && $(MSGFMT) -o $@ $< +PMFILES := $(wildcard perl/*.pm perl/*/*.pm perl/*/*/*.pm perl/*/*/*/*.pm) +PMCFILES := $(patsubst perl/%.pm,perl/build/lib/%.pmc,$(PMFILES)) + +ifndef NO_PERL +all:: $(PMCFILES) +endif + +perl/build/lib/%.pmc: 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]' \ @@ -2550,7 +2548,9 @@ ifndef NO_GETTEXT (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 @@ -2600,12 +2600,17 @@ endif 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 @@ -2697,7 +2702,7 @@ clean: profile-clean coverage-clean $(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 diff --git a/contrib/examples/git-difftool.perl b/contrib/examples/git-difftool.perl index df59bdf..fb0fd0b 100755 --- a/contrib/examples/git-difftool.perl +++ b/contrib/examples/git-difftool.perl @@ -13,7 +13,7 @@ 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; diff --git a/git-send-email.perl b/git-send-email.perl index 2208dcc..88a0edc 100755 --- a/git-send-email.perl +++ b/git-send-email.perl @@ -26,7 +26,7 @@ use Text::ParseWords; 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; diff --git a/perl/.gitignore b/perl/.gitignore index 0f1fc27..84c048a 100644 --- a/perl/.gitignore +++ b/perl/.gitignore @@ -1,8 +1 @@ -perl.mak -perl.mak.old -MYMETA.json -MYMETA.yml -blib -blibdirs -pm_to_blib -PM.stamp +/build/ diff --git a/perl/Git.pm b/perl/Git.pm index ffa09ac..02a3871 100644 --- a/perl/Git.pm +++ b/perl/Git.pm @@ -101,7 +101,7 @@ increase notwithstanding). 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); diff --git a/perl/Git/Error.pm b/perl/Git/Error.pm new file mode 100644 index 0000000..5874672 --- /dev/null +++ b/perl/Git/Error.pm @@ -0,0 +1,46 @@ +package Git::Error; +use 5.008; +use strict; +use warnings; + +=head1 NAME + +Git::Error - Wrapper for the L module, in case it's not installed + +=head1 DESCRIPTION + +Wraps the import function for the L module. + +This module is only intended to be used for code shipping in the +C 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; + }; + + local @_ = ($caller, @_); + goto &Error::import; +} + +1; diff --git a/perl/Git/FromCPAN/Error.pm b/perl/Git/FromCPAN/Error.pm new file mode 100644 index 0000000..6098135 --- /dev/null +++ b/perl/Git/FromCPAN/Error.pm @@ -0,0 +1,827 @@ +# Error.pm +# +# 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. +# +# Based on my original Error.pm, and Exceptions.pm by Peter Seibel +# and adapted by Jesse Glick . +# +# 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 and +# Peter Seibel + +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 package provides two interfaces. Firstly C provides +a procedural interface to exception handling. Secondly C 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 should not be thrown directly, but the +user should throw errors from a sub-class of C. + +=head1 PROCEDURAL INTERFACE + +C exports subroutines to perform exception handling. These will +be exported if the C<:try> tag is used in the C line. + +=over 4 + +=item try BLOCK CLAUSES + +C 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 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-Eisa(CLASS)> +to be caught and handled by evaluating C. + +C 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-Ethrow> + +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 is looking for a handler, if an except clause is found +C 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 + +When evaluated C 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 either after the code in the try block has +successfully completed, or if the try block throws an error then +C 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 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 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 package +to associate the error with the object. + +The C 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 object and throw an error, which will be caught +by a surrounding C block, if there is one. Otherwise it will cause +the program to exit. + +C may also be called on an existing error to re-throw it. + +=item with ( [ ARGS ] ) + +Create a new C object and returns it. This is defined for +syntactic sugar, eg + + die with Some::Error ( ... ); + +=item record ( [ ARGS ] ) + +Create a new C 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 + +=item flush ( [ PACKAGE ] ) + +Flush the last error created, or the last error associated with +C.It is necessary to clear the error stack before exiting the +package or uncaught errors generated using C 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 returns a string created by calling +C. If the variable was zero the C 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 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 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 + +The code that inspired me to write this was originally written by +Peter Seibel and adapted by Jesse Glick +. + +=head1 MAINTAINER + +Shlomi Fish + +=head1 PAST MAINTAINERS + +Arun Kumar U + +=cut diff --git a/perl/Git/I18N.pm b/perl/Git/I18N.pm index 836a5c2..dba96ff 100644 --- a/perl/Git/I18N.pm +++ b/perl/Git/I18N.pm @@ -18,7 +18,7 @@ our @EXPORT_OK = @EXPORT; sub __bootstrap_locale_messages { our $TEXTDOMAIN = 'git'; - our $TEXTDOMAINDIR = $ENV{GIT_TEXTDOMAINDIR} || '++LOCALEDIR++'; + our $TEXTDOMAINDIR = $ENV{GIT_TEXTDOMAINDIR} || '@@LOCALEDIR@@'; require POSIX; POSIX->import(qw(setlocale)); diff --git a/perl/Makefile b/perl/Makefile deleted file mode 100644 index f657de2..0000000 --- a/perl/Makefile +++ /dev/null @@ -1,90 +0,0 @@ -# -# Makefile for perl support modules and routine -# -makfile:=perl.mak -modules = - -PERL_PATH_SQ = $(subst ','\'',$(PERL_PATH)) -prefix_SQ = $(subst ','\'',$(prefix)) -localedir_SQ = $(subst ','\'',$(localedir)) - -ifndef V - QUIET = @ -endif - -all install instlibdir: $(makfile) - $(QUIET)$(MAKE) -f $(makfile) $@ - -clean: - $(QUIET)test -f $(makfile) && $(MAKE) -f $(makfile) $@ || exit 0 - $(RM) ppport.h - $(RM) $(makfile) - $(RM) $(makfile).old - $(RM) PM.stamp - -$(makfile): PM.stamp - -ifdef NO_PERL_MAKEMAKER -instdir_SQ = $(subst ','\'',$(prefix)/lib) - -modules += Git -modules += Git/I18N -modules += Git/IndexInfo -modules += Git/Packet -modules += Git/SVN -modules += Git/SVN/Memoize/YAML -modules += Git/SVN/Fetcher -modules += Git/SVN/Editor -modules += Git/SVN/GlobSpec -modules += Git/SVN/Log -modules += Git/SVN/Migration -modules += Git/SVN/Prompt -modules += Git/SVN/Ra -modules += Git/SVN/Utils - -$(makfile): ../GIT-CFLAGS Makefile - echo all: private-Error.pm Git.pm Git/I18N.pm > $@ - set -e; \ - for i in $(modules); \ - do \ - if test $$i = $${i%/*}; \ - then \ - subdir=; \ - else \ - subdir=/$${i%/*}; \ - fi; \ - echo ' $(RM) blib/lib/'$$i'.pm' >> $@; \ - echo ' mkdir -p blib/lib'$$subdir >> $@; \ - echo ' cp '$$i'.pm blib/lib/'$$i'.pm' >> $@; \ - done - echo ' $(RM) blib/lib/Error.pm' >> $@ - '$(PERL_PATH_SQ)' -MError -e 'exit($$Error::VERSION < 0.15009)' || \ - echo ' cp private-Error.pm blib/lib/Error.pm' >> $@ - echo install: >> $@ - set -e; \ - for i in $(modules); \ - do \ - if test $$i = $${i%/*}; \ - then \ - subdir=; \ - else \ - subdir=/$${i%/*}; \ - fi; \ - echo ' $(RM) "$$(DESTDIR)$(instdir_SQ)/'$$i'.pm"' >> $@; \ - echo ' mkdir -p "$$(DESTDIR)$(instdir_SQ)'$$subdir'"' >> $@; \ - echo ' cp '$$i'.pm "$$(DESTDIR)$(instdir_SQ)/'$$i'.pm"' >> $@; \ - done - echo ' $(RM) "$$(DESTDIR)$(instdir_SQ)/Error.pm"' >> $@ - '$(PERL_PATH_SQ)' -MError -e 'exit($$Error::VERSION < 0.15009)' || \ - echo ' cp private-Error.pm "$$(DESTDIR)$(instdir_SQ)/Error.pm"' >> $@ - echo instlibdir: >> $@ - echo ' echo $(instdir_SQ)' >> $@ -else -$(makfile): Makefile.PL ../GIT-CFLAGS - $(PERL_PATH) $< PREFIX='$(prefix_SQ)' INSTALL_BASE='' --localedir='$(localedir_SQ)' -endif - -# this is just added comfort for calling make directly in perl dir -# (even though GIT-CFLAGS aren't used yet. If ever) -../GIT-CFLAGS: - $(MAKE) -C .. GIT-CFLAGS diff --git a/perl/Makefile.PL b/perl/Makefile.PL deleted file mode 100644 index 3f29ba9..0000000 --- a/perl/Makefile.PL +++ /dev/null @@ -1,62 +0,0 @@ -use strict; -use warnings; -use ExtUtils::MakeMaker; -use Getopt::Long; -use File::Find; - -# Don't forget to update the perl/Makefile, too. -# Don't forget to test with NO_PERL_MAKEMAKER=YesPlease - -# Sanity: die at first unknown option -Getopt::Long::Configure qw/ pass_through /; - -my $localedir = ''; -GetOptions("localedir=s" => \$localedir); - -sub MY::postamble { - return <<'MAKE_FRAG'; -instlibdir: - @echo '$(INSTALLSITELIB)' - -ifneq (,$(DESTDIR)) -ifeq (0,$(shell expr '$(MM_VERSION)' '>' 6.10)) -$(error ExtUtils::MakeMaker version "$(MM_VERSION)" is older than 6.11 and so \ - is likely incompatible with the DESTDIR mechanism. Try setting \ - NO_PERL_MAKEMAKER=1 instead) -endif -endif - -MAKE_FRAG -} - -# Find all the .pm files in "Git/" and Git.pm -my %pm; -find sub { - return unless /\.pm$/; - - # sometimes File::Find prepends a ./ Strip it. - my $pm_path = $File::Find::name; - $pm_path =~ s{^\./}{}; - - $pm{$pm_path} = '$(INST_LIBDIR)/'.$pm_path; -}, "Git", "Git.pm"; - - -# We come with our own bundled Error.pm. It's not in the set of default -# Perl modules so install it if it's not available on the system yet. -if ( !eval { require Error } || $Error::VERSION < 0.15009) { - $pm{'private-Error.pm'} = '$(INST_LIBDIR)/Error.pm'; -} - -# redirect stdout, otherwise the message "Writing perl.mak for Git" -# disrupts the output for the target 'instlibdir' -open STDOUT, ">&STDERR"; - -WriteMakefile( - NAME => 'Git', - VERSION_FROM => 'Git.pm', - PM => \%pm, - PM_FILTER => qq[\$(PERL) -pe "s<\\Q++LOCALEDIR++\\E><$localedir>"], - MAKEFILE => 'perl.mak', - INSTALLSITEMAN3DIR => '$(SITEPREFIX)/share/man/man3' -); diff --git a/perl/private-Error.pm b/perl/private-Error.pm deleted file mode 100644 index 6098135..0000000 --- a/perl/private-Error.pm +++ /dev/null @@ -1,827 +0,0 @@ -# Error.pm -# -# 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. -# -# Based on my original Error.pm, and Exceptions.pm by Peter Seibel -# and adapted by Jesse Glick . -# -# 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 and -# Peter Seibel - -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 package provides two interfaces. Firstly C provides -a procedural interface to exception handling. Secondly C 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 should not be thrown directly, but the -user should throw errors from a sub-class of C. - -=head1 PROCEDURAL INTERFACE - -C exports subroutines to perform exception handling. These will -be exported if the C<:try> tag is used in the C line. - -=over 4 - -=item try BLOCK CLAUSES - -C 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 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-Eisa(CLASS)> -to be caught and handled by evaluating C. - -C 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-Ethrow> - -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 is looking for a handler, if an except clause is found -C 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 - -When evaluated C 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 either after the code in the try block has -successfully completed, or if the try block throws an error then -C 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 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 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 package -to associate the error with the object. - -The C 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 object and throw an error, which will be caught -by a surrounding C block, if there is one. Otherwise it will cause -the program to exit. - -C may also be called on an existing error to re-throw it. - -=item with ( [ ARGS ] ) - -Create a new C object and returns it. This is defined for -syntactic sugar, eg - - die with Some::Error ( ... ); - -=item record ( [ ARGS ] ) - -Create a new C 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 - -=item flush ( [ PACKAGE ] ) - -Flush the last error created, or the last error associated with -C.It is necessary to clear the error stack before exiting the -package or uncaught errors generated using C 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 returns a string created by calling -C. If the variable was zero the C 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 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 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 - -The code that inspired me to write this was originally written by -Peter Seibel and adapted by Jesse Glick -. - -=head1 MAINTAINER - -Shlomi Fish - -=head1 PAST MAINTAINERS - -Arun Kumar U - -=cut diff --git a/t/perf/aggregate.perl b/t/perf/aggregate.perl index 1dbc85b..923044d 100755 --- a/t/perf/aggregate.perl +++ b/t/perf/aggregate.perl @@ -1,6 +1,6 @@ #!/usr/bin/perl -use lib '../../perl/blib/lib'; +use lib '../../perl/build/lib'; use strict; use warnings; use Git; diff --git a/t/test-lib.sh b/t/test-lib.sh index 116bd6a..85a0fab 100644 --- a/t/test-lib.sh +++ b/t/test-lib.sh @@ -919,7 +919,7 @@ then 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?" diff --git a/wrap-for-bin.sh b/wrap-for-bin.sh index 22b6e49..5842408 100644 --- a/wrap-for-bin.sh +++ b/wrap-for-bin.sh @@ -14,7 +14,7 @@ else 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" -- cgit v0.10.2-6-g49f6