diff options
34 files changed, 2692 insertions, 0 deletions
diff --git a/Build.PL b/Build.PL new file mode 100644 index 0000000..ccf7ee4 --- /dev/null +++ b/Build.PL @@ -0,0 +1,21 @@ +use strict; +use warnings; + +use File::Spec; +use lib File::Spec->catdir(File::Spec->curdir(), "inc"); + +use Test::Run::Builder; + +my $build = Test::Run::Builder->new( + 'module_name' => "Error", + 'requires' => + { + 'Scalar::Util' => 0, + 'perl' => "5.6.0", + 'warnings' => 0, + }, + 'license' => "perl", + 'dist_abstract' => 'Error/exception handling in an OO-ish way', + 'dist_author' => 'Shlomi Fish <shlomif@iglu.org.il>', +); +$build->create_build_script; diff --git a/ChangeLog b/ChangeLog new file mode 100644 index 0000000..4bfadab --- /dev/null +++ b/ChangeLog @@ -0,0 +1,285 @@ +May 08 2012 <shlomif@shlomifish.org> (Shlomi Fish) + + Error.pm #0.17018 + - Add a $VERSION variable for Error::Simple. + - thanks to Kevin Dawson for the report. + - Add scripts/bump-version-number.pl . + - This can be used to bump the version numbers globally. + +Feb 11 2012 <shlomif@shlomifish.org> (Shlomi Fish) + + - Bleadperl broke Error.pm's tests - + - https://rt.cpan.org/Ticket/Display.html?id=74770 + - Applied a patch to check for optional trailing periods. + - Thanks to ANDK for the report and RURBAN for the patch + +Dec 19 2009 <shlomif@iglu.org.il> (Shlomi Fish) + + Error.pm #0.17016 + - Mentioned the lack of compatibility of "use Error qw(:try)" with Moose. + Fixed: https://rt.cpan.org/Ticket/Display.html?id=46364 + - Added TryCatch and Try::Tiny to the "SEE ALSO". + - Add the WARNING that this module is no longer recommended. + +Jul 19 2008 <shlomif@iglu.org.il> (Shlomi Fish) + + Error.pm #0.17015 + - Added the "SEE ALSO" section to the Error.pm POD mentioning + Exception::Class and Error::Exception. + +May 24 2008 <shlomif@iglu.org.il> (Shlomi Fish) + + Error.pm #0.17014 + - Made Makefile.PL require perl-5.6.0 and above. + +May 22 2008 <shlomif@iglu.org.il> (Shlomi Fish) + + Error.pm #0.17013 + - Now building only on perl-5.6.0 and above. + - Added the line to the Build.PL + +Jan 25 2008 <shlomif@iglu.org.il> (Shlomi Fish) + + Error.pm #0.17012 + - Added some examples to the examples/ directory. + - Applied the patch from hchbaw to fix: + -//rt.cpan.org/Public/Bug/Display.html?id=32638 + - Thanks to hchbaw + +Dec 25 2007 <shlomif@iglu.org.il> (Shlomi Fish) + + Error.pm #0.17011 + - added 'warnings' to the dependencies in the Build.PL/Makefile.PL as + we are using it. + - changed the author in Makefile.PL/Build.PL from GBARR to SHLOMIF: + - http://rt.cpan.org/Public/Bug/Display.html?id=31861 + - Thanks to Michael Schwern + - added an empty line between the "__END__" and "=head1" in + lib/Error/Simple.pm for more pedantic POD parsers. + +Nov 22 2007 <shlomif@iglu.org.il> (Shlomi Fish) + + Error.pm #0.17010 + - moved the first Error->new() POD portion over to the POD at the bottom, and + deleted the second, identical POD portion. + - closing http://rt.cpan.org/Public/Bug/Display.html?id=30906 + ( "Duplicate Error->new() documentation" ) + +Aug 28 2007 <shlomif@iglu.org.il> (Shlomi Fish) + + Error.pm #0.17009 + - fixed http://rt.cpan.org/Public/Bug/Display.html?id=20643 by applying + a modified version of the patch by MAREKR with the t/12wrong-error-var.t + regression test. + +Oct 25 2006 <shlomif@iglu.org.il> (Shlomi Fish) + + Error.pm #0.17008 + - Added the empty PL_FILES paramaeter to ExtUtils::MakeMaker so it won't + attempt to run Build.PL. + +Oct 18 2006 <shlomif@iglu.org.il> (Shlomi Fish) + + Error.pm #0.17007 + - Added the "COPYRIGHT" section to the POD with the correct + license. (several people have asked me about what the license is.) + - Added the Build.PL file so we'll have license meta data in the + distribution. + +Oct 07 2006 <shlomif@iglu.org.il> (Shlomi Fish) + + Error.pm #0.17006 + - t/11rethrow.t - added the test file by Thomas Equeter. + - Changed to the more correct behevaiour that fixes the rethrowning + error by Thomas Equeter. + - see http://rt.cpan.org/Public/Bug/Display.html?id=21612 + - added t/pod.t to check for POD validity. + - added the t/pod-coverage.t file for POD coverage. + - added the missing POD. + - added "use strict" and "use warnings" to lib/Error/Simple.pm to make + CPANTS happy. + +Oct 03 2006 <shlomif@iglu.org.il> (Shlomi Fish) + + Error.pm #0.17005 + - t/09dollar-at.t - included in the distribution (it was not placed in + the MANIFEST previously. + - t/10throw-in-catch.t, t/Error.pm - Fixed: + http://rt.cpan.org/Public/Bug/Display.html?id=21884 when an error that + was thrown inside a catch or otherwise clause was not registered. + +Sep 01 2006 <leonerd@leonerd.org.uk> (Paul Evans) + + Error.pm #0.17004 + - t/08warndie.t: Various fixes: + Workaround for ActivePerl bug when dup2()ing to STDERR - close it first + Should fix https://rt.cpan.org/Public/Bug/Display.html?id=21080 but I + have no means to test it + Use __LINE__ rather than a custom function implemented using caller() + +Aug 20 2006 <leonerd@leonerd.org.uk> (Paul Evans) + + Error.pm #0.17003 + - Pass error in $@ as well as $_[0] to catch and otherwise blocks. + - t/08warndie.t: Various fixes for Win32: + Win32 can't open( HANDLE, "-|" ) - need manual pipe()/fork() workaround + Filename on Win32 is t\08warndie.t - need \Q in regexp to avoid + interpretation as an invalid octal character + +Aug 17 2006 <leonerd@leonerd.org.uk> (Paul Evans) + + Error.pm #0.17002 + - Documentation fix for Error::Simple constructor in example + - t/80warndie.t: Bugfix to open() call to work on perl 5.6 + +Jul 24 2006 <leonerd@leonerd.org.uk> (Paul Evans) + + Error.pm #0.17001 + - Bugfix to t/08warndie.t - Don't abuse $! for forcing "die"'s exit status + Fixes http://rt.cpan.org/Public/Bug/Display.html?id=20549 + +Jul 13 2006 <shlomif@iglu.org.il> (Shlomi Fish) + + Error.pm #0.17 + - Added some examples to the examples/ directory. + - Updated the MANIFEST. + +Jul 13 2006 <leonerd@leonerd.org.uk> (Paul Evans) + + Error.pm #0.16001 + - Added the :warndie tag and the internal Error::WarnDie package that + provides custom __WARN__ and __DIE__ handlers. + +Apr 24 2006 <shlomif@iglu.org.il> (Shlomi Fish) + + Error.pm #0.16 + - Bumped the version number to indicate a new number with no known + bugs. + +Apr 24 2006 <shlomif@iglu.org.il> (Shlomi Fish) + + Error.pm #0.15009 + - Added the flush() method from Alasdair Allan. + +Apr 07 2006 <shlomif@iglu.org.il> (Shlomi Fish) + + Error.pm #0.15008 + - Fixed a test in t/05text-errors-with-file-handles.t to work on + MS Windows due to File::Spec and require inconsistency. + +Apr 07 2006 <shlomif@iglu.org.il> (Shlomi Fish) + + Error.pm #0.15007 + - Fixed https://rt.cpan.org/Ticket/Display.html?id=3291 + +Apr 07 2006 <shlomif@iglu.org.il> (Shlomi Fish) + + Error.pm #0.15006 + - According to https://rt.cpan.org/Ticket/Display.html?id=6130 - made + the auto-conversion of textual errors to object customizable. + +Apr 03 2006 <shlomif@iglu.org.il> (Shlomi Fish) + + Error.pm #0.15005 + - Fixed the conversion of textual messages to Error::Simple when + they contain information about an open filehandle. (as reported in + http://rt.cpan.org/Ticket/Display.html?id=6130 ) + +Apr 02 2006 <shlomif@iglu.org.il> (Shlomi Fish) + + Error.pm #0.15004 + - Added POD to the lib/Error/Simple.pm module. + +Mar 31 2006 <shlomif@iglu.org.il> (Shlomi Fish) + + Error.pm #0.15003 + - Added the lib/Error/Simple.pm module (that just "use"'s Error) so + one can say "use base 'Error::Simple';' Added an appropriate test. + Fixes: http://rt.cpan.org/Public/Bug/Display.html?id=17841 + +Mar 30 2006 <shlomif@iglu.org.il> (Shlomi Fish) + + - Added Scalar::Util to the dependencies in Makefile.PL. + + Error.pm #0.15002 + - Fixed http://rt.cpan.org/Public/Bug/Display.html?id=18024 and a related + exception thrown because ->isa was called on something that was not + certainly an object. + + Error.pm #0.15001 + + - Moved Error.pm inside the distribution to reside under lib/. + +Oct 9 2001 <u_arunkumar@yahoo.com> (Arun Kumar U) + + Error.pm #0.15 + + - Removed the run_clauses calls from the stack trace + +May 12 2001 <u_arunkumar@yahoo.com> (Arun Kumar U) + + Error.pm #0.14 + + - Added overloading method for 'bool'. This was neccessary so that + examining the value of $@ after a eval block, returns a true + value + - Applied the diffs from Graham's code base + - Changed README with more information about the module + +Change 436 on 2000/03/29 by <gbarr@pobox.com> (Graham Barr) + + Added ppd stuff to MANIFEST and Makefile.PL + +Change 435 on 2000/03/29 by <gbarr@pobox.com> (Graham Barr) + + Changed README to contain examples from the POD + +Change 434 on 2000/03/29 by <gbarr@pobox.com> (Graham Barr) + + Documentation updates + removed experimental warning, too many users now to change too much. + +Change 422 on 2000/03/28 by <gbarr@pobox.com> (Graham Barr) + + Some tidy-ups + +Change 145 on 1998/05/31 by <gbarr@pobox.com> (Graham Barr) + + Errno.pm + - Separated run_clauses out into a sub + +Oct 28 1997 <gbarr@pobox.com> + + Error.pm #0.12 + + - Removed proceed clause + +Oct 27 1997 <gbarr@pobox.com> + + Error.pm #0.11 + + - Fixed calling of otherwise clause if there are no catch claues + +Oct 21 1997 <gbarr@pobox.com> + + Error.pm #0.10 + + - Added proceed clause, the return value from the proceed block + will be returned by throw. + - try will now return the result from the try block + or from the catch + - Changed except clause handling so that block is only evaluated + once, the first time the result is required. + - Changed catch and proceed blocks to accept two arguments. The + second argument is a reference to a scalar, which if set to true + will cause Error to continue looking for a catch/proceed block + when the block returns. + +Oct 19 1997 <gbarr@pobox.com> + + - Added associate method so that an existing error may be associated + with an object. + +Oct 10 1997 <gbarr@pobox.com> + + - Initial release for private viewing diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..e8e8f9e --- /dev/null +++ b/MANIFEST @@ -0,0 +1,34 @@ +Build.PL +ChangeLog +examples/example.pl +examples/next-in-loop/Error.pm-eval.pl +examples/next-in-loop/Error.pm-next-label.pl +examples/next-in-loop/Error.pm-next-out-of-catch.pl +examples/next-in-loop/Error.pm-next.pl +examples/next-in-loop/README +examples/warndie.pl +inc/Test/Run/Builder.pm +lib/Error.pm +lib/Error/Simple.pm +Makefile.PL +MANIFEST +META.yml Module meta-data (added by MakeMaker) +README +scripts/bump-version-number.pl +t/01throw.t +t/02order.t +t/03throw-non-Error.t +t/04use-base-Error-Simple.t +t/05text-errors-with-file-handles.t +t/06customize-text-throw.t +t/07try-in-obj-destructor.t +t/08warndie.t +t/09dollar-at.t +t/10throw-in-catch.t +t/11rethrow.t +t/12wrong-error-var.t +t/13except-arg0.t +t/lib/MyDie.pm +t/pod-coverage.t +t/pod.t +META.json diff --git a/META.json b/META.json new file mode 100644 index 0000000..b5cc777 --- /dev/null +++ b/META.json @@ -0,0 +1,55 @@ +{ + "abstract" : "Error/exception handling in an OO-ish way", + "author" : [ + "Shlomi Fish <shlomif@iglu.org.il>" + ], + "dynamic_config" : 1, + "generated_by" : "Module::Build version 0.38, CPAN::Meta::Converter version 2.120630", + "license" : [ + "perl_5" + ], + "meta-spec" : { + "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", + "version" : "2" + }, + "name" : "Error", + "prereqs" : { + "configure" : { + "requires" : { + "Module::Build" : "0.38" + } + }, + "runtime" : { + "requires" : { + "Scalar::Util" : "0", + "perl" : "v5.6.0", + "warnings" : "0" + } + } + }, + "provides" : { + "Error" : { + "file" : "lib/Error.pm", + "version" : "0.17018" + }, + "Error::Simple" : { + "file" : "lib/Error.pm", + "version" : "0.17018" + }, + "Error::WarnDie" : { + "file" : "lib/Error.pm", + "version" : 0 + }, + "Error::subs" : { + "file" : "lib/Error.pm", + "version" : 0 + } + }, + "release_status" : "stable", + "resources" : { + "license" : [ + "http://dev.perl.org/licenses/" + ] + }, + "version" : "0.17018" +} diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..b5897d3 --- /dev/null +++ b/META.yml @@ -0,0 +1,34 @@ +--- +abstract: 'Error/exception handling in an OO-ish way' +author: + - 'Shlomi Fish <shlomif@iglu.org.il>' +build_requires: {} +configure_requires: + Module::Build: 0.38 +dynamic_config: 1 +generated_by: 'Module::Build version 0.38, CPAN::Meta::Converter version 2.120630' +license: perl +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: 1.4 +name: Error +provides: + Error: + file: lib/Error.pm + version: 0.17018 + Error::Simple: + file: lib/Error.pm + version: 0.17018 + Error::WarnDie: + file: lib/Error.pm + version: 0 + Error::subs: + file: lib/Error.pm + version: 0 +requires: + Scalar::Util: 0 + perl: v5.6.0 + warnings: 0 +resources: + license: http://dev.perl.org/licenses/ +version: 0.17018 diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..672131b --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,15 @@ +use 5.006; +use ExtUtils::MakeMaker; + +WriteMakefile( + NAME => 'Error', + VERSION_FROM => 'lib/Error.pm', + PREREQ_PM => + { + 'Scalar::Util' => 0, + 'warnings' => 0, + }, + AUTHOR => 'Shlomi Fish <shlomif@iglu.org.il>', + ABSTRACT => 'Error/exception handling in an OO-ish way', + PL_FILES => {}, +); @@ -0,0 +1,90 @@ +NAME + Error - Error/exception handling in an OO-ish way + +DESCRIPTION + The Error package provides two interfaces. Firstly Error provides + a procedural interface to exception handling. Secondly 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 Error should not be thrown directly, but the + user should throw errors from a sub-class of Error + +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 + +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>. + +MAINTAINER + + Arun Kumar U <u_arunkumar@yahoo.com> + + ===================== + +HOW TO INSTALL IT ? + +To install this module, cd to the directory that contains this README +file and type the following: + + perl Makefile.PL + make test + make install + +To install this module into a specific directory, do: +perl Makefile.PL PREFIX=/name/of/the/directory +...the rest is the same... + +Please also read the perlmodinstall man page, if available. + +Share and Enjoy !! + +Arun Kumar U +<u_arunkumar@yahoo.com> + +------------------------------------------------------------------------------- + Only wimps use tape backup: *real* men just upload their important + stuff on ftp, and let the rest of the world mirror it. + - Linus Torvalds +------------------------------------------------------------------------------- + diff --git a/examples/example.pl b/examples/example.pl new file mode 100644 index 0000000..59da597 --- /dev/null +++ b/examples/example.pl @@ -0,0 +1,51 @@ + +use lib '.'; +use Error qw(:try); + +@Error::Bad::ISA = qw(Error); + +$Error::Debug = 1; # turn on verbose stacktrace + +sub abc { + try { + try { + throw Error::Simple("a simple error"); + } + catch Error::Simple with { + my $err = shift; + throw Error::Bad(-text => "some text"); + } + except { + return { + Error::Simple => sub { warn "simple" } + } + } + otherwise { + 1; + } finally { + warn "finally\n"; + }; + } + catch Error::Bad with { + 1; + }; +} + +sub def { + unlink("not such file") or + record Error::Simple("unlink: $!", $!) and return; + 1; +} + +abc(); + + +$x = prior Error; + +print "--\n",$x->stacktrace; + +unless(defined def()) { + $x = prior Error 'main'; + print "--\n",0+$x,"\n",$x; +} + diff --git a/examples/next-in-loop/Error.pm-eval.pl b/examples/next-in-loop/Error.pm-eval.pl new file mode 100644 index 0000000..87c67f7 --- /dev/null +++ b/examples/next-in-loop/Error.pm-eval.pl @@ -0,0 +1,40 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Error qw(:try); +use Scalar::Util qw(blessed); + +use IO::Handle; + +package MyError; + +use base 'Error'; + +package SecondError; + +use base 'Error'; + +package main; + +autoflush STDOUT 1; + +SHLOMIF_FOREACH: +foreach my $i (1 .. 100) +{ + eval + { + if ($i % 10 == 0) + { + throw MyError; + } + }; + my $E = $@; + if (blessed($E) && $E->isa('MyError')) + { + next SHLOMIF_FOREACH; + } + print "$i\n"; +} + diff --git a/examples/next-in-loop/Error.pm-next-label.pl b/examples/next-in-loop/Error.pm-next-label.pl new file mode 100644 index 0000000..1badf74 --- /dev/null +++ b/examples/next-in-loop/Error.pm-next-label.pl @@ -0,0 +1,38 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Error qw(:try); + +use IO::Handle; + +package MyError; + +use base 'Error'; + +package SecondError; + +use base 'Error'; + +package main; + +autoflush STDOUT 1; + +SHLOMIF_FOREACH: +foreach my $i (1 .. 100) +{ + try + { + if ($i % 10 == 0) + { + throw MyError; + } + } + catch MyError with + { + my $E = shift; + next SHLOMIF_FOREACH; + }; + print "$i\n"; +} diff --git a/examples/next-in-loop/Error.pm-next-out-of-catch.pl b/examples/next-in-loop/Error.pm-next-out-of-catch.pl new file mode 100644 index 0000000..019fe38 --- /dev/null +++ b/examples/next-in-loop/Error.pm-next-out-of-catch.pl @@ -0,0 +1,43 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Error qw(:try); + +use IO::Handle; + +package MyError; + +use base 'Error'; + +package SecondError; + +use base 'Error'; + +package main; + +autoflush STDOUT 1; + +SHLOMIF_FOREACH: +foreach my $i (1 .. 100) +{ + my $caught = 0; + try + { + if ($i % 10 == 0) + { + throw MyError; + } + } + catch MyError with + { + my $E = shift; + $caught = 1; + }; + if ($caught) + { + next SHLOMIF_FOREACH; + } + print "$i\n"; +} diff --git a/examples/next-in-loop/Error.pm-next.pl b/examples/next-in-loop/Error.pm-next.pl new file mode 100644 index 0000000..4a0bab3 --- /dev/null +++ b/examples/next-in-loop/Error.pm-next.pl @@ -0,0 +1,37 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Error qw(:try); + +use IO::Handle; + +package MyError; + +use base 'Error'; + +package SecondError; + +use base 'Error'; + +package main; + +autoflush STDOUT 1; + +foreach my $i (1 .. 100) +{ + try + { + if ($i % 10 == 0) + { + throw MyError; + } + } + catch MyError with + { + my $E = shift; + next; + }; + print "$i\n"; +} diff --git a/examples/next-in-loop/README b/examples/next-in-loop/README new file mode 100644 index 0000000..f13c21f --- /dev/null +++ b/examples/next-in-loop/README @@ -0,0 +1,3 @@ +This is a case study for various ways to implement a "next" command +inside one of the Error.pm clauses, which itself will be inside an +inner loop inside Error.pm. diff --git a/examples/warndie.pl b/examples/warndie.pl new file mode 100644 index 0000000..23e2e9e --- /dev/null +++ b/examples/warndie.pl @@ -0,0 +1,23 @@ +#!/usr/bin/perl -w + +require Error; +if( $ARGV[0] ) { + import Error qw( :warndie ); + print "Imported the :warndie tag.\n"; + print "\n"; +} +else { + print "Running example without the :warndie tag.\n"; + print "Try also passing a true value as \$ARGV[0] to import this tag\n"; + print "\n"; +} + +sub inner { + shift->foo(); +} + +sub outer { + inner( @_ ); +} + +outer( undef ); diff --git a/inc/Test/Run/Builder.pm b/inc/Test/Run/Builder.pm new file mode 100644 index 0000000..2365c61 --- /dev/null +++ b/inc/Test/Run/Builder.pm @@ -0,0 +1,65 @@ +package Test::Run::Builder; + +use strict; +use warnings; + +use Module::Build; + +use vars qw(@ISA); + +@ISA = (qw(Module::Build)); + +sub ACTION_runtest +{ + my ($self) = @_; + my $p = $self->{properties}; + + $self->depends_on('code'); + + local @INC = @INC; + + # Make sure we test the module in blib/ + unshift @INC, (File::Spec->catdir($p->{base_dir}, $self->blib, 'lib'), + File::Spec->catdir($p->{base_dir}, $self->blib, 'arch')); + + $self->do_test_run_tests; +} + +sub ACTION_distruntest { + my ($self) = @_; + + $self->depends_on('distdir'); + + my $start_dir = $self->cwd; + my $dist_dir = $self->dist_dir; + chdir $dist_dir or die "Cannot chdir to $dist_dir: $!"; + # XXX could be different names for scripts + + $self->run_perl_script('Build.PL') # XXX Should this be run w/ --nouse-rcfile + or die "Error executing 'Build.PL' in dist directory: $!"; + $self->run_perl_script('Build') + or die "Error executing 'Build' in dist directory: $!"; + $self->run_perl_script('Build', [], ['runtest']) + or die "Error executing 'Build test' in dist directory"; + chdir $start_dir; +} + +sub do_test_run_tests +{ + my $self = shift; + + require Test::Run::CmdLine::Iface; + + my $test_run = + Test::Run::CmdLine::Iface->new( + { + 'test_files' => [glob("t/*.t")], + } + # 'backend_params' => $self->_get_backend_params(), + ); + + return $test_run->run(); +} + +1; + diff --git a/lib/Error.pm b/lib/Error.pm new file mode 100644 index 0000000..1989296 --- /dev/null +++ b/lib/Error.pm @@ -0,0 +1,1039 @@ +# 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.17018"; + +use overload ( + '""' => 'stringify', + '0+' => 'value', + 'bool' => sub { return 1; }, + 'fallback' => 1 +); + +$Error::Depth = 0; # Depth to pass to caller() +$Error::Debug = 0; # Generate verbose stack traces +@Error::STACK = (); # Clause stack for try +$Error::THROWN = undef; # last error thrown, a workaround until die $ref works + +my $LAST; # Last error created +my %ERROR; # Last error associated with package + +sub _throw_Error_Simple +{ + my $args = shift; + return Error::Simple->new($args->{'text'}); +} + +$Error::ObjectifyCallback = \&_throw_Error_Simple; + + +# Exported subs are defined in Error::subs + +use Scalar::Util (); + +sub import { + shift; + my @tags = @_; + local $Exporter::ExportLevel = $Exporter::ExportLevel + 1; + + @tags = grep { + if( $_ eq ':warndie' ) { + Error::WarnDie->import(); + 0; + } + else { + 1; + } + } @tags; + + Error::subs->import(@tags); +} + +# I really want to use last for the name of this method, but it is a keyword +# which prevent the syntax last Error + +sub prior { + shift; # ignore + + return $LAST unless @_; + + my $pkg = shift; + return exists $ERROR{$pkg} ? $ERROR{$pkg} : undef + unless ref($pkg); + + my $obj = $pkg; + my $err = undef; + if($obj->isa('HASH')) { + $err = $obj->{'__Error__'} + if exists $obj->{'__Error__'}; + } + elsif($obj->isa('GLOB')) { + $err = ${*$obj}{'__Error__'} + if exists ${*$obj}{'__Error__'}; + } + + $err; +} + +sub flush { + shift; #ignore + + unless (@_) { + $LAST = undef; + return; + } + + my $pkg = shift; + return unless ref($pkg); + + undef $ERROR{$pkg} if defined $ERROR{$pkg}; +} + +# Return as much information as possible about where the error +# happened. The -stacktrace element only exists if $Error::DEBUG +# was set when the error was created + +sub stacktrace { + my $self = shift; + + return $self->{'-stacktrace'} + if exists $self->{'-stacktrace'}; + + my $text = exists $self->{'-text'} ? $self->{'-text'} : "Died"; + + $text .= sprintf(" at %s line %d.\n", $self->file, $self->line) + unless($text =~ /\n$/s); + + $text; +} + + +sub associate { + my $err = shift; + my $obj = shift; + + return unless ref($obj); + + if($obj->isa('HASH')) { + $obj->{'__Error__'} = $err; + } + elsif($obj->isa('GLOB')) { + ${*$obj}{'__Error__'} = $err; + } + $obj = ref($obj); + $ERROR{ ref($obj) } = $err; + + return; +} + + +sub new { + my $self = shift; + my($pkg,$file,$line) = caller($Error::Depth); + + my $err = bless { + '-package' => $pkg, + '-file' => $file, + '-line' => $line, + @_ + }, $self; + + $err->associate($err->{'-object'}) + if(exists $err->{'-object'}); + + # To always create a stacktrace would be very inefficient, so + # we only do it if $Error::Debug is set + + if($Error::Debug) { + require Carp; + local $Carp::CarpLevel = $Error::Depth; + my $text = defined($err->{'-text'}) ? $err->{'-text'} : "Error"; + my $trace = Carp::longmess($text); + # Remove try calls from the trace + $trace =~ s/(\n\s+\S+__ANON__[^\n]+)?\n\s+eval[^\n]+\n\s+Error::subs::try[^\n]+(?=\n)//sog; + $trace =~ s/(\n\s+\S+__ANON__[^\n]+)?\n\s+eval[^\n]+\n\s+Error::subs::run_clauses[^\n]+\n\s+Error::subs::try[^\n]+(?=\n)//sog; + $err->{'-stacktrace'} = $trace + } + + $@ = $LAST = $ERROR{$pkg} = $err; +} + +# Throw an error. this contains some very gory code. + +sub throw { + my $self = shift; + local $Error::Depth = $Error::Depth + 1; + + # if we are not rethrow-ing then create the object to throw + $self = $self->new(@_) unless ref($self); + + die $Error::THROWN = $self; +} + +# syntactic sugar for +# +# die with Error( ... ); + +sub with { + my $self = shift; + local $Error::Depth = $Error::Depth + 1; + + $self->new(@_); +} + +# syntactic sugar for +# +# record Error( ... ) and return; + +sub record { + my $self = shift; + local $Error::Depth = $Error::Depth + 1; + + $self->new(@_); +} + +# catch clause for +# +# try { ... } catch CLASS with { ... } + +sub catch { + my $pkg = shift; + my $code = shift; + my $clauses = shift || {}; + my $catch = $clauses->{'catch'} ||= []; + + unshift @$catch, $pkg, $code; + + $clauses; +} + +# Object query methods + +sub object { + my $self = shift; + exists $self->{'-object'} ? $self->{'-object'} : undef; +} + +sub file { + my $self = shift; + exists $self->{'-file'} ? $self->{'-file'} : undef; +} + +sub line { + my $self = shift; + exists $self->{'-line'} ? $self->{'-line'} : undef; +} + +sub text { + my $self = shift; + exists $self->{'-text'} ? $self->{'-text'} : undef; +} + +# overload methods + +sub stringify { + my $self = shift; + defined $self->{'-text'} ? $self->{'-text'} : "Died"; +} + +sub value { + my $self = shift; + exists $self->{'-value'} ? $self->{'-value'} : undef; +} + +package Error::Simple; + +use vars qw($VERSION); + +$VERSION = "0.17018"; + +@Error::Simple::ISA = qw(Error); + +sub new { + my $self = shift; + my $text = "" . shift; + my $value = shift; + my(@args) = (); + + local $Error::Depth = $Error::Depth + 1; + + @args = ( -file => $1, -line => $2) + if($text =~ s/\s+at\s+(\S+)\s+line\s+(\d+)(?:,\s*<[^>]*>\s+line\s+\d+)?\.?\n?$//s); + push(@args, '-value', 0 + $value) + if defined($value); + + $self->SUPER::new(-text => $text, @args); +} + +sub stringify { + my $self = shift; + my $text = $self->SUPER::stringify; + $text .= sprintf(" at %s line %d.\n", $self->file, $self->line) + unless($text =~ /\n$/s); + $text; +} + +########################################################################## +########################################################################## + +# Inspired by code from Jesse Glick <jglick@sig.bsh.com> and +# Peter Seibel <peter@weblogic.com> + +package Error::subs; + +use Exporter (); +use vars qw(@EXPORT_OK @ISA %EXPORT_TAGS); + +@EXPORT_OK = qw(try with finally except otherwise); +%EXPORT_TAGS = (try => \@EXPORT_OK); + +@ISA = qw(Exporter); + +sub run_clauses ($$$\@) { + my($clauses,$err,$wantarray,$result) = @_; + my $code = undef; + + $err = $Error::ObjectifyCallback->({'text' =>$err}) unless ref($err); + + CATCH: { + + # catch + my $catch; + if(defined($catch = $clauses->{'catch'})) { + my $i = 0; + + CATCHLOOP: + for( ; $i < @$catch ; $i += 2) { + my $pkg = $catch->[$i]; + unless(defined $pkg) { + #except + splice(@$catch,$i,2,$catch->[$i+1]->($err)); + $i -= 2; + next CATCHLOOP; + } + elsif(Scalar::Util::blessed($err) && $err->isa($pkg)) { + $code = $catch->[$i+1]; + while(1) { + my $more = 0; + local($Error::THROWN, $@); + my $ok = eval { + $@ = $err; + if($wantarray) { + @{$result} = $code->($err,\$more); + } + elsif(defined($wantarray)) { + @{$result} = (); + $result->[0] = $code->($err,\$more); + } + else { + $code->($err,\$more); + } + 1; + }; + if( $ok ) { + next CATCHLOOP if $more; + undef $err; + } + else { + $err = $@ || $Error::THROWN; + $err = $Error::ObjectifyCallback->({'text' =>$err}) + unless ref($err); + } + last CATCH; + }; + } + } + } + + # otherwise + my $owise; + if(defined($owise = $clauses->{'otherwise'})) { + my $code = $clauses->{'otherwise'}; + my $more = 0; + local($Error::THROWN, $@); + my $ok = eval { + $@ = $err; + if($wantarray) { + @{$result} = $code->($err,\$more); + } + elsif(defined($wantarray)) { + @{$result} = (); + $result->[0] = $code->($err,\$more); + } + else { + $code->($err,\$more); + } + 1; + }; + if( $ok ) { + undef $err; + } + else { + $err = $@ || $Error::THROWN; + + $err = $Error::ObjectifyCallback->({'text' =>$err}) + unless ref($err); + } + } + } + $err; +} + +sub try (&;$) { + my $try = shift; + my $clauses = @_ ? shift : {}; + my $ok = 0; + my $err = undef; + my @result = (); + + unshift @Error::STACK, $clauses; + + my $wantarray = wantarray(); + + do { + local $Error::THROWN = undef; + local $@ = undef; + + $ok = eval { + if($wantarray) { + @result = $try->(); + } + elsif(defined $wantarray) { + $result[0] = $try->(); + } + else { + $try->(); + } + 1; + }; + + $err = $@ || $Error::THROWN + unless $ok; + }; + + shift @Error::STACK; + + $err = run_clauses($clauses,$err,wantarray,@result) + unless($ok); + + $clauses->{'finally'}->() + if(defined($clauses->{'finally'})); + + if (defined($err)) + { + if (Scalar::Util::blessed($err) && $err->can('throw')) + { + throw $err; + } + else + { + die $err; + } + } + + wantarray ? @result : $result[0]; +} + +# Each clause adds a sub to the list of clauses. The finally clause is +# always the last, and the otherwise clause is always added just before +# the finally clause. +# +# All clauses, except the finally clause, add a sub which takes one argument +# this argument will be the error being thrown. The sub will return a code ref +# if that clause can handle that error, otherwise undef is returned. +# +# The otherwise clause adds a sub which unconditionally returns the users +# code reference, this is why it is forced to be last. +# +# The catch clause is defined in Error.pm, as the syntax causes it to +# be called as a method + +sub with (&;$) { + @_ +} + +sub finally (&) { + my $code = shift; + my $clauses = { 'finally' => $code }; + $clauses; +} + +# The except clause is a block which returns a hashref or a list of +# key-value pairs, where the keys are the classes and the values are subs. + +sub except (&;$) { + my $code = shift; + my $clauses = shift || {}; + my $catch = $clauses->{'catch'} ||= []; + + my $sub = sub { + my $ref; + my(@array) = $code->($_[0]); + if(@array == 1 && ref($array[0])) { + $ref = $array[0]; + $ref = [ %$ref ] + if(UNIVERSAL::isa($ref,'HASH')); + } + else { + $ref = \@array; + } + @$ref + }; + + unshift @{$catch}, undef, $sub; + + $clauses; +} + +sub otherwise (&;$) { + my $code = shift; + my $clauses = shift || {}; + + if(exists $clauses->{'otherwise'}) { + require Carp; + Carp::croak("Multiple otherwise clauses"); + } + + $clauses->{'otherwise'} = $code; + + $clauses; +} + +1; + +package Error::WarnDie; + +sub gen_callstack($) +{ + my ( $start ) = @_; + + require Carp; + local $Carp::CarpLevel = $start; + my $trace = Carp::longmess(""); + # Remove try calls from the trace + $trace =~ s/(\n\s+\S+__ANON__[^\n]+)?\n\s+eval[^\n]+\n\s+Error::subs::try[^\n]+(?=\n)//sog; + $trace =~ s/(\n\s+\S+__ANON__[^\n]+)?\n\s+eval[^\n]+\n\s+Error::subs::run_clauses[^\n]+\n\s+Error::subs::try[^\n]+(?=\n)//sog; + my @callstack = split( m/\n/, $trace ); + return @callstack; +} + +my $old_DIE; +my $old_WARN; + +sub DEATH +{ + my ( $e ) = @_; + + local $SIG{__DIE__} = $old_DIE if( defined $old_DIE ); + + die @_ if $^S; + + my ( $etype, $message, $location, @callstack ); + if ( ref($e) && $e->isa( "Error" ) ) { + $etype = "exception of type " . ref( $e ); + $message = $e->text; + $location = $e->file . ":" . $e->line; + @callstack = split( m/\n/, $e->stacktrace ); + } + else { + # Don't apply subsequent layer of message formatting + die $e if( $e =~ m/^\nUnhandled perl error caught at toplevel:\n\n/ ); + $etype = "perl error"; + my $stackdepth = 0; + while( caller( $stackdepth ) =~ m/^Error(?:$|::)/ ) { + $stackdepth++ + } + + @callstack = gen_callstack( $stackdepth + 1 ); + + $message = "$e"; + chomp $message; + + if ( $message =~ s/ at (.*?) line (\d+)\.$// ) { + $location = $1 . ":" . $2; + } + else { + my @caller = caller( $stackdepth ); + $location = $caller[1] . ":" . $caller[2]; + } + } + + shift @callstack; + # Do it this way in case there are no elements; we don't print a spurious \n + my $callstack = join( "", map { "$_\n"} @callstack ); + + die "\nUnhandled $etype caught at toplevel:\n\n $message\n\nThrown from: $location\n\nFull stack trace:\n\n$callstack\n"; +} + +sub TAXES +{ + my ( $message ) = @_; + + local $SIG{__WARN__} = $old_WARN if( defined $old_WARN ); + + $message =~ s/ at .*? line \d+\.$//; + chomp $message; + + my @callstack = gen_callstack( 1 ); + my $location = shift @callstack; + + # $location already starts in a leading space + $message .= $location; + + # Do it this way in case there are no elements; we don't print a spurious \n + my $callstack = join( "", map { "$_\n"} @callstack ); + + warn "$message:\n$callstack"; +} + +sub import +{ + $old_DIE = $SIG{__DIE__}; + $old_WARN = $SIG{__WARN__}; + + $SIG{__DIE__} = \&DEATH; + $SIG{__WARN__} = \&TAXES; +} + +1; + +__END__ + +=head1 NAME + +Error - Error/exception handling in an OO-ish way + +=head1 WARNING + +Using the "Error" module is B<no longer recommended> due to the black-magical +nature of its syntactic sugar, which often tends to break. Its maintainers +have stopped actively writing code that uses it, and discourage people +from doing so. See the "SEE ALSO" section below for better recommendations. + +=head1 SYNOPSIS + + use Error qw(:try); + + throw Error::Simple( "A simple error"); + + sub xyz { + ... + record Error::Simple("A simple error") + and return; + } + + unlink($file) or throw Error::Simple("$file: $!",$!); + + try { + do_some_stuff(); + die "error!" if $condition; + throw Error::Simple "Oops!" if $other_condition; + } + catch Error::IO with { + my $E = shift; + print STDERR "File ", $E->{'-file'}, " had a problem\n"; + } + except { + my $E = shift; + my $general_handler=sub {send_message $E->{-description}}; + return { + UserException1 => $general_handler, + UserException2 => $general_handler + }; + } + otherwise { + print STDERR "Well I don't know what to say\n"; + } + finally { + close_the_garage_door_already(); # Should be reliable + }; # Don't forget the trailing ; or you might be surprised + +=head1 DESCRIPTION + +The C<Error> package provides two interfaces. Firstly C<Error> provides +a procedural interface to exception handling. Secondly C<Error> is a +base class for errors/exceptions that can either be thrown, for +subsequent catch, or can simply be recorded. + +Errors in the class C<Error> should not be thrown directly, but the +user should throw errors from a sub-class of C<Error>. + +=head1 PROCEDURAL INTERFACE + +C<Error> exports subroutines to perform exception handling. These will +be exported if the C<:try> tag is used in the C<use> line. + +=over 4 + +=item try BLOCK CLAUSES + +C<try> is the main subroutine called by the user. All other subroutines +exported are clauses to the try subroutine. + +The BLOCK will be evaluated and, if no error is throw, try will return +the result of the block. + +C<CLAUSES> are the subroutines below, which describe what to do in the +event of an error being thrown within BLOCK. + +=item catch CLASS with BLOCK + +This clauses will cause all errors that satisfy C<$err-E<gt>isa(CLASS)> +to be caught and handled by evaluating C<BLOCK>. + +C<BLOCK> will be passed two arguments. The first will be the error +being thrown. The second is a reference to a scalar variable. If this +variable is set by the catch block then, on return from the catch +block, try will continue processing as if the catch block was never +found. The error will also be available in C<$@>. + +To propagate the error the catch block may call C<$err-E<gt>throw> + +If the scalar reference by the second argument is not set, and the +error is not thrown. Then the current try block will return with the +result from the catch block. + +=item except BLOCK + +When C<try> is looking for a handler, if an except clause is found +C<BLOCK> is evaluated. The return value from this block should be a +HASHREF or a list of key-value pairs, where the keys are class names +and the values are CODE references for the handler of errors of that +type. + +=item otherwise BLOCK + +Catch any error by executing the code in C<BLOCK> + +When evaluated C<BLOCK> will be passed one argument, which will be the +error being processed. The error will also be available in C<$@>. + +Only one otherwise block may be specified per try block + +=item finally BLOCK + +Execute the code in C<BLOCK> either after the code in the try block has +successfully completed, or if the try block throws an error then +C<BLOCK> will be executed after the handler has completed. + +If the handler throws an error then the error will be caught, the +finally block will be executed and the error will be re-thrown. + +Only one finally block may be specified per try block + +=back + +=head1 COMPATIBILITY + +L<Moose> exports a keyword called C<with> which clashes with Error's. This +example returns a prototype mismatch error: + + package MyTest; + + use warnings; + use Moose; + use Error qw(:try); + +(Thanks to C<maik.hentsche@amd.com> for the report.). + +=head1 CLASS INTERFACE + +=head2 CONSTRUCTORS + +The C<Error> object is implemented as a HASH. This HASH is initialized +with the arguments that are passed to it's constructor. The elements +that are used by, or are retrievable by the C<Error> class are listed +below, other classes may add to these. + + -file + -line + -text + -value + -object + +If C<-file> or C<-line> are not specified in the constructor arguments +then these will be initialized with the file name and line number where +the constructor was called from. + +If the error is associated with an object then the object should be +passed as the C<-object> argument. This will allow the C<Error> package +to associate the error with the object. + +The C<Error> package remembers the last error created, and also the +last error associated with a package. This could either be the last +error created by a sub in that package, or the last error which passed +an object blessed into that package as the C<-object> argument. + +=over 4 + +=item Error->new() + +See the Error::Simple documentation. + +=item throw ( [ ARGS ] ) + +Create a new C<Error> object and throw an error, which will be caught +by a surrounding C<try> block, if there is one. Otherwise it will cause +the program to exit. + +C<throw> may also be called on an existing error to re-throw it. + +=item with ( [ ARGS ] ) + +Create a new C<Error> object and returns it. This is defined for +syntactic sugar, eg + + die with Some::Error ( ... ); + +=item record ( [ ARGS ] ) + +Create a new C<Error> object and returns it. This is defined for +syntactic sugar, eg + + record Some::Error ( ... ) + and return; + +=back + +=head2 STATIC METHODS + +=over 4 + +=item prior ( [ PACKAGE ] ) + +Return the last error created, or the last error associated with +C<PACKAGE> + +=item flush ( [ PACKAGE ] ) + +Flush the last error created, or the last error associated with +C<PACKAGE>.It is necessary to clear the error stack before exiting the +package or uncaught errors generated using C<record> will be reported. + + $Error->flush; + +=cut + +=back + +=head2 OBJECT METHODS + +=over 4 + +=item stacktrace + +If the variable C<$Error::Debug> was non-zero when the error was +created, then C<stacktrace> returns a string created by calling +C<Carp::longmess>. If the variable was zero the C<stacktrace> returns +the text of the error appended with the filename and line number of +where the error was created, providing the text does not end with a +newline. + +=item object + +The object this error was associated with + +=item file + +The file where the constructor of this error was called from + +=item line + +The line where the constructor of this error was called from + +=item text + +The text of the error + +=item $err->associate($obj) + +Associates an error with an object to allow error propagation. I.e: + + $ber->encode(...) or + return Error->prior($ber)->associate($ldap); + +=back + +=head2 OVERLOAD METHODS + +=over 4 + +=item stringify + +A method that converts the object into a string. This method may simply +return the same as the C<text> method, or it may append more +information. For example the file name and line number. + +By default this method returns the C<-text> argument that was passed to +the constructor, or the string C<"Died"> if none was given. + +=item value + +A method that will return a value that can be associated with the +error. For example if an error was created due to the failure of a +system call, then this may return the numeric value of C<$!> at the +time. + +By default this method returns the C<-value> argument that was passed +to the constructor. + +=back + +=head1 PRE-DEFINED ERROR CLASSES + +=head2 Error::Simple + +This class can be used to hold simple error strings and values. It's +constructor takes two arguments. The first is a text value, the second +is a numeric value. These values are what will be returned by the +overload methods. + +If the text value ends with C<at file line 1> as $@ strings do, then +this infomation will be used to set the C<-file> and C<-line> arguments +of the error object. + +This class is used internally if an eval'd block die's with an error +that is a plain string. (Unless C<$Error::ObjectifyCallback> is modified) + + +=head1 $Error::ObjectifyCallback + +This variable holds a reference to a subroutine that converts errors that +are plain strings to objects. It is used by Error.pm to convert textual +errors to objects, and can be overrided by the user. + +It accepts a single argument which is a hash reference to named parameters. +Currently the only named parameter passed is C<'text'> which is the text +of the error, but others may be available in the future. + +For example the following code will cause Error.pm to throw objects of the +class MyError::Bar by default: + + sub throw_MyError_Bar + { + my $args = shift; + my $err = MyError::Bar->new(); + $err->{'MyBarText'} = $args->{'text'}; + return $err; + } + + { + local $Error::ObjectifyCallback = \&throw_MyError_Bar; + + # Error handling here. + } + +=cut + +=head1 MESSAGE HANDLERS + +C<Error> also provides handlers to extend the output of the C<warn()> perl +function, and to handle the printing of a thrown C<Error> that is not caught +or otherwise handled. These are not installed by default, but are requested +using the C<:warndie> tag in the C<use> line. + + use Error qw( :warndie ); + +These new error handlers are installed in C<$SIG{__WARN__}> and +C<$SIG{__DIE__}>. If these handlers are already defined when the tag is +imported, the old values are stored, and used during the new code. Thus, to +arrange for custom handling of warnings and errors, you will need to perform +something like the following: + + BEGIN { + $SIG{__WARN__} = sub { + print STDERR "My special warning handler: $_[0]" + }; + } + + use Error qw( :warndie ); + +Note that setting C<$SIG{__WARN__}> after the C<:warndie> tag has been +imported will overwrite the handler that C<Error> provides. If this cannot be +avoided, then the tag can be explicitly C<import>ed later + + use Error; + + $SIG{__WARN__} = ...; + + import Error qw( :warndie ); + +=head2 EXAMPLE + +The C<__DIE__> handler turns messages such as + + Can't call method "foo" on an undefined value at examples/warndie.pl line 16. + +into + + Unhandled perl error caught at toplevel: + + Can't call method "foo" on an undefined value + + Thrown from: examples/warndie.pl:16 + + Full stack trace: + + main::inner('undef') called at examples/warndie.pl line 20 + main::outer('undef') called at examples/warndie.pl line 23 + +=cut + +=head1 SEE ALSO + +See L<Exception::Class> for a different module providing Object-Oriented +exception handling, along with a convenient syntax for declaring hierarchies +for them. It doesn't provide Error's syntactic sugar of C<try { ... }>, +C<catch { ... }>, etc. which may be a good thing or a bad thing based +on what you want. (Because Error's syntactic sugar tends to break.) + +L<Error::Exception> aims to combine L<Error> and L<Exception::Class> +"with correct stringification". + +L<TryCatch> and L<Try::Tiny> are similar in concept to Error.pm only providing +a syntax that hopefully breaks less. + +=head1 KNOWN BUGS + +None, but that does not mean there are not any. + +=head1 AUTHORS + +Graham Barr <gbarr@pobox.com> + +The code that inspired me to write this was originally written by +Peter Seibel <peter@weblogic.com> and adapted by Jesse Glick +<jglick@sig.bsh.com>. + +C<:warndie> handlers added by Paul Evans <leonerd@leonerd.org.uk> + +=head1 MAINTAINER + +Shlomi Fish <shlomif@iglu.org.il> + +=head1 PAST MAINTAINERS + +Arun Kumar U <u_arunkumar@yahoo.com> + +=head1 COPYRIGHT + +Copyright (c) 1997-8 Graham Barr. All rights reserved. +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=cut + diff --git a/lib/Error/Simple.pm b/lib/Error/Simple.pm new file mode 100644 index 0000000..906e724 --- /dev/null +++ b/lib/Error/Simple.pm @@ -0,0 +1,58 @@ +# Error.pm +# +# Copyright (c) 2006 Shlomi Fish <shlomif@iglu.org.il>. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the terms of the MIT/X11 license. + +use strict; +use warnings; + +use vars qw($VERSION); + +$VERSION = "0.17018"; + +use Error; + +1; +__END__ + +=head1 NAME + +Error::Simple - the simple error sub-class of Error + +=head1 SYNOPSIS + + use base 'Error::Simple'; + +=head1 DESCRIPTION + +The only purpose of this module is to allow one to say: + + use base 'Error::Simple'; + +and the only thing it does is "use" Error.pm. Refer to the documentation +of L<Error> for more information about Error::Simple. + +=head1 METHODS + +=head2 Error::Simple->new($text [, $value]) + +Constructs an Error::Simple with the text C<$text> and the optional value +C<$value>. + +=head2 $err->stringify() + +Error::Simple overloads this method. + +=head1 KNOWN BUGS + +None. + +=head1 AUTHORS + +Shlomi Fish ( C<< shlomif@iglu.org.il >> ) + +=head1 SEE ALSO + +L<Error> + diff --git a/scripts/bump-version-number.pl b/scripts/bump-version-number.pl new file mode 100644 index 0000000..4fb7cf8 --- /dev/null +++ b/scripts/bump-version-number.pl @@ -0,0 +1,43 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use File::Find::Object; +use IO::All; + +my $tree = File::Find::Object->new({}, 'lib/'); + +my $version_n = shift(@ARGV); + +if (!defined($version_n)) +{ + die "Specify version number as an argument! bump-version-number.pl '0.0.1'"; +} + +sub process_file +{ + # The filename. + my ($r) = @_; + + my @lines = io->file($r)->getlines(); + foreach (@lines) + { + s#(\$VERSION = "|^Version )\d+\.\d+(?:\.\d+)?("|)#$1 . $version_n . $2#e; + } + io->file($r)->print( + @lines + ); +} + +while (my $r = $tree->next()) { + if ($r =~ m{/\.(?:svn|hg|git)\z}) + { + $tree->prune(); + } + elsif ($r =~ m{\.pm\z}) + { + process_file($r); + } +} + diff --git a/t/01throw.t b/t/01throw.t new file mode 100644 index 0000000..a1bdba2 --- /dev/null +++ b/t/01throw.t @@ -0,0 +1,25 @@ + +use Error qw(:try); + +print "1..4\n"; + +try { + print "ok 1\n"; +}; + + +try { + throw Error::Simple("ok 2\n",2); + print "not ok 2\n"; +} +catch Error::Simple with { + my $err = shift; + print "$err"; +} +finally { + print "ok 3\n"; +}; + +$err = prior Error; + +print "ok ",2+$err,"\n";; diff --git a/t/02order.t b/t/02order.t new file mode 100644 index 0000000..7d1e59d --- /dev/null +++ b/t/02order.t @@ -0,0 +1,47 @@ + +use Error qw(:try); + +@Error::Fatal::ISA = qw(Error); + +print "1..6\n"; + +$num = try { + try { + try { + throw Error::Simple("ok 1\n"); + } + catch Error::Simple with { + my $err = shift; + print $err; + + throw Error::Fatal(-value => 4); + + print "not ok 3\n"; + } + catch Error::Fatal with { + exit(1); + } + finally { + print "ok 2\n"; + }; + } finally { + print "ok 3\n"; + }; +} +catch Error::Fatal with { + my $err = shift; + my $more = shift; + $$more = 1; + print "ok ",0+$err,"\n"; +} +catch Error::Fatal with { + my $err = shift; + print "ok ",1+$err,"\n"; + return 6; +} +catch Error::Fatal with { + my $err = shift; + print "not ok ",2+$err,"\n"; +}; + +print "ok ",$num,"\n"; diff --git a/t/03throw-non-Error.t b/t/03throw-non-Error.t new file mode 100644 index 0000000..03ef624 --- /dev/null +++ b/t/03throw-non-Error.t @@ -0,0 +1,32 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Error (qw(:try)); +use Test::More tests => 2; + +my $count_of_Error = 0; +eval +{ +try +{ + die +{ 'private' => "Shlomi", 'family' => "Fish" }; +} +catch Error with +{ + my $err = shift; + $count_of_Error++; +} +}; +my $exception = $@; + +# TEST +is_deeply ( + $exception, + +{'private' => "Shlomi", 'family' => "Fish"}, + "Testing for thrown exception", +); + +# TEST +is ($count_of_Error, 0, "No Errors caught."); diff --git a/t/04use-base-Error-Simple.t b/t/04use-base-Error-Simple.t new file mode 100644 index 0000000..a9656bb --- /dev/null +++ b/t/04use-base-Error-Simple.t @@ -0,0 +1,18 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 1; + +package Error::MyError; + +use base 'Error::Simple'; + +package main; + +# TEST +ok(1, "Testing that the use base worked."); + +1; + diff --git a/t/05text-errors-with-file-handles.t b/t/05text-errors-with-file-handles.t new file mode 100644 index 0000000..dd36b33 --- /dev/null +++ b/t/05text-errors-with-file-handles.t @@ -0,0 +1,52 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 4; + +use Error qw(:try); + +BEGIN +{ + use File::Spec; + use lib File::Spec->catdir(File::Spec->curdir(), "t", "lib"); + use MyDie; +} + +package MyError::Foo; + +use vars qw(@ISA); + +@ISA=(qw(Error)); + +package main; + +my $ok = 1; +eval +{ + try + { + MyDie::mydie(); + } + catch MyError::Foo with + { + my $err = shift; + $ok = 0; + }; +}; + +my $err = $@; + +# TEST +ok($ok, "Not MyError::Foo"); + +# TEST +ok($err->isa("Error::Simple"), "Testing"); + +# TEST +is($err->{-line}, 16, "Testing for correct line number"); + +# TEST +ok(($err->{-file} =~ m{MyDie\.pm$}), "Testing for correct module"); + diff --git a/t/06customize-text-throw.t b/t/06customize-text-throw.t new file mode 100644 index 0000000..26eb523 --- /dev/null +++ b/t/06customize-text-throw.t @@ -0,0 +1,66 @@ +#!/usr/bin/perl -w + +use strict; + +use Test::More tests => 3; + +use Error qw(:try); + +package MyError::Foo; + +use vars qw(@ISA); + +@ISA=qw(Error); + +package MyError::Bar; + +use vars qw(@ISA); + +@ISA=qw(Error); + +package main; + +{ + eval + { + try + { + die "Hello"; + } + catch MyError::Foo with { + }; + }; + + my $err = $@; + + # TEST + ok($err->isa("Error::Simple"), "Error was auto-converted to Error::Simple"); +} + +sub throw_MyError_Bar +{ + my $args = shift; + my $err = MyError::Bar->new(); + $err->{'MyBarText'} = $args->{'text'}; + return $err; +} + +{ + local $Error::ObjectifyCallback = \&throw_MyError_Bar; + eval + { + try + { + die "Hello\n"; + } + catch MyError::Foo with { + }; + }; + + my $err = $@; + + # TEST + ok ($err->isa("MyError::Bar"), "Error was auto-converted to MyError::Bar"); + # TEST + is ($err->{'MyBarText'}, "Hello\n", "Text of the error is correct"); +} diff --git a/t/07try-in-obj-destructor.t b/t/07try-in-obj-destructor.t new file mode 100644 index 0000000..b15bff2 --- /dev/null +++ b/t/07try-in-obj-destructor.t @@ -0,0 +1,42 @@ +#!/usr/bin/perl -w + +use strict; + +use Test::More tests => 1; + +use Error qw/ :try /; + +package ErrorTest; +use Error qw/ :try /; + +sub new { + return bless {}, 'ErrorTest'; +} + +sub DESTROY { + my $self = shift; + try { 1; } otherwise { }; + return; +} + +package main; + +my $E; +try { + + my $y = ErrorTest->new(); +# throw Error::Simple("Object die"); + die "throw normal die"; + +} catch Error with { + $E = shift; +} otherwise { + $E = shift; +}; + +# TEST +is ($E->{'-text'}, "throw normal die", + "Testing that the excpetion is not trampeled" +); + + diff --git a/t/08warndie.t b/t/08warndie.t new file mode 100644 index 0000000..205c6e1 --- /dev/null +++ b/t/08warndie.t @@ -0,0 +1,219 @@ +#!/usr/bin/perl -w + +use strict; +use warnings; + +use Test::More tests => 21; + +use Error qw/ :warndie /; + +# Turn on full stack trace capture +$Error::Debug = 1; + +# This file's name - for string matching. We need to quotemeta it, because on +# Win32, the filename is t\08warndie.t, and we don't want that accidentally +# matching an (invalid) \08 octal digit +my $file = qr/\Q$0\E/; + +# Most of these tests are fatal, and print data on STDERR. We therefore use +# this testing function to run a CODEref in a child process and captures its +# STDERR and note whether the CODE block exited +my ( $s, $felloffcode ); +my $linekid = __LINE__ + 15; # the $code->() is 15 lines below this one +sub run_kid(&) +{ + my ( $code ) = @_; + + # Win32's fork() emulation can't correctly handle the open("-|") case yet + # So we'll implement this manually - inspired by 'perldoc perlfork' + pipe my $childh, my $child or die "Cannot pipe() - $!"; + defined( my $kid = fork() ) or die "Cannot fork() - $!"; + + if ( !$kid ) { + close $childh; + close STDERR; + open(STDERR, ">&=" . fileno($child)) or die; + + $code->(); + + print STDERR "FELL OUT OF CODEREF\n"; + exit(1); + } + + close $child; + + $s = ""; + while( defined ( $_ = <$childh> ) ) { + $s .= $_; + } + + close( $childh ); + waitpid( $kid, 0 ); + + $felloffcode = 0; + $s =~ tr/\r//d; # Remove Win32 \r linefeeds to make RE tests easier + if( $s =~ s/FELL OUT OF CODEREF\n$// ) { + $felloffcode = 1; + } +} + +ok(1, "Loaded"); + +run_kid { + print STDERR "Print to STDERR\n"; +}; + +is( $s, "Print to STDERR\n", "Test framework STDERR" ); +is( $felloffcode, 1, "Test framework felloffcode" ); + +my $line; + +$line = __LINE__; +run_kid { + warn "A warning\n"; +}; + +my ( $linea, $lineb ) = ( $line + 2, $line + 3 ); +like( $s, qr/^A warning at $file line $linea\.?: +\tmain::__ANON__\(\) called at $file line $linekid +\tmain::run_kid\('CODE\(0x[0-9a-f]+\)'\) called at $file line $lineb +$/, "warn \\n-terminated STDERR" ); +is( $felloffcode, 1, "warn \\n-terminated felloffcode" ); + +$line = __LINE__; +run_kid { + warn "A warning"; +}; + +( $linea, $lineb ) = ( $line + 2, $line + 3 ); +like( $s, qr/^A warning at $file line $linea\.?: +\tmain::__ANON__\(\) called at $file line $linekid +\tmain::run_kid\('CODE\(0x[0-9a-f]+\)'\) called at $file line $lineb +$/, "warn unterminated STDERR" ); +is( $felloffcode, 1, "warn unterminated felloffcode" ); + +$line = __LINE__; +run_kid { + die "An error\n"; +}; + +( $linea, $lineb ) = ( $line + 2, $line + 3 ); +like( $s, qr/^ +Unhandled perl error caught at toplevel: + + An error + +Thrown from: $file:$linea + +Full stack trace: + +\tmain::__ANON__\(\) called at $file line $linekid +\tmain::run_kid\('CODE\(0x[0-9a-f]+\)'\) called at $file line $lineb + +$/, "die \\n-terminated STDERR" ); +is( $felloffcode, 0, "die \\n-terminated felloffcode" ); + +$line = __LINE__; +run_kid { + die "An error"; +}; + +( $linea, $lineb ) = ( $line + 2, $line + 3 ); +like( $s, qr/^ +Unhandled perl error caught at toplevel: + + An error + +Thrown from: $file:$linea + +Full stack trace: + +\tmain::__ANON__\(\) called at $file line $linekid +\tmain::run_kid\('CODE\(0x[0-9a-f]+\)'\) called at $file line $lineb + +$/, "die unterminated STDERR" ); +is( $felloffcode, 0, "die unterminated felloffcode" ); + +$line = __LINE__; +run_kid { + throw Error( -text => "An exception" ); +}; + +( $linea, $lineb ) = ( $line + 2, $line + 3 ); +like( $s, qr/^ +Unhandled exception of type Error caught at toplevel: + + An exception + +Thrown from: $file:$linea + +Full stack trace: + +\tmain::__ANON__\(\) called at $file line $linekid +\tmain::run_kid\('CODE\(0x[0-9a-f]+\)'\) called at $file line $lineb + +$/, "Error STDOUT" ); +is( $felloffcode, 0, "Error felloffcode" ); + +# Now custom warn and die functions to ensure the :warndie handler respects them +$SIG{__WARN__} = sub { warn "My custom warning here: $_[0]" }; +$SIG{__DIE__} = sub { die "My custom death here: $_[0]" }; + +# First test them +$line = __LINE__; +run_kid { + warn "A warning"; +}; + +$linea = $line + 2; +like( $s, qr/^My custom warning here: A warning at $file line $linea\.? +$/, "Custom warn test STDERR" ); +is( $felloffcode, 1, "Custom warn test felloffcode" ); + +$line = __LINE__; +run_kid { + die "An error"; +}; + +$linea = $line + 2; +like( $s, qr/^My custom death here: An error at $file line $linea\.? +/, "Custom die test STDERR" ); +is( $felloffcode, 0, "Custom die test felloffcode" ); + +# Re-install the :warndie handlers +import Error qw( :warndie ); + +$line = __LINE__; +run_kid { + warn "A warning\n"; +}; + +( $linea, $lineb ) = ( $line + 2, $line + 3 ); +like( $s, qr/^My custom warning here: A warning at $file line $linea\.?: +\tmain::__ANON__\(\) called at $file line $linekid +\tmain::run_kid\('CODE\(0x[0-9a-f]+\)'\) called at $file line $lineb +$/, "Custom warn STDERR" ); +is( $felloffcode, 1, "Custom warn felloffcode" ); + +$line = __LINE__; +run_kid { + die "An error"; +}; + +( $linea, $lineb ) = ( $line + 2, $line + 3 ); +like( $s, qr/^My custom death here: +Unhandled perl error caught at toplevel: + + An error + +Thrown from: $file:$linea + +Full stack trace: + +\tmain::__ANON__\(\) called at $file line $linekid +\tmain::run_kid\('CODE\(0x[0-9a-f]+\)'\) called at $file line $lineb + +$/, "Custom die STDERR" ); +is( $felloffcode, 0, "Custom die felloffcode" ); + +# Done diff --git a/t/09dollar-at.t b/t/09dollar-at.t new file mode 100644 index 0000000..7a46b16 --- /dev/null +++ b/t/09dollar-at.t @@ -0,0 +1,36 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Error qw(:try); +use Test::More tests => 8; + +my $dollar_at; +my $arg_0; + +try { + throw Error::Simple( "message" ); +} +catch Error::Simple with { + $arg_0 = shift; + $dollar_at = $@; +}; + +ok( defined $arg_0, 'defined( $_[0] ) after throw/catch' ); +ok( defined $dollar_at, 'defined( $@ ) after throw/catch' ); +ok( ref $arg_0 && $arg_0->isa( "Error::Simple" ), '$_[0]->isa( "Error::Simple" ) after throw/catch' ); +ok( ref $dollar_at && $dollar_at->isa( "Error::Simple" ), '$@->isa( "Error::Simple" ) after throw/catch' ); + +try { + throw Error::Simple( "message" ); +} +otherwise { + $arg_0 = shift; + $dollar_at = $@; +}; + +ok( defined $arg_0, 'defined( $_[0] ) after throw/otherwise' ); +ok( defined $dollar_at, 'defined( $@ ) after throw/otherwise' ); +ok( ref $arg_0 && $arg_0->isa( "Error::Simple" ), '$_[0]->isa( "Error::Simple" ) after throw/otherwise' ); +ok( ref $dollar_at && $dollar_at->isa( "Error::Simple" ), '$@->isa( "Error::Simple" ) after throw/otherwise' ); diff --git a/t/10throw-in-catch.t b/t/10throw-in-catch.t new file mode 100644 index 0000000..7d2af3e --- /dev/null +++ b/t/10throw-in-catch.t @@ -0,0 +1,41 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Error qw(:try); +use Test::More tests => 2; + +my ($error); + +eval +{ +try { + throw Error::Simple( "message" ); +} +catch Error::Simple with { + die "A-Lovely-Day"; +}; +}; +$error = $@; + +# TEST +ok (scalar($error =~ /^A-Lovely-Day/), + "Error thrown in the catch clause is registered" +); + +eval { +try { + throw Error::Simple( "message" ); +} +otherwise { + die "Had-the-ancient-greeks"; +}; +}; +$error = $@; + +# TEST +ok (scalar($error =~ /^Had-the-ancient/), + "Error thrown in the otherwise clause is registered" +); + diff --git a/t/11rethrow.t b/t/11rethrow.t new file mode 100644 index 0000000..227bca5 --- /dev/null +++ b/t/11rethrow.t @@ -0,0 +1,50 @@ +#!/usr/bin/perl + +use Error qw(:try); +use Test::More tests => 4; + +try { + try { die "inner" } + catch Error::Simple with { die "foobar" }; +} +otherwise +{ + my $err = shift; + # TEST + ok (scalar($err =~ /foobar/), "Error rethrown"); +}; + +try { + try { die "inner" } + catch Error::Simple with { throw Error::Simple "foobar" }; +} +otherwise +{ + my $err = shift; + # TEST + ok (scalar("$err" =~ /foobar/), "Thrown Error::Simple"); +}; + +try { + try { die "inner" } + otherwise { die "foobar" }; +} +otherwise +{ + my $err = shift; + # TEST + ok (scalar("$err" =~ /foobar/), "die foobar"); +}; + +try { + try { die "inner" } + catch Error::Simple with { throw Error::Simple "foobar" }; +} +otherwise +{ + my $err = shift; + # TEST + ok (scalar($err =~ /foobar/), "throw Error::Simple"); +}; + +1; diff --git a/t/12wrong-error-var.t b/t/12wrong-error-var.t new file mode 100644 index 0000000..888c723 --- /dev/null +++ b/t/12wrong-error-var.t @@ -0,0 +1,37 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 2; + +use Error qw(:try); + +try { + eval { + throw Error::Simple "This is caught by eval, not by try."; + }; + + # TEST + ok (($@ && $@ =~ /This is caught by eval, not by try/), + "Checking that eval { ... } is sane" + ); + + print "# Error::THROWN = $Error::THROWN\n"; + + die "This is a simple 'die' exception."; + + # not reached +} +otherwise { + my $E = shift; + my $t = $Error::THROWN ? "$Error::THROWN" : ''; + print "# Error::THROWN = $t\n"; + $E ||= ''; + print "# E = $E\n"; + + # TEST + ok ("$E" =~ /This is a simple 'die' exception/, + "Checking that the argument to otherwise is the thrown exception" + ); +}; diff --git a/t/13except-arg0.t b/t/13except-arg0.t new file mode 100644 index 0000000..5bc9497 --- /dev/null +++ b/t/13except-arg0.t @@ -0,0 +1,22 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Error qw(:try); +use Test::More tests => 2; + +my $arg_0; + +try { + throw Error::Simple( "message" ); +} +except { + $arg_0 = shift; + return { + 'Error::Simple' => sub {}, + }; +}; + +ok( defined $arg_0, 'defined( $_[0] ) after throw/except' ); +ok( ref $arg_0 && $arg_0->isa( "Error::Simple" ), '$_[0]->isa( "Error::Simple" ) after throw/except' ); diff --git a/t/lib/MyDie.pm b/t/lib/MyDie.pm new file mode 100644 index 0000000..21205c8 --- /dev/null +++ b/t/lib/MyDie.pm @@ -0,0 +1,19 @@ +package MyDie; + +sub mydie +{ + local *I; + open I, "<", "ChangeLog"; + my $s = <I>; + + + + + + + + + die "Hello"; +} + +1; diff --git a/t/pod-coverage.t b/t/pod-coverage.t new file mode 100644 index 0000000..703f91d --- /dev/null +++ b/t/pod-coverage.t @@ -0,0 +1,6 @@ +#!perl -T + +use Test::More; +eval "use Test::Pod::Coverage 1.04"; +plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@; +all_pod_coverage_ok(); @@ -0,0 +1,6 @@ +#!perl -T + +use Test::More; +eval "use Test::Pod 1.14"; +plan skip_all => "Test::Pod 1.14 required for testing POD" if $@; +all_pod_files_ok(); |