--- /dev/null
+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;
--- /dev/null
+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
--- /dev/null
+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
+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
--- /dev/null
+{
+ "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.113640",
+ "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.17017"
+ },
+ "Error::Simple" : {
+ "file" : "lib/Error.pm",
+ "version" : 0
+ },
+ "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.17017"
+}
--- /dev/null
+---
+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.113640'
+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.17017
+ Error::Simple:
+ file: lib/Error.pm
+ version: 0
+ 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.17017
--- /dev/null
+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 => {},
+);
--- /dev/null
+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
+-------------------------------------------------------------------------------
+
--- /dev/null
+
+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;
+}
+
--- /dev/null
+#!/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";
+}
+
--- /dev/null
+#!/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";
+}
--- /dev/null
+#!/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";
+}
--- /dev/null
+#!/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";
+}
--- /dev/null
+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.
--- /dev/null
+#!/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 );
--- /dev/null
+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;
+
--- /dev/null
+# Error.pm
+#
+# Copyright (c) 1997-8 Graham Barr <gbarr@ti.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+#
+# Based on my original Error.pm, and Exceptions.pm by Peter Seibel
+# <peter@weblogic.com> and adapted by Jesse Glick <jglick@sig.bsh.com>.
+#
+# but modified ***significantly***
+
+package Error;
+
+use strict;
+use vars qw($VERSION);
+use 5.004;
+
+$VERSION = "0.17017";
+
+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;
+
+@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
+
--- /dev/null
+# 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 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>
+
--- /dev/null
+
+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";;
--- /dev/null
+
+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";
--- /dev/null
+#!/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.");
--- /dev/null
+#!/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;
+
--- /dev/null
+#!/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");
+
--- /dev/null
+#!/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");
+}
--- /dev/null
+#!/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"
+);
+
+
--- /dev/null
+#!/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
--- /dev/null
+#!/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' );
--- /dev/null
+#!/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"
+);
+
--- /dev/null
+#!/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;
--- /dev/null
+#!/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"
+ );
+};
--- /dev/null
+#!/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' );
--- /dev/null
+package MyDie;
+
+sub mydie
+{
+ local *I;
+ open I, "<", "ChangeLog";
+ my $s = <I>;
+
+
+
+
+
+
+
+
+ die "Hello";
+}
+
+1;
--- /dev/null
+#!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();
--- /dev/null
+#!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();
projects / platform / upstream / perl-Error.git / commitdiff