From 661707e7bd4282aeab5a2f6a8f02ca5731fd813f Mon Sep 17 00:00:00 2001 From: Lorry Tar Creator Date: Tue, 8 May 2012 18:20:12 +0000 Subject: Imported from /srv/lorry/lorry-area/error-perl-tarball/Error-0.17018.tar.gz. --- Build.PL | 21 + ChangeLog | 285 ++++++ MANIFEST | 34 + META.json | 55 ++ META.yml | 34 + Makefile.PL | 15 + README | 90 ++ examples/example.pl | 51 + examples/next-in-loop/Error.pm-eval.pl | 40 + examples/next-in-loop/Error.pm-next-label.pl | 38 + .../next-in-loop/Error.pm-next-out-of-catch.pl | 43 + examples/next-in-loop/Error.pm-next.pl | 37 + examples/next-in-loop/README | 3 + examples/warndie.pl | 23 + inc/Test/Run/Builder.pm | 65 ++ lib/Error.pm | 1039 ++++++++++++++++++++ lib/Error/Simple.pm | 58 ++ scripts/bump-version-number.pl | 43 + t/01throw.t | 25 + t/02order.t | 47 + t/03throw-non-Error.t | 32 + t/04use-base-Error-Simple.t | 18 + t/05text-errors-with-file-handles.t | 52 + t/06customize-text-throw.t | 66 ++ t/07try-in-obj-destructor.t | 42 + t/08warndie.t | 219 +++++ t/09dollar-at.t | 36 + t/10throw-in-catch.t | 41 + t/11rethrow.t | 50 + t/12wrong-error-var.t | 37 + t/13except-arg0.t | 22 + t/lib/MyDie.pm | 19 + t/pod-coverage.t | 6 + t/pod.t | 6 + 34 files changed, 2692 insertions(+) create mode 100644 Build.PL create mode 100644 ChangeLog create mode 100644 MANIFEST create mode 100644 META.json create mode 100644 META.yml create mode 100644 Makefile.PL create mode 100644 README create mode 100644 examples/example.pl create mode 100644 examples/next-in-loop/Error.pm-eval.pl create mode 100644 examples/next-in-loop/Error.pm-next-label.pl create mode 100644 examples/next-in-loop/Error.pm-next-out-of-catch.pl create mode 100644 examples/next-in-loop/Error.pm-next.pl create mode 100644 examples/next-in-loop/README create mode 100644 examples/warndie.pl create mode 100644 inc/Test/Run/Builder.pm create mode 100644 lib/Error.pm create mode 100644 lib/Error/Simple.pm create mode 100644 scripts/bump-version-number.pl create mode 100644 t/01throw.t create mode 100644 t/02order.t create mode 100644 t/03throw-non-Error.t create mode 100644 t/04use-base-Error-Simple.t create mode 100644 t/05text-errors-with-file-handles.t create mode 100644 t/06customize-text-throw.t create mode 100644 t/07try-in-obj-destructor.t create mode 100644 t/08warndie.t create mode 100644 t/09dollar-at.t create mode 100644 t/10throw-in-catch.t create mode 100644 t/11rethrow.t create mode 100644 t/12wrong-error-var.t create mode 100644 t/13except-arg0.t create mode 100644 t/lib/MyDie.pm create mode 100644 t/pod-coverage.t create mode 100644 t/pod.t 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 ', +); +$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 (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 (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 (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 (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 (Shlomi Fish) + + Error.pm #0.17014 + - Made Makefile.PL require perl-5.6.0 and above. + +May 22 2008 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (Shlomi Fish) + + Error.pm #0.17 + - Added some examples to the examples/ directory. + - Updated the MANIFEST. + +Jul 13 2006 (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 (Shlomi Fish) + + Error.pm #0.16 + - Bumped the version number to indicate a new number with no known + bugs. + +Apr 24 2006 (Shlomi Fish) + + Error.pm #0.15009 + - Added the flush() method from Alasdair Allan. + +Apr 07 2006 (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 (Shlomi Fish) + + Error.pm #0.15007 + - Fixed https://rt.cpan.org/Ticket/Display.html?id=3291 + +Apr 07 2006 (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 (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 (Shlomi Fish) + + Error.pm #0.15004 + - Added POD to the lib/Error/Simple.pm module. + +Mar 31 2006 (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 (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 (Arun Kumar U) + + Error.pm #0.15 + + - Removed the run_clauses calls from the stack trace + +May 12 2001 (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 (Graham Barr) + + Added ppd stuff to MANIFEST and Makefile.PL + +Change 435 on 2000/03/29 by (Graham Barr) + + Changed README to contain examples from the POD + +Change 434 on 2000/03/29 by (Graham Barr) + + Documentation updates + removed experimental warning, too many users now to change too much. + +Change 422 on 2000/03/28 by (Graham Barr) + + Some tidy-ups + +Change 145 on 1998/05/31 by (Graham Barr) + + Errno.pm + - Separated run_clauses out into a sub + +Oct 28 1997 + + Error.pm #0.12 + + - Removed proceed clause + +Oct 27 1997 + + Error.pm #0.11 + + - Fixed calling of otherwise clause if there are no catch claues + +Oct 21 1997 + + 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 + + - Added associate method so that an existing error may be associated + with an object. + +Oct 10 1997 + + - 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 " + ], + "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 ' +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 ', + ABSTRACT => 'Error/exception handling in an OO-ish way', + PL_FILES => {}, +); diff --git a/README b/README new file mode 100644 index 0000000..4405ccb --- /dev/null +++ b/README @@ -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 + + The code that inspired me to write this was originally written by + Peter Seibel and adapted by Jesse Glick + . + +MAINTAINER + + Arun Kumar U + + ===================== + +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 + + +------------------------------------------------------------------------------- + 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 . 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.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 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 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 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 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. The error will also be available in C<$@>. + +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. 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 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 COMPATIBILITY + +L exports a keyword called C 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 for the report.). + +=head1 CLASS INTERFACE + +=head2 CONSTRUCTORS + +The C 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 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 Error->new() + +See the Error::Simple documentation. + +=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 + +=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 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 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 also provides handlers to extend the output of the C perl +function, and to handle the printing of a thrown C that is not caught +or otherwise handled. These are not installed by default, but are requested +using the C<:warndie> tag in the C 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 provides. If this cannot be +avoided, then the tag can be explicitly Ced 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 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, +C, 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 aims to combine L and L +"with correct stringification". + +L and L 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 + +The code that inspired me to write this was originally written by +Peter Seibel and adapted by Jesse Glick +. + +C<:warndie> handlers added by Paul Evans + +=head1 MAINTAINER + +Shlomi Fish + +=head1 PAST MAINTAINERS + +Arun Kumar U + +=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 . 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 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 + 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 = ; + + + + + + + + + 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(); diff --git a/t/pod.t b/t/pod.t new file mode 100644 index 0000000..976d7cd --- /dev/null +++ b/t/pod.t @@ -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(); -- cgit v1.2.1