[Date Prev][Date Next] [Thread Prev][Thread Next] [Date Index][Thread Index][Top&Search][Original]
[PATCH] autodie 1.991 patch
G'day everyone,
Attached is a single patch for autodie 1.991 generated against the latest
blead from git. All the tests that depend upon non-core modules should have
been omitted from this patch. It also completely supersedes the previous
patch sent to the list for autodie 1.99.
Comments, feedback, cpan ratings, etc all appreciated.
Cheerio,
Paul
--
Paul Fenwick <pjf@perltraining.com.au> | http://perltraining.com.au/
Director of Training | Ph: +61 3 9354 6001
Perl Training Australia | Fax: +61 3 9354 2681
>From fb692b17924f5f1a255e8e1ab6ad25cb727f6134 Mon Sep 17 00:00:00 2001
From: Paul Fenwick <pjf@perltraining.com.au>
Date: Thu, 28 Aug 2008 19:14:53 +1000
Subject: [PATCH] Merge of autodie 1.991 into core.
---
lib/Fatal.pm | 1014 +++++++++++++++++++++---
lib/autodie.pm | 281 +++++++
lib/autodie/exception.pm | 519 ++++++++++++
lib/autodie/exception/system.pm | 81 ++
t/lib/autodie/00-load.t | 9 +
t/lib/autodie/Fatal.t | 36 +
t/lib/autodie/autodie.t | 103 +++
t/lib/autodie/autodie_test_module.pm | 18 +
t/lib/autodie/backcompat.t | 14 +
t/lib/autodie/basic_exceptions.t | 27 +
t/lib/autodie/context.t | 66 ++
t/lib/autodie/context_lexical.t | 80 ++
t/lib/autodie/crickey.t | 27 +
t/lib/autodie/exceptions.t | 45 +
t/lib/autodie/exec.t | 12 +
t/lib/autodie/filehandles.t | 60 ++
t/lib/autodie/fileno.t | 35 +
t/lib/autodie/internal.t | 33 +
t/lib/autodie/lethal.t | 17 +
t/lib/autodie/lib/autodie/test/au.pm | 14 +
t/lib/autodie/lib/autodie/test/au/exception.pm | 19 +
t/lib/autodie/lib/lethal.pm | 8 +
t/lib/autodie/recv.t | 60 ++
t/lib/autodie/repeat.t | 19 +
t/lib/autodie/scope_leak.t | 37 +
t/lib/autodie/sysopen.t | 23 +
t/lib/autodie/usersub.t | 64 ++
t/lib/autodie/version.t | 17 +
28 files changed, 2620 insertions(+), 118 deletions(-)
create mode 100644 lib/autodie.pm
create mode 100644 lib/autodie/exception.pm
create mode 100644 lib/autodie/exception/system.pm
create mode 100755 t/lib/autodie/00-load.t
create mode 100755 t/lib/autodie/Fatal.t
create mode 100644 t/lib/autodie/autodie.t
create mode 100644 t/lib/autodie/autodie_test_module.pm
create mode 100644 t/lib/autodie/backcompat.t
create mode 100644 t/lib/autodie/basic_exceptions.t
create mode 100755 t/lib/autodie/context.t
create mode 100755 t/lib/autodie/context_lexical.t
create mode 100644 t/lib/autodie/crickey.t
create mode 100644 t/lib/autodie/exceptions.t
create mode 100644 t/lib/autodie/exec.t
create mode 100644 t/lib/autodie/filehandles.t
create mode 100644 t/lib/autodie/fileno.t
create mode 100755 t/lib/autodie/internal.t
create mode 100644 t/lib/autodie/lethal.t
create mode 100644 t/lib/autodie/lib/autodie/test/au.pm
create mode 100644 t/lib/autodie/lib/autodie/test/au/exception.pm
create mode 100644 t/lib/autodie/lib/lethal.pm
create mode 100644 t/lib/autodie/recv.t
create mode 100644 t/lib/autodie/repeat.t
create mode 100644 t/lib/autodie/scope_leak.t
create mode 100644 t/lib/autodie/sysopen.t
create mode 100755 t/lib/autodie/usersub.t
create mode 100644 t/lib/autodie/version.t
diff --git a/lib/Fatal.pm b/lib/Fatal.pm
index 0b4bf9b..82b70a7 100644
--- a/lib/Fatal.pm
+++ b/lib/Fatal.pm
@@ -1,137 +1,844 @@
package Fatal;
-use 5.006_001;
+use 5.008; # 5.8.x needed for autodie
use Carp;
use strict;
-our($AUTOLOAD, $Debug, $VERSION);
+use warnings;
-$VERSION = 1.06;
+use constant LEXICAL_TAG => q{:lexical};
+use constant VOID_TAG => q{:void};
-$Debug = 0 unless defined $Debug;
+use constant ERROR_NOARGS => 'Cannot use lexical %s with no arguments';
+use constant ERROR_VOID_LEX => VOID_TAG. 'cannot be used with lexical scope';
+use constant ERROR_LEX_FIRST => LEXICAL_TAG.' must be used as first argument';
+use constant ERROR_NO_LEX => "no %s can only start with ".LEXICAL_TAG;
+use constant ERROR_BADNAME => "Bad subroutine name for %s: %s";
+use constant ERROR_NOTSUB => "%s is not a Perl subroutine";
+use constant ERROR_NOT_BUILT => "%s is neither a builtin, nor a Perl subroutine";
+use constant ERROR_CANT_OVERRIDE => "Cannot make the non-overridable builtin %s fatal";
+
+use constant ERROR_NO_IPC_SYS_SIMPLE => "IPC::System::Simple required for Fatalised/autodying system()";
+
+use constant ERROR_IPC_SYS_SIMPLE_OLD => "IPC::System::Simple version %f required for Fatalised/autodying system(). We only have version %f";
+
+use constant ERROR_AUTODIE_CONFLICT => q{"no autodie '%s'" is not allowed while "use Fatal '%s'" is in effect};
+
+use constant ERROR_FATAL_CONFLICT => q{"use Fatal '%s'" is not allowed while "no autodie '%s'" is in effect};
+
+# Older versions of IPC::System::Simple don't support all the
+# features we need.
+
+use constant MIN_IPC_SYS_SIMPLE_VER => 0.12;
+
+# All the Fatal/autodie modules share the same version number.
+our $VERSION = '1.991';
+
+our $Debug ||= 0;
+
+# We have some tags that can be passed in for use with import.
+# These are all assumed to be CORE::
+
+my %TAGS = (
+ ':io' => [qw(:file :filesys :socket)],
+ ':file' => [qw(open close sysopen fcntl fileno)],
+ ':filesys' => [qw(opendir chdir)],
+ ':threads' => [qw(fork)],
+ ':system' => [qw(system exec)],
+
+ # Can we use qw(getpeername getsockname)? What do they do on failure?
+ # XXX - Can socket return false?
+ ':socket' => [qw(accept bind connect getsockopt listen recv send
+ setsockopt shutdown socketpair)],
+
+ # Our defaults don't include system(), because it depends upon
+ # an optional module, and it breaks the exotic form.
+ #
+ # This *may* change in the future. I'd love IPC::System::Simple
+ # to be a dependency rather than a recommendation, and hence for
+ # system() to be autodying by default.
+
+ ':default' => [qw(:io :threads)],
+);
+
+$TAGS{':all'} = [ keys %TAGS ];
+
+# This hash contains subroutines for which we should
+# subroutine() // die() rather than subroutine() || die()
+
+my %Use_defined_or;
+
+# CORE::open returns undef on failure. It can legitimately return
+# 0 on success, eg: open(my $fh, '-|') || exec(...);
+
+@Use_defined_or{qw(
+ CORE::fork
+ CORE::recv
+ CORE::send
+ CORE::open
+ CORE::fileno
+)} = ();
+
+# Cached_fatalised_sub caches the various versions of our
+# fatalised subs as they're produced. This means we don't
+# have to build our own replacement of CORE::open and friends
+# for every single package that wants to use them.
+
+my %Cached_fatalised_sub = ();
+
+# Every time we're called with package scope, we record the subroutine
+# (including package or CORE::) in %Package_Fatal. This allows us
+# to detect illegal combinations of autodie and Fatal, and makes sure
+# we don't accidently make a Fatal function autodying (which isn't
+# very useful).
+
+my %Package_Fatal = ();
+
+# The first time we're called with a user-sub, we cache it here.
+# In the case of a "no autodie ..." we put back the cached copy.
+
+my %Original_user_sub = ();
+
+# We use our package in a few hash-keys. Having it in a scalar is
+# convenient. The "guard $PACKAGE" string is used as a key when
+# setting up lexical guards.
+
+my $PACKAGE = __PACKAGE__;
+my $PACKAGE_GUARD = "guard $PACKAGE";
+my $NO_PACKAGE = "no $PACKAGE"; # Used to detect 'no autodie'
+
+# Here's where all the magic happens when someone write 'use Fatal'
+# or 'use autodie'.
sub import {
- my $self = shift(@_);
- my($sym, $pkg);
- my $void = 0;
- $pkg = (caller)[0];
- foreach $sym (@_) {
- if ($sym eq ":void") {
- $void = 1;
- }
- else {
- &_make_fatal($sym, $pkg, $void);
- }
- }
-};
-
-sub AUTOLOAD {
- my $cmd = $AUTOLOAD;
- $cmd =~ s/.*:://;
- &_make_fatal($cmd, (caller)[0]);
- goto &$AUTOLOAD;
+ my $class = shift(@_);
+ my $void = 0;
+ my $lexical = 0;
+
+ my ($pkg, $filename) = caller();
+
+ @_ or return; # 'use Fatal' is a no-op.
+
+ # If we see the :lexical flag, then _all_ arguments are
+ # changed lexically
+
+ if ($_[0] eq LEXICAL_TAG) {
+ $lexical = 1;
+ shift @_;
+
+ # If we see no arguments and :lexical, we assume they
+ # wanted ':default'.
+
+ if (@_ == 0) {
+ push(@_, ':default');
+ }
+
+ # Don't allow :lexical with :void, it's needlessly confusing.
+ if ( grep { $_ eq VOID_TAG } @_ ) {
+ croak(ERROR_VOID_LEX);
+ }
+ }
+
+ if ( grep { $_ eq LEXICAL_TAG } @_ ) {
+ # If we see the lexical tag as the non-first argument, complain.
+ croak(ERROR_LEX_FIRST);
+ }
+
+ my @fatalise_these = @_;
+
+ # Thiese subs will get unloaded at the end of lexical scope.
+ my %unload_later;
+
+ # This hash helps us track if we've alredy done work.
+ my %done_this;
+
+ # NB: we're using while/shift rather than foreach, since
+ # we'll be modifying the array as we walk through it.
+
+ while (my $func = shift @fatalise_these) {
+
+ if ($func eq VOID_TAG) {
+
+ # When we see :void, set the void flag.
+ $void = 1;
+
+ } elsif (exists $TAGS{$func}) {
+
+ # When it's a tag, expand it.
+ push(@fatalise_these, @{ $TAGS{$func} });
+
+ } else {
+
+ # Otherwise, fatalise it.
+
+ # If we've already made something fatal this call,
+ # then don't do it twice.
+
+ next if $done_this{$func};
+
+ # We're going to make a subroutine fatalistic.
+ # However if we're being invoked with 'use Fatal qw(x)'
+ # and we've already been called with 'no autodie qw(x)'
+ # in the same scope, we consider this to be an error.
+ # Mixing Fatal and autodie effects was considered to be
+ # needlessly confusing on p5p.
+
+ my $sub = $func;
+ $sub = "${pkg}::$sub" unless $sub =~ /::/;
+
+ # If we're being called as Fatal, and we've previously
+ # had a 'no X' in scope for the subroutine, then complain
+ # bitterly.
+
+ if (! $lexical and $^H{$NO_PACKAGE}{$sub}) {
+ croak(sprintf(ERROR_FATAL_CONFLICT, $func, $func));
+ }
+
+ # We're not being used in a confusing way, so make
+ # the sub fatal. Note that _make_fatal returns the
+ # old (original) version of the sub, or undef for
+ # built-ins.
+
+ my $sub_ref = $class->_make_fatal(
+ $func, $pkg, $void, $lexical, $filename
+ );
+
+ $done_this{$func}++;
+
+ $Original_user_sub{$sub} ||= $sub_ref;
+
+ # If we're making lexical changes, we need to arrange
+ # for them to be cleaned at the end of our scope, so
+ # record them here.
+
+ $unload_later{$func} = $sub_ref if $lexical;
+ }
+ }
+
+ if ($lexical) {
+
+ # Dark magic to have autodie work under 5.8
+ # Copied from namespace::clean, that copied it from
+ # autobox, that found it on an ancient scroll written
+ # in blood.
+
+ # This magic bit causes %^H to be lexically scoped.
+
+ $^H |= 0x020000;
+
+ # Our package guard gets invoked when we leave our lexical
+ # scope.
+
+ push(@ { $^H{$PACKAGE_GUARD} }, autodie::Scope::Guard->new(sub {
+ $class->_install_subs($pkg, \%unload_later);
+ }));
+
+ }
+
+ return;
+
}
+# The code here is originally lifted from namespace::clean,
+# by Robert "phaylon" Sedlacek.
+#
+# It's been redesigned after feedback from ikegami on perlmonks.
+# See http://perlmonks.org/?node_id=693338 . Ikegami rocks.
+#
+# Given a package, and hash of (subname => subref) pairs,
+# we install the given subroutines into the package. If
+# a subref is undef, the subroutine is removed. Otherwise
+# it replaces any existing subs which were already there.
+
+sub _install_subs {
+ my ($class, $pkg, $subs_to_reinstate) = @_;
+
+ my $pkg_sym = "${pkg}::";
+
+ while(my ($sub_name, $sub_ref) = each %$subs_to_reinstate) {
+
+ my $full_path = $pkg_sym.$sub_name;
+
+ # Copy symbols across to temp area.
+
+ no strict 'refs';
+
+ local *__tmp = *{ $full_path };
+
+ # Nuke the old glob.
+ { no strict; delete $pkg_sym->{$sub_name}; }
+
+ # Copy innocent bystanders back.
+
+ foreach my $slot (qw( SCALAR ARRAY HASH IO FORMAT ) ) {
+ next unless defined *__tmp{ $slot };
+ *{ $full_path } = *__tmp{ $slot };
+ }
+
+ # Put back the old sub (if there was one).
+
+ if ($sub_ref) {
+
+ no strict;
+ *{ $pkg_sym . $sub_name } = $sub_ref;
+ }
+ }
+
+ return;
+}
+
+sub unimport {
+ my $class = shift;
+
+ # Calling "no Fatal" must start with ":lexical"
+ if ($_[0] ne LEXICAL_TAG) {
+ croak(sprintf(ERROR_NO_LEX,$class));
+ }
+
+ shift @_; # Remove :lexical
+
+ my $pkg = (caller)[0];
+
+ # If we've been called with arguments, then the developer
+ # has explicitly stated 'no autodie qw(blah)',
+ # in which case, we disable Fatalistic behaviour for 'blah'.
+
+ my @unimport_these = @_ ? @_ : ':all';
+
+ while (my $symbol = shift @unimport_these) {
+
+ if ($symbol =~ /^:/) {
+
+ # Looks like a tag! Expand it!
+ push(@unimport_these, @{ $TAGS{$symbol} });
+
+ next;
+ }
+
+ my $sub = $symbol;
+ $sub = "${pkg}::$sub" unless $sub =~ /::/;
+
+ # If 'blah' was already enabled with Fatal (which has package
+ # scope) then, this is considered an error.
+
+ if (exists $Package_Fatal{$sub}) {
+ croak(sprintf(ERROR_AUTODIE_CONFLICT,$symbol,$symbol));
+ }
+
+ # Record 'no autodie qw($sub)' as being in effect.
+ # This is to catch conflicting semantics elsewhere
+ # (eg, mixing Fatal with no autodie)
+
+ $^H{$NO_PACKAGE}{$sub} = 1;
+
+ if (my $original_sub = $Original_user_sub{$sub}) {
+ # Hey, we've got an original one of these, put it back.
+ $class->_install_subs($pkg, { $symbol => $original_sub });
+ next;
+ }
+
+ # We don't have an original copy of the sub, on the assumption
+ # it's core (or doesn't exist), we'll just nuke it.
+
+ $class->_install_subs($pkg,{ $symbol => undef });
+
+ }
+
+ return;
+
+}
+
+# TODO - This is rather terribly inefficient right now.
+
+{
+ my %tag_cache;
+
+ sub _expand_tag {
+ my ($class, $tag) = @_;
+
+ if (my $cached = $tag_cache{$tag}) {
+ return $cached;
+ }
+
+ if (not exists $TAGS{$tag}) {
+ croak "Invalid exception class $tag";
+ }
+
+ my @to_process = @{$TAGS{$tag}};
+
+ my @taglist = ();
+
+ while (my $item = shift @to_process) {
+ if ($item =~ /^:/) {
+ push(@to_process, @{$TAGS{$item}} );
+ } else {
+ push(@taglist, "CORE::$item");
+ }
+ }
+
+ $tag_cache{$tag} = \@taglist;
+
+ return \@taglist;
+
+ }
+
+}
+
+# This code is from the original Fatal. It scares me.
+
sub fill_protos {
- my $proto = shift;
- my ($n, $isref, @out, @out1, $seen_semi) = -1;
- while ($proto =~ /\S/) {
- $n++;
- push(@out1,[$n,@out]) if $seen_semi;
- push(@out, $1 . "{\$_[$n]}"), next if $proto =~ s/^\s*\\([\@%\$\&])//;
- push(@out, "\$_[$n]"), next if $proto =~ s/^\s*([_*\$&])//;
- push(@out, "\@_[$n..\$#_]"), last if $proto =~ s/^\s*(;\s*)?\@//;
- $seen_semi = 1, $n--, next if $proto =~ s/^\s*;//; # XXXX ????
- die "Unknown prototype letters: \"$proto\"";
- }
- push(@out1,[$n+1,@out]);
- @out1;
+ my $proto = shift;
+ my ($n, $isref, @out, @out1, $seen_semi) = -1;
+ while ($proto =~ /\S/) {
+ $n++;
+ push(@out1,[$n,@out]) if $seen_semi;
+ push(@out, $1 . "{\$_[$n]}"), next if $proto =~ s/^\s*\\([\@%\$\&])//;
+ push(@out, "\$_[$n]"), next if $proto =~ s/^\s*([_*\$&])//;
+ push(@out, "\@_[$n..\$#_]"), last if $proto =~ s/^\s*(;\s*)?\@//;
+ $seen_semi = 1, $n--, next if $proto =~ s/^\s*;//; # XXXX ????
+ die "Internal error: Unknown prototype letters: \"$proto\"";
+ }
+ push(@out1,[$n+1,@out]);
+ return @out1;
}
+# This generates the code that will become our fatalised subroutine.
+
sub write_invocation {
- my ($core, $call, $name, $void, @argvs) = @_;
- if (@argvs == 1) { # No optional arguments
- my @argv = @{$argvs[0]};
- shift @argv;
- return "\t" . one_invocation($core, $call, $name, $void, @argv) . ";\n";
- } else {
- my $else = "\t";
- my (@out, @argv, $n);
- while (@argvs) {
- @argv = @{shift @argvs};
- $n = shift @argv;
- push @out, "$ {else}if (\@_ == $n) {\n";
- $else = "\t} els";
- push @out,
- "\t\treturn " . one_invocation($core, $call, $name, $void, @argv) . ";\n";
- }
- push @out, <<EOC;
- }
- die "$name(\@_): Do not expect to get ", scalar \@_, " arguments";
-EOC
- return join '', @out;
- }
+ my ($class, $core, $call, $name, $void, $lexical, $sub, @argvs) = @_;
+
+ if (@argvs == 1) { # No optional arguments
+
+ my @argv = @{$argvs[0]};
+ shift @argv;
+
+ return $class->one_invocation($core,$call,$name,$void,$sub,! $lexical,@argv);
+
+ } else {
+ my $else = "\t";
+ my (@out, @argv, $n);
+ while (@argvs) {
+ @argv = @{shift @argvs};
+ $n = shift @argv;
+
+ push @out, "${else}if (\@_ == $n) {\n";
+ $else = "\t} els";
+
+ push @out, $class->one_invocation($core,$call,$name,$void,$sub,! $lexical,@argv);
+ }
+ push @out, q[
+ }
+ die "Internal error: $name(\@_): Do not expect to get ", scalar \@_, " arguments";
+ ];
+
+ return join '', @out;
+ }
}
sub one_invocation {
- my ($core, $call, $name, $void, @argv) = @_;
- local $" = ', ';
- if ($void) {
- return qq/(defined wantarray)?$call(@argv):
- $call(@argv) || croak "Can't $name(\@_)/ .
- ($core ? ': $!' : ', \$! is \"$!\"') . '"'
- } else {
- return qq{$call(@argv) || croak "Can't $name(\@_)} .
- ($core ? ': $!' : ', \$! is \"$!\"') . '"';
- }
+ my ($class, $core, $call, $name, $void, $sub, $back_compat, @argv) = @_;
+
+ # If someone is calling us directly (a child class perhaps?) then
+ # they could try to mix void without enabling backwards
+ # compatibility. We just don't support this at all, so we gripe
+ # about it rather than doing something unwise.
+
+ if ($void and not $back_compat) {
+ Carp::confess("Internal error: :void mode not supported with $class");
+ }
+
+ # @argv only contains the results of the in-built prototype
+ # function, and is therefore safe to interpolate in the
+ # code generators below.
+
+ # TODO - The following clobbers context, but that's what the
+ # old Fatal did. Do we care?
+
+ if ($back_compat) {
+
+ # TODO - Use Fatal qw(system) is not yet supported. It should be!
+
+ if ($call eq 'CORE::system') {
+ return q{
+ croak("UNIMPLEMENTED: use Fatal qw(system) not yet supported.");
+ };
+ }
+
+ local $" = ', ';
+
+ if ($void) {
+ return qq/return (defined wantarray)?$call(@argv):
+ $call(@argv) || croak "Can't $name(\@_)/ .
+ ($core ? ': $!' : ', \$! is \"$!\"') . '"'
+ } else {
+ return qq{return $call(@argv) || croak "Can't $name(\@_)} .
+ ($core ? ': $!' : ', \$! is \"$!\"') . '"';
+ }
+ }
+
+ # The name of our original function is:
+ # $call if the function is CORE
+ # $sub if our function is non-CORE
+
+ # The reason for this is that $call is what we're actualling
+ # calling. For our core functions, this is always
+ # CORE::something. However for user-defined subs, we're about to
+ # replace whatever it is that we're calling; as such, we actually
+ # calling a subroutine ref.
+
+ # Unfortunately, none of this tells us the *ultimate* name.
+ # For example, if I export 'copy' from File::Copy, I'd like my
+ # ultimate name to be File::Copy::copy.
+ #
+ # TODO - Is there any way to find the ultimate name of a sub, as
+ # described above?
+
+ my $true_sub_name = $core ? $call : $sub;
+
+ if ($call eq 'CORE::system') {
+
+ # Leverage IPC::System::Simple if we're making an autodying
+ # system.
+
+ local $" = ", ";
+
+ # We need to stash $@ into $E, rather than using
+ # local $@ for the whole sub. If we don't then
+ # any exceptions from internal errors in autodie/Fatal
+ # will mysteriously disappear before propogating
+ # upwards.
+
+ return qq{
+ my \$retval;
+ my \$E;
+
+
+ {
+ local \$@;
+
+ eval {
+ \$retval = IPC::System::Simple::system(@argv);
+ };
+
+ \$E = \$@;
+ }
+
+ if (\$E) {
+
+ # XXX - TODO - This can't be overridden in child
+ # classes!
+
+ die autodie::exception::system->new(
+ function => q{CORE::system}, args => [ @argv ],
+ message => "\$E", errno => \$!,
+ );
+ }
+
+ return \$retval;
+ };
+
+ }
+
+
+ # Should we be testing to see if our result is defined, or
+ # just true?
+ my $use_defined_or = exists ( $Use_defined_or{$call} );
+
+ local $" = ', ';
+
+ # If we're going to throw an exception, here's the code to use.
+ my $die = qq{
+ die $class->throw(
+ function => q{$true_sub_name}, args => [ @argv ],
+ pragma => q{$class}, errno => \$!,
+ )
+ };
+
+ return qq{
+ if (wantarray) {
+ my \@results = $call(@argv);
+ # If we got back nothing, or we got back a single
+ # undef, we die.
+ if (! \@results or (\@results == 1 and ! defined \$results[0])) {
+ $die;
+ };
+ return \@results;
+ }
+
+ # Otherwise, we're in scalar context.
+ # We're never in a void context, since we have to look
+ # at the result.
+
+ my \$result = $call(@argv);
+
+ } . ( $use_defined_or ? qq{
+
+ $die if not defined \$result;
+
+ return \$result;
+
+ } : qq{
+
+ return \$result || $die;
+
+ } ) ;
+
}
+# This returns the old copy of the sub, so we can
+# put it back at end of scope.
+
+# TODO : Check to make sure prototypes are restored correctly.
+
+# TODO: Taking a huge list of arguments is awful. Rewriting to
+# take a hash would be lovely.
+
sub _make_fatal {
- my($sub, $pkg, $void) = @_;
+ my($class, $sub, $pkg, $void, $lexical, $filename) = @_;
my($name, $code, $sref, $real_proto, $proto, $core, $call);
my $ini = $sub;
$sub = "${pkg}::$sub" unless $sub =~ /::/;
+
+ # Figure if we're using lexical or package semantics and
+ # twiddle the appropriate bits.
+
+ if (not $lexical) {
+ $Package_Fatal{$sub} = 1;
+ }
+
+ # TODO - We *should* be able to do skipping, since we know when
+ # we've lexicalised / unlexicalised a subroutine.
+
$name = $sub;
$name =~ s/.*::// or $name =~ s/^&//;
- print "# _make_fatal: sub=$sub pkg=$pkg name=$name void=$void\n" if $Debug;
- croak "Bad subroutine name for Fatal: $name" unless $name =~ /^\w+$/;
- if (defined(&$sub)) { # user subroutine
- $sref = \&$sub;
- $proto = prototype $sref;
- $call = '&$sref';
+
+ warn "# _make_fatal: sub=$sub pkg=$pkg name=$name void=$void\n" if $Debug;
+ croak(sprintf(ERROR_BADNAME, $class, $name)) unless $name =~ /^\w+$/;
+
+ if (defined(&$sub)) { # user subroutine
+
+ # This could be something that we've fatalised that
+ # was in core.
+
+ local $@; # Don't clobber anyone else's $@
+
+ if ( $Package_Fatal{$sub} and eval { prototype "CORE::$name" } ) {
+
+ # Something we previously made Fatal that was core.
+ # This is safe to replace with an autodying to core
+ # version.
+
+ $core = 1;
+ $call = "CORE::$name";
+ $proto = prototype $call;
+
+ # We return our $sref from this subroutine later
+ # on, indicating this subroutine should be placed
+ # back when we're finished.
+
+ $sref = \&$sub;
+
+ } else {
+
+ # A regular user sub, or a user sub wrapping a
+ # core sub.
+
+ $sref = \&$sub;
+ $proto = prototype $sref;
+ $call = '&$sref';
+
+ }
+
} elsif ($sub eq $ini && $sub !~ /^CORE::GLOBAL::/) {
- # Stray user subroutine
- die "$sub is not a Perl subroutine"
- } else { # CORE subroutine
+ # Stray user subroutine
+ croak(sprintf(ERROR_NOTSUB,$sub));
+
+ } elsif ($name eq 'system') {
+
+ # If we're fatalising system, then we need to load
+ # helper code.
+
+ eval {
+ require IPC::System::Simple; # Only load it if we need it.
+ require autodie::exception::system;
+ };
+
+ if ($@) { croak ERROR_NO_IPC_SYS_SIMPLE; }
+
+ # Make sure we're using a recent version of ISS that actually
+ # support fatalised system.
+ if ($IPC::System::Simple::VERSION < MIN_IPC_SYS_SIMPLE_VER) {
+ croak sprintf(
+ ERROR_IPC_SYS_SIMPLE_OLD, MIN_IPC_SYS_SIMPLE_VER,
+ $IPC::System::Simple::VERSION
+ );
+ }
+
+ $call = 'CORE::system';
+ $name = 'system';
+
+ } elsif ($name eq 'exec') {
+ # Exec doesn't have a prototype. We don't care. This
+ # breaks the exotic form with lexical scope, and gives
+ # the regular form a "do or die" beaviour as expected.
+
+ $call = 'CORE::exec';
+ $name = 'exec';
+ $core = 1;
+
+ } else { # CORE subroutine
$proto = eval { prototype "CORE::$name" };
- die "$name is neither a builtin, nor a Perl subroutine"
- if $@;
- die "Cannot make the non-overridable builtin $name fatal"
- if not defined $proto;
- $core = 1;
- $call = "CORE::$name";
+ croak(sprintf(ERROR_NOT_BUILT,$name)) if $@;
+ croak(sprintf(ERROR_CANT_OVERRIDE,$name)) if not defined $proto;
+ $core = 1;
+ $call = "CORE::$name";
}
+
if (defined $proto) {
- $real_proto = " ($proto)";
+ $real_proto = " ($proto)";
} else {
- $real_proto = '';
- $proto = '@';
+ $real_proto = '';
+ $proto = '@';
}
- $code = <<EOS;
-sub$real_proto {
- local(\$", \$!) = (', ', 0);
-EOS
+
+ my $true_name = $core ? $call : $sub;
+
+ # TODO: This caching works, but I don't like using $void and
+ # $lexical as keys. In particular, I suspect our code may end up
+ # wrapping already wrapped code when autodie and Fatal are used
+ # together.
+
+ # NB: We must use '$sub' (the name plus package) and not
+ # just '$name' (the short name) here. Failing to do so
+ # results code that's in the wrong package, and hence has
+ # access to the wrong package filehandles.
+
+ if (my $subref = $Cached_fatalised_sub{$sub}{$void}{$lexical}) {
+ $class->_install_subs($pkg, { $name => $subref });
+ return $sref;
+ }
+
+ $code = qq[
+ sub$real_proto {
+ local(\$", \$!) = (', ', 0); # TODO - Why do we do this?
+ ];
+
+ # Don't have perl whine if exec fails, since we'll be handling
+ # the exception now.
+ $code .= "no warnings qw(exec);\n" if $call eq "CORE::exec";
+
my @protos = fill_protos($proto);
- $code .= write_invocation($core, $call, $name, $void, @protos);
+ $code .= $class->write_invocation($core, $call, $name, $void, $lexical, $sub, @protos);
$code .= "}\n";
- print $code if $Debug;
+ warn $code if $Debug;
+
+ # I thought that changing package was a monumental waste of
+ # time for CORE subs, since they'll always be the same. However
+ # that's not the case, since they may refer to package-based
+ # filehandles (eg, with open).
+ #
+ # There is potential to more aggressively cache core subs
+ # that we know will never want to interact with package variables
+ # and filehandles.
+
{
- no strict 'refs'; # to avoid: Can't use string (...) as a symbol ref ...
- $code = eval("package $pkg; use Carp; $code");
- die if $@;
- no warnings; # to avoid: Subroutine foo redefined ...
- *{$sub} = $code;
+ local $@;
+ no strict 'refs'; # to avoid: Can't use string (...) as a symbol ref ...
+ $code = eval("package $pkg; use Carp; $code");
+ Carp::confess("$@") if $@;
+ }
+
+ # Now we need to wrap our fatalised sub inside an itty bitty
+ # closure, which can detect if we've leaked into another file.
+ # Luckily, we only need to do this for lexical (autodie)
+ # subs. Fatal subs can leak all they want, it's considered
+ # a "feature" (or at least backwards compatible).
+
+ # TODO: Cache our leak guards!
+
+ # TODO: This is pretty hairy code. A lot more tests would
+ # be really nice for this.
+
+ my $leak_guard;
+
+ if ($lexical) {
+
+ $leak_guard = qq<
+ package $pkg;
+
+ sub$real_proto {
+
+ # If we're called from the correct file, then use the
+ # autodying code.
+ goto &\$code if ((caller)[1] eq \$filename);
+
+ # Oh bother, we've leaked into another file. Call the
+ # original code. Note that \$sref may actually be a
+ # reference to a Fatalised version of a core built-in.
+ # That's okay, because Fatal *always* leaks between files.
+
+ goto &\$sref if \$sref;
+ >;
+
+
+ # If we're here, it must have been a core subroutine called.
+ # Warning: The following code may disturb some viewers.
+
+ # TODO: It should be possible to combine this with
+ # write invocations.
+
+ foreach my $proto (@protos) {
+ local $" = ", "; # So @args is formatted correctly.
+ my ($count, @args) = @$proto;
+ $leak_guard .= qq<
+ if (\@_ == $count) {
+ return $call(@args);
+ }
+ >;
+ }
+
+ $leak_guard .= qq< croak "Internal error in Fatal/autodie. Leak-guard failure"; } >;
+
+ # warn "$leak_guard\n";
+
+ local $@;
+
+ $leak_guard = eval $leak_guard;
+
+ die "Internal error in $class: Leak-guard installation failure: $@" if $@;
}
+
+ $class->_install_subs($pkg, { $name => $leak_guard || $code });
+
+ $Cached_fatalised_sub{$sub}{$void}{$lexical} = $leak_guard || $code;
+
+ return $sref;
+
+}
+
+sub throw {
+ my ($class, @args) = @_;
+
+ require autodie::exception;
+ return autodie::exception->new(@args);
+}
+
+package autodie::Scope::Guard;
+
+# This code schedules the cleanup of subroutines at the end of
+# scope. It's directly inspired by chocolateboy's excellent
+# Scope::Guard module.
+
+sub new {
+ my ($class, $handler) = @_;
+
+ return bless $handler, $class;
+}
+
+sub DESTROY {
+ my ($self) = @_;
+
+ $self->();
}
1;
@@ -140,54 +847,125 @@ __END__
=head1 NAME
-Fatal - replace functions with equivalents which succeed or die
+Fatal - Replace functions with equivalents which succeed or die
=head1 SYNOPSIS
use Fatal qw(open close);
+ open(my $fh, "<", $filename); # No need to check errors!
+
+ use File::Copy qw(move);
+ use Fatal qw(move);
+
+ move($file1, $file2); # No need to check errors!
+
sub juggle { . . . }
- import Fatal 'juggle';
+ Fatal->import('juggle');
+
+=head1 BEST PRACTICE
+
+B<Fatal has been obsoleted by the new L<autodie> pragma.> Please use
+L<autodie> in preference to C<Fatal>. L<autodie> supports lexical scoping,
+throws real exception objects, and provides much nicer error messages.
+
+The use of C<:void> with Fatal is discouraged.
=head1 DESCRIPTION
-C<Fatal> provides a way to conveniently replace functions which normally
-return a false value when they fail with equivalents which raise exceptions
-if they are not successful. This lets you use these functions without
-having to test their return values explicitly on each call. Exceptions
-can be caught using C<eval{}>. See L<perlfunc> and L<perlvar> for details.
+C<Fatal> provides a way to conveniently replace
+functions which normally return a false value when they fail with
+equivalents which raise exceptions if they are not successful. This
+lets you use these functions without having to test their return
+values explicitly on each call. Exceptions can be caught using
+C<eval{}>. See L<perlfunc> and L<perlvar> for details.
The do-or-die equivalents are set up simply by calling Fatal's
C<import> routine, passing it the names of the functions to be
replaced. You may wrap both user-defined functions and overridable
-CORE operators (except C<exec>, C<system> which cannot be expressed
-via prototypes) in this way.
+CORE operators (except C<exec>, C<system>, C<print>, or any other
+built-in that cannot be expressed via prototypes) in this way.
If the symbol C<:void> appears in the import list, then functions
named later in that import list raise an exception only when
these are called in void context--that is, when their return
values are ignored. For example
- use Fatal qw/:void open close/;
+ use Fatal qw/:void open close/;
+
+ # properly checked, so no exception raised on error
+ if (not open(my $fh, '<' '/bogotic') {
+ warn "Can't open /bogotic: $!";
+ }
+
+ # not checked, so error raises an exception
+ close FH;
+
+The use of C<:void> is discouraged, as it can result in exceptions
+not being thrown if you I<accidentally> call a method without
+void context. Use L<autodie> instead if you need to be able to
+disable autodying/Fatal behaviour for a small block of code.
- # properly checked, so no exception raised on error
- if(open(FH, "< /bogotic") {
- warn "bogo file, dude: $!";
- }
+=head1 DIAGNOSTICS
- # not checked, so error raises an exception
- close FH;
+=over 4
+
+=item Bad subroutine name for Fatal: %s
+
+You've called C<Fatal> with an argument that doesn't look like
+a subroutine name, nor a switch that this version of Fatal
+understands.
+
+=item %s is not a Perl subroutine
+
+You've asked C<Fatal> to try and replace a subroutine which does not
+exist, or has not yet been defined.
+
+=item %s is neither a builtin, nor a Perl subroutine
+
+You've asked C<Fatal> to replace a subroutine, but it's not a Perl
+built-in, and C<Fatal> couldn't find it as a regular subroutine.
+It either doesn't exist or has not yet been defined.
+
+=item Cannot make the non-overridable %s fatal
+
+You've tried to use C<Fatal> on a Perl built-in that can't be
+overridden, such as C<print> or C<system>, which means that
+C<Fatal> can't help you, although some other modules might.
+See the L</"SEE ALSO"> section of this documentation.
+
+=item Internal error: %s
+
+You've found a bug in C<Fatal>. Please report it using
+the C<perlbug> command.
+
+=back
=head1 BUGS
-You should not fatalize functions that are called in list context, because this
-module tests whether a function has failed by testing the boolean truth of its
-return value in scalar context.
+C<Fatal> clobbers the context in which a function is called and always
+makes it a scalar context, except when the C<:void> tag is used.
+This problem does not exist in L<autodie>.
=head1 AUTHOR
-Lionel Cons (CERN).
+Original module by Lionel Cons (CERN).
Prototype updates by Ilya Zakharevich <ilya@math.ohio-state.edu>.
+L<autodie> support, bugfixes, extended diagnostics, C<system>
+support, and major overhauling by Paul Fenwick <pjf@perltraining.com.au>
+
+=head1 LICENSE
+
+This module is free software, you may distribute it under the
+same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<autodie> for a nicer way to use lexical Fatal.
+
+L<IPC::System::Simple> for a similar idea for calls to C<system()>
+and backticks.
+
=cut
diff --git a/lib/autodie.pm b/lib/autodie.pm
new file mode 100644
index 0000000..d6feb2c
--- /dev/null
+++ b/lib/autodie.pm
@@ -0,0 +1,281 @@
+package autodie;
+use 5.008;
+use strict;
+use warnings;
+
+use Fatal ();
+our @ISA = qw(Fatal);
+our $VERSION;
+
+BEGIN {
+ $VERSION = "1.991";
+}
+
+use constant ERROR_WRONG_FATAL => q{
+Incorrect version of Fatal.pm loaded by autodie.
+
+The autodie pragma uses an updated version of Fatal to do its
+heavy lifting. We seem to have loaded Fatal version %s, which is
+probably the version that came with your version of Perl. However
+autodie needs version %s, which would have come bundled with
+autodie.
+
+You may be able to solve this problem by adding the following
+line of code to your main program, before any use of Fatal or
+autodie.
+
+ use lib "%s";
+
+};
+
+# We have to check we've got the right version of Fatal before we
+# try to compile the rest of our code, lest we use a constant
+# that doesn't exist.
+
+BEGIN {
+
+ # If we have the wrong Fatal, then we've probably loaded the system
+ # one, not our own. Complain, and give a useful hint. ;)
+
+ if ($Fatal::VERSION ne $VERSION) {
+ my $autodie_path = $INC{'autodie.pm'};
+
+ $autodie_path =~ s/autodie\.pm//;
+
+ require Carp;
+
+ Carp::croak sprintf(
+ ERROR_WRONG_FATAL, $Fatal::VERSION, $VERSION, $autodie_path
+ );
+ }
+}
+
+# When passing args to Fatal we want to keep the first arg
+# (our package) in place. Hence the splice.
+
+sub import {
+ splice(@_,1,0,Fatal::LEXICAL_TAG);
+ goto &Fatal::import;
+}
+
+sub unimport {
+ splice(@_,1,0,Fatal::LEXICAL_TAG);
+ goto &Fatal::unimport;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+autodie - Replace functions with ones that succeed or die with lexical scope
+
+=head1 SYNOPSIS
+
+ use autodie; # Recommended, implies 'use autodie qw(:default)'
+
+ use autodie qw(open close); # open/close succeed or die
+
+ open(my $fh, "<", $filename); # No need to check!
+
+ {
+ no autodie qw(open); # open failures won't die
+ open(my $fh, "<", $filename); # Could fail silently!
+ no autodie; # disable all autodies
+ }
+
+=head1 DESCRIPTION
+
+ bIlujDI' yIchegh()Qo'; yIHegh()!
+
+ It is better to die() than to return() in failure.
+
+ -- Klingon programming proverb.
+
+The C<autodie> pragma provides a convenient way to replace functions
+that normally return false on failure with equivalents that throw
+an exception on failure.
+
+The C<autodie> pragma has I<lexical scope>, meaning that functions
+and subroutines altered with C<autodie> will only change their behaviour
+until the end of the enclosing block, file, or C<eval>.
+
+If C<system> is specified as an argument to C<autodie>, then it
+uses L<IPC::System::Simple> to do the heavy lifting. See the
+description of that module for more information.
+
+=head1 EXCEPTIONS
+
+Exceptions produced by the C<autodie> pragma are members of the
+L<autodie::exception> class. The preferred way to work with
+these exceptions under Perl 5.10 is as follows:
+
+ use feature qw(switch);
+
+ eval {
+ use autodie;
+
+ open(my $fh, '<', $some_file);
+
+ my @records = <$fh>;
+
+ # Do things with @records...
+
+ close($fh);
+
+ };
+
+ given ($@) {
+ when (undef) { say "No error"; }
+ when ('open') { say "Error from open"; }
+ when (':io') { say "Non-open, IO error."; }
+ when (':all') { say "All other autodie errors." }
+ default { say "Not an autodie error at all." }
+ }
+
+Under Perl 5.8, the C<given/when> structure is not available, so the
+following structure may be used:
+
+ eval {
+ use autodie;
+
+ open(my $fh, '<', $some_file);
+
+ my @records = <$fh>;
+
+ # Do things with @records...
+
+ close($fh);
+ };
+
+ if ($@ and $@->isa('autodie::exception')) {
+ if ($@->matches('open')) { print "Error from open\n"; }
+ if ($@->matches(':io' )) { print "Non-open, IO error."; }
+ } elsif ($@) {
+ # A non-autodie exception.
+ }
+
+See L<autodie::exception> for further information on interrogating
+exceptions.
+
+=head1 CATEGORIES
+
+Autodie uses a simple set of categories to group together similar
+built-ins. Requesting a category type (starting with a colon) will
+enable autodie for all built-ins beneath that category. For example,
+requesting C<:file> will enable autodie for C<close>, C<fcntl>,
+C<fileno>, C<open> and C<sysopen>.
+
+The categories are currently:
+
+ :all
+ :default
+ :io
+ :file
+ close
+ fcntl
+ fileno
+ open
+ sysopen
+ :filesys
+ opendir
+ :socket
+ accept
+ bind
+ connect
+ getsockopt
+ listen
+ recv
+ send
+ setsockopt
+ shutdown
+ socketpair
+ :threads
+ fork
+ :system
+ system
+ exec
+
+
+A plain C<use autodie> implies C<use autodie qw(:default)>. Note that
+C<system> and C<exec> are not enabled by default. C<system> requires
+the optional L<IPC::System::Simple> module to be installed, and enabling
+C<system> or C<exec> will invalidate their exotic forms. See L</BUGS>
+below for more details.
+
+Note that while the above category system is presently a strict
+hierarchy, this should not be assumed.
+
+=head1 GOTCHAS
+
+Functions called in list context are assumed to have failed if they
+return an empty list, or a list consisting only of a single undef
+element.
+
+=head1 DIAGNOSTICS
+
+=over 4
+
+=item :void cannot be used with lexical scope
+
+The C<:void> option is supported in L<Fatal>, but not
+C<autodie>. However you can explicitly disable autodie
+end the end of the current block with C<no autodie>.
+To disable autodie for only a single function (eg, open)
+use or C<no autodie qw(open)>.
+
+=back
+
+See also L<Fatal/DIAGNOSTICS>.
+
+=head1 BUGS
+
+Applying C<autodie> to C<system> or C<exec> causes the exotic
+forms C<system { $cmd } @args > or C<exec { $cmd } @args>
+to be considered a syntax error until the end of the lexical scope.
+If you really need to use the exotic form, you can call C<CORE::system>
+or C<CORE::exec> instead, or use C<no autodie qw(system exec)> before
+calling the exotic form.
+
+"Used only once" warnings can be generated when C<autodie> or C<Fatal>
+is used with package filehandles (eg, C<FILE>). It's strongly recommended
+you use scalar filehandles instead.
+
+When using C<autodie> or C<Fatal> with user subroutines, the
+declaration of those subroutines must appear before the first use of
+C<Fatal> or C<autodie>, or have been exported from a module.
+Attempting to ue C<Fatal> or C<autodie> on other user subroutines will
+result in a compile-time error.
+
+A TODO list of items remaining for improvement can be found in
+the development tree for the module at
+L<http://github.com/pfenwick/autodie/tree/master/TODO>.
+
+=head2 REPORTING BUGS
+
+Please report bugs via the CPAN Request Tracker at
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=autodie>.
+
+=head1 AUTHOR
+
+Copyright 2008, Paul Fenwick E<lt>pjf@perltraining.com.auE<gt>
+
+=head1 LICENSE
+
+This module is free software. You may distribute it under the
+same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<Fatal>, L<autodie::exception>, L<IPC::System::Simple>
+
+=head1 ACKNOWLEDGEMENTS
+
+Mark Reed and Roland Giersig -- Klingon translators.
+
+See the F<AUTHORS> file for full credits. The latest version of this
+file can be found at
+L<http://github.com/pfenwick/autodie/tree/AUTHORS> .
+
+=cut
diff --git a/lib/autodie/exception.pm b/lib/autodie/exception.pm
new file mode 100644
index 0000000..86cdad7
--- /dev/null
+++ b/lib/autodie/exception.pm
@@ -0,0 +1,519 @@
+package autodie::exception;
+use 5.008;
+use strict;
+use warnings;
+use Carp qw(croak);
+
+our $DEBUG = 0;
+
+use overload
+ q{""} => "stringify"
+;
+
+# Overload smart-match only if we're using 5.10
+
+use if ($] >= 5.010), overload => '~~' => "matches";
+
+our $VERSION = '1.991';
+
+my $PACKAGE = __PACKAGE__; # Useful to have a scalar for hash keys.
+
+=head1 NAME
+
+autodie::exception - Exceptions from autodying functions.
+
+=head1 SYNOPSIS
+
+ eval {
+ use autodie;
+
+ open(my $fh, '<', 'some_file.txt');
+
+ ...
+ };
+
+ if (my $E = $@) {
+ say "Ooops! ",$E->caller," had problems: $@";
+ }
+
+
+=head1 DESCRIPTION
+
+When an L<autodie> enabled function fails, it generates an
+C<autodie::exception> object. This can be interrogated to
+determine further information about the error that occurred.
+
+This document is broken into two sections; those methods that
+are most useful to the end-developer, and those methods for
+anyone wishing to subclass or get very familiar with
+C<autodie::exception>.
+
+=head2 Common Methods
+
+These methods are intended to be used in the everyday dealing
+of exceptions.
+
+The following assume that the error has been copied into
+a separate scalar:
+
+ if ($E = $@) {
+ ...
+ }
+
+This is not required, but is recommended in case any code
+is called which may reset or alter C<$@>.
+
+=cut
+
+=head3 args
+
+ my $array_ref = $E->args;
+
+Provides a reference to the arguments passed to the subroutine
+that died.
+
+=cut
+
+sub args { return $_[0]->{$PACKAGE}{args}; }
+
+=head3 function
+
+ my $sub = $E->function;
+
+The subroutine (including package) that threw the exception.
+
+=cut
+
+sub function { return $_[0]->{$PACKAGE}{function}; }
+
+=head3 file
+
+ my $file = $E->file;
+
+The file in which the error occurred (eg, C<myscript.pl> or
+C<MyTest.pm>).
+
+=cut
+
+sub file { return $_[0]->{$PACKAGE}{file}; }
+
+=head3 package
+
+ my $package = $E->package;
+
+The package from which the exceptional subroutine was called.
+
+=cut
+
+sub package { return $_[0]->{$PACKAGE}{package}; }
+
+=head3 caller
+
+ my $caller = $E->caller;
+
+The subroutine that I<called> the exceptional code.
+
+=cut
+
+sub caller { return $_[0]->{$PACKAGE}{caller}; }
+
+=head3 line
+
+ my $line = $E->line;
+
+The line in C<< $E->file >> where the exceptional code was called.
+
+=cut
+
+sub line { return $_[0]->{$PACKAGE}{line}; }
+
+=head3 errno
+
+ my $errno = $E->errno;
+
+The value of C<$!> at the time when the exception occurred.
+
+B<NOTE>: This method will leave the main C<autodie::exception> class
+and become part of a role in the future. You should only call
+C<errno> for exceptions where C<$!> would reasonably have been
+set on failure.
+
+=cut
+
+# TODO: Make errno part of a role. It doesn't make sense for
+# everything.
+
+sub errno { return $_[0]->{$PACKAGE}{errno}; }
+
+=head3 matches
+
+ if ( $e->matches('open') ) { ... }
+
+ if ( $e ~~ 'open' ) { ... }
+
+C<matches> is used to determine whether a
+given exception matches a particular role. On Perl 5.10,
+using smart-match (C<~~>) with an C<autodie::exception> object
+will use C<matches> underneath.
+
+An exception is considered to match a string if:
+
+=over 4
+
+=item *
+
+For a string not starting with a colon, the string exactly matches the
+package and subroutine that threw the exception. For example,
+C<MyModule::log>. If the string does not contain a package name,
+C<CORE::> is assumed.
+
+=item *
+
+For a string that does start with a colon, if the subroutine
+throwing the exception I<does> that behaviour. For example, the
+C<CORE::open> subroutine does C<:file>, C<:io> and C<:all>.
+
+See L<autodie/CATEGORIES> for futher information.
+
+=back
+
+=cut
+
+{
+ my (%cache);
+
+ sub matches {
+ my ($this, $that) = @_;
+
+ # XXX - Handle references
+ croak "UNIMPLEMENTED" if ref $that;
+
+ my $sub = $this->function;
+
+ if ($DEBUG) {
+ my $sub2 = $this->function;
+ warn "Smart-matching $that against $sub / $sub2\n";
+ }
+
+ # Direct subname match.
+ return 1 if $that eq $sub;
+ return 1 if $that !~ /:/ and "CORE::$that" eq $sub;
+ return 0 if $that !~ /^:/;
+
+ # Cached match / check tags.
+ require Fatal;
+
+ if (exists $cache{$sub}{$that}) {
+ return $cache{$sub}{$that};
+ }
+
+ # This rather awful looking line checks to see if our sub is in the
+ # list of expanded tags, caches it, and returns the result.
+
+ return $cache{$sub}{$that} = grep { $_ eq $sub } @{ $this->_expand_tag($that) };
+ }
+}
+
+# This exists primarily so that child classes can override or
+# augment it if they wish.
+
+sub _expand_tag {
+ my ($this, @args) = @_;
+
+ return Fatal->_expand_tag(@args);
+}
+
+=head2 Advanced methods
+
+The following methods, while usable from anywhere, are primarily
+intended for developers wishing to subclass C<autodie::exception>,
+write code that registers custom error messages, or otherwise
+work closely with the C<autodie::exception> model.
+
+=cut
+
+# The table below records customer formatters.
+# TODO - Should this be a package var instead?
+# TODO - Should these be in a completely different file, or
+# perhaps loaded on demand? Most formatters will never
+# get used in most programs.
+
+my %formatter_of = (
+ 'CORE::close' => \&_format_close,
+ 'CORE::open' => \&_format_open,
+);
+
+# Default formatter for CORE::close
+
+sub _format_close {
+ my ($this) = @_;
+ my $close_arg = $this->args->[0];
+
+ local $! = $this->errno;
+
+ # If we've got an old-style filehandle, mention it.
+ if ($close_arg and not ref $close_arg) {
+ return "Can't close filehandle '$close_arg': '$!'";
+ }
+
+ return "Can't close($close_arg) filehandle: '$!'";
+
+}
+
+# Default formatter for CORE::open
+# Currently only works with 3-arg open.
+# TODO: Pretty printing for 2-arg (and 1-arg?) open.
+
+sub _format_open {
+ my ($this) = @_;
+
+ my @open_args = @{$this->args};
+
+ # We'll only handle 3 argument open for the moment.
+ if (@open_args != 3) {
+ return $this->format_default;
+ }
+
+ my $file = $open_args[2];
+
+ local $! = $this->errno;
+
+ my $mode = $open_args[1];
+
+ if ($mode eq '<') { return "Can't open '$file' for reading: '$!'" }
+ elsif ($mode eq '>') { return "Can't open '$file' for writing: '$!'" }
+ elsif ($mode eq '>>') { return "Can't open '$file' for appending: '$!'" }
+
+ # Default message (for pipes and odd things)
+
+ return "Can't open '$file' with mode '$open_args[1]': '$!'";
+}
+
+=head3 register
+
+ autodie::exception->register( 'CORE::open' => \&mysub );
+
+The C<register> method allows for the registration of a message
+handler for a given subroutine. The full subroutine name including
+the package should be used.
+
+Registered message handlers will receive the C<autodie::exception>
+object as the first parameter.
+
+=cut
+
+sub register {
+ my ($class, $symbol, $handler) = @_;
+
+ croak "Incorrect call to autodie::register" if @_ != 3;
+
+ $formatter_of{$symbol} = $handler;
+
+}
+
+=head3 add_file_and_line
+
+ say "Problem occurred",$@->add_file_and_line;
+
+Returns the string C< at %s line %d>, where C<%s> is replaced with
+the filename, and C<%d> is replaced with the line number.
+
+Primarily intended for use by format handlers.
+
+=cut
+
+# Simply produces the file and line number; intended to be added
+# to the end of error messages.
+
+sub add_file_and_line {
+ my ($this) = @_;
+
+ return sprintf(" at %s line %d\n", $this->file, $this->line);
+}
+
+=head3 stringify
+
+ say "The error was: ",$@->stringify;
+
+Formats the error as a human readable string. Usually there's no
+reason to call this directly, as it is used automatically if an
+C<autodie::exception> object is ever used as a string.
+
+Child classes can override this method to change how they're
+stringified.
+
+=cut
+
+sub stringify {
+ my ($this) = @_;
+
+ my $call = $this->function;
+
+ if ($DEBUG) {
+ my $dying_pkg = $this->package;
+ my $sub = $this->function;
+ my $caller = $this->caller;
+ warn "Stringifing exception for $dying_pkg :: $sub / $caller / $call\n";
+ }
+
+ # TODO - This isn't using inheritance. Should it?
+ if ( my $sub = $formatter_of{$call} ) {
+ return $sub->($this) . $this->add_file_and_line;
+ }
+
+ return $this->format_default;
+
+}
+
+=head3 format_default
+
+ my $error_string = $E->format_default;
+
+This produces the default error string for the given exception,
+I<without using any registered message handlers>. It is primarily
+intended to be called from a message handler when they have
+been passed an exception they don't want to format.
+
+Child classes can override this method to change how default
+messages are formatted.
+
+=cut
+
+# TODO: This produces ugly errors. Is there any way we can
+# dig around to find the actual variable names? I know perl 5.10
+# does some dark and terrible magicks to find them for undef warnings.
+
+sub format_default {
+ my ($this) = @_;
+
+ my $call = $this->function;
+
+ local $! = $this->errno;
+
+ # TODO: This is probably a good idea for CORE, is it
+ # a good idea for other subs?
+
+ # Trim package name off dying sub for error messages.
+ $call =~ s/.*:://;
+
+ return "Can't $call(".
+ join(q{, }, map { defined($_) ? "'$_'" : "undef" } @{$this->args()}) . "): $!" .
+ $this->add_file_and_line;
+
+ # TODO - Handle user-defined errors from hash.
+
+ # TODO - Handle default error messages.
+
+}
+
+=head3 new
+
+ my $error = autodie::exception->new(
+ args => \@_,
+ function => "CORE::open",
+ errno => $!,
+ );
+
+
+Creates a new C<autodie::exception> object. Normally called
+directly from an autodying function. The C<function> argument
+is required, its the function we were trying to call that
+generated the exception. The C<args> parameter is optional.
+
+The C<errno> value is optional. In versions of C<autodie::exception>
+1.99 and earlier the code would try to automatically use the
+current value of C<$!>, but this was unreliable and is no longer
+supported.
+
+Atrributes such as package, file, and caller are determined
+automatically, and cannot be specified.
+
+=cut
+
+sub new {
+ my ($class, @args) = @_;
+
+ my $this = {};
+
+ bless($this,$class);
+
+ # I'd love to use EVERY here, but it causes our code to die
+ # because it wants to stringify our objects before they're
+ # initialised, causing everything to explode.
+
+ $this->_init(@args);
+
+ return $this;
+}
+
+sub _init {
+
+ my ($this, %args) = @_;
+
+ # Capturing errno here is not necessarily reliable.
+ my $original_errno = $!;
+
+ our $init_called = 1;
+
+ my $class = ref $this;
+
+ # We're going to walk up our call stack, looking for the
+ # first thing that doesn't look like our exception
+ # code, autodie/Fatal, or some whacky eval.
+
+ my ($package, $file, $line, $sub);
+
+ my $depth = 0;
+
+ while (1) {
+ $depth++;
+
+ ($package, $file, $line, $sub) = CORE::caller($depth);
+
+ # Skip up the call stack until we find something outside
+ # of the Fatal/autodie/eval space.
+
+ next if $package->isa('Fatal');
+ next if $package->isa($class);
+ next if $package->isa(__PACKAGE__);
+ next if $file =~ /^\(eval\s\d+\)$/;
+
+ last;
+
+ }
+
+ $this->{$PACKAGE}{package} = $package;
+ $this->{$PACKAGE}{file} = $file;
+ $this->{$PACKAGE}{line} = $line;
+ $this->{$PACKAGE}{caller} = $sub;
+ $this->{$PACKAGE}{package} = $package;
+
+ $this->{$PACKAGE}{errno} = $args{errno} || 0;
+
+ $this->{$PACKAGE}{args} = $args{args} || [];
+ $this->{$PACKAGE}{function}= $args{function} or
+ croak("$class->new() called without function arg");
+
+ return $this;
+
+}
+
+1;
+
+__END__
+
+=head1 SEE ALSO
+
+L<autodie>, L<autodie::exception::system>
+
+=head1 LICENSE
+
+Copyright (C)2008 Paul Fenwick
+
+This is free software. You may modify and/or redistribute this
+code under the same terms as Perl 5.10 itself, or, at your option,
+any later version of Perl 5.
+
+=head1 AUTHOR
+
+Paul Fenwick E<lt>pjf@perltraining.com.auE<gt>
diff --git a/lib/autodie/exception/system.pm b/lib/autodie/exception/system.pm
new file mode 100644
index 0000000..6764745
--- /dev/null
+++ b/lib/autodie/exception/system.pm
@@ -0,0 +1,81 @@
+package autodie::exception::system;
+use 5.008;
+use strict;
+use warnings;
+use base 'autodie::exception';
+use Carp qw(croak);
+
+our $VERSION = '1.991';
+
+my $PACKAGE = __PACKAGE__;
+
+=head1 NAME
+
+autodie::exception::system - Exceptions from autodying system().
+
+=head1 SYNOPSIS
+
+ eval {
+ use autodie;
+
+ system($cmd, @args);
+
+ };
+
+ if (my $E = $@) {
+ say "Ooops! ",$E->caller," had problems: $@";
+ }
+
+
+=head1 DESCRIPTION
+
+This is a L<autodie::exception> class for failures from the
+C<system> command.
+
+Presently there is no way to interrogate an C<autodie::exception::system>
+object for the command, exit status, and other information you'd expect
+such an object to hold. The interface will be expanded to accommodate
+this in the future.
+
+=cut
+
+sub _init {
+ my ($this, %args) = @_;
+
+ $this->{$PACKAGE}{message} = $args{message}
+ || croak "'message' arg not supplied to autodie::exception::system->new";
+
+ return $this->SUPER::_init(%args);
+
+}
+
+=head2 stringify
+
+When stringified, C<autodie::exception::system> objects currently
+use the message generated by L<IPC::System::Simple>.
+
+=cut
+
+sub stringify {
+
+ my ($this) = @_;
+
+ return $this->{$PACKAGE}{message} . $this->add_file_and_line;
+
+}
+
+1;
+
+__END__
+
+=head1 LICENSE
+
+Copyright (C)2008 Paul Fenwick
+
+This is free software. You may modify and/or redistribute this
+code under the same terms as Perl 5.10 itself, or, at your option,
+any later version of Perl 5.
+
+=head1 AUTHOR
+
+Paul Fenwick E<lt>pjf@perltraining.com.auE<gt>
diff --git a/t/lib/autodie/00-load.t b/t/lib/autodie/00-load.t
new file mode 100755
index 0000000..d07fcae
--- /dev/null
+++ b/t/lib/autodie/00-load.t
@@ -0,0 +1,9 @@
+#!perl -T
+
+use Test::More tests => 1;
+
+BEGIN {
+ use_ok( 'Fatal' );
+}
+
+# diag( "Testing Fatal $Fatal::VERSION, Perl $], $^X" );
diff --git a/t/lib/autodie/Fatal.t b/t/lib/autodie/Fatal.t
new file mode 100755
index 0000000..a291837
--- /dev/null
+++ b/t/lib/autodie/Fatal.t
@@ -0,0 +1,36 @@
+#!/usr/bin/perl -w
+use strict;
+
+use constant NO_SUCH_FILE => "this_file_or_dir_had_better_not_exist_XYZZY";
+
+use Test::More tests => 17;
+
+use Fatal qw(open close :void opendir);
+
+eval { open FOO, "<".NO_SUCH_FILE }; # Two arg open
+like($@, qr/^Can't open/, q{Package Fatal::open});
+is(ref $@, "", "Regular fatal throws a string");
+
+my $foo = 'FOO';
+for ('$foo', "'$foo'", "*$foo", "\\*$foo") {
+ eval qq{ open $_, '<$0' };
+
+ is($@,"", "Open using filehandle named - $_");
+
+ like(scalar(<$foo>), qr{^#!.*/perl}, "File contents using - $_");
+ eval qq{ close FOO };
+
+ is($@,"", "Close filehandle using - $_");
+}
+
+eval { opendir FOO, NO_SUCH_FILE };
+like($@, qr{^Can't open}, "Package :void Fatal::opendir");
+
+eval { my $a = opendir FOO, NO_SUCH_FILE };
+is($@, "", "Package :void Fatal::opendir in scalar context");
+
+eval { Fatal->import(qw(print)) };
+like(
+ $@, qr{Cannot make the non-overridable builtin print fatal},
+ "Can't override print"
+);
diff --git a/t/lib/autodie/autodie.t b/t/lib/autodie/autodie.t
new file mode 100644
index 0000000..c528a16
--- /dev/null
+++ b/t/lib/autodie/autodie.t
@@ -0,0 +1,103 @@
+#!/usr/bin/perl -w
+use strict;
+
+use constant NO_SUCH_FILE => 'this_file_had_so_better_not_be_here';
+
+use Test::More tests => 19;
+
+{
+
+ use autodie qw(open);
+
+ eval { open(my $fh, '<', NO_SUCH_FILE); };
+ like($@,qr{Can't open},"autodie qw(open) in lexical scope");
+
+ no autodie qw(open);
+
+ eval { open(my $fh, '<', NO_SUCH_FILE); };
+ is($@,"","no autodie qw(open) in lexical scope");
+
+ use autodie qw(open);
+ eval { open(my $fh, '<', NO_SUCH_FILE); };
+ like($@,qr{Can't open},"autodie qw(open) in lexical scope 2");
+
+ no autodie; # Should turn off all autodying subs
+ eval { open(my $fh, '<', NO_SUCH_FILE); };
+ is($@,"","no autodie in lexical scope 2");
+
+ # Turn our pragma on one last time, so we can verify that
+ # falling out of this block reverts it back to previous
+ # behaviour.
+ use autodie qw(open);
+ eval { open(my $fh, '<', NO_SUCH_FILE); };
+ like($@,qr{Can't open},"autodie qw(open) in lexical scope 3");
+
+}
+
+eval { open(my $fh, '<', NO_SUCH_FILE); };
+is($@,"","autodie open outside of lexical scope");
+
+eval {
+ use autodie; # Should turn on everything
+ open(my $fh, '<', NO_SUCH_FILE);
+};
+
+like($@, qr{Can't open}, "vanilla use autodie turns on everything.");
+
+eval { open(my $fh, '<', NO_SUCH_FILE); };
+is($@,"","vanilla autodie cleans up");
+
+{
+ use autodie qw(:io);
+
+ eval { open(my $fh, '<', NO_SUCH_FILE); };
+ like($@,qr{Can't open},"autodie q(:io) makes autodying open");
+
+ no autodie qw(:io);
+
+ eval { open(my $fh, '<', NO_SUCH_FILE); };
+ is($@,"", "no autodie qw(:io) disabled autodying open");
+}
+
+{
+ package Testing_autodie;
+
+ use Test::More;
+
+ use constant NO_SUCH_FILE => ::NO_SUCH_FILE();
+
+ use Fatal qw(open);
+
+ eval { open(my $fh, '<', NO_SUCH_FILE); };
+
+ like($@, qr{Can't open}, "Package fatal working");
+ is(ref $@,"","Old Fatal throws strings");
+
+ {
+ use autodie qw(open);
+
+ ok(1,"use autodie allowed with Fatal");
+
+ eval { open(my $fh, '<', NO_SUCH_FILE); };
+ like($@, qr{Can't open}, "autodie and Fatal works");
+ isa_ok($@, "autodie::exception"); # autodie throws real exceptions
+
+ }
+
+ eval { open(my $fh, '<', NO_SUCH_FILE); };
+
+ like($@, qr{Can't open}, "Package fatal working after autodie");
+ is(ref $@,"","Old Fatal throws strings after autodie");
+
+ eval " no autodie qw(open); ";
+
+ ok($@,"no autodie on Fataled sub an error.");
+
+ eval "
+ no autodie qw(close);
+ use Fatal 'close';
+ ";
+
+ like($@, qr{not allowed}, "Using fatal after autodie is an error.");
+}
+
diff --git a/t/lib/autodie/autodie_test_module.pm b/t/lib/autodie/autodie_test_module.pm
new file mode 100644
index 0000000..e8e824c
--- /dev/null
+++ b/t/lib/autodie/autodie_test_module.pm
@@ -0,0 +1,18 @@
+package main;
+use strict;
+use warnings;
+
+# Calls open, while still in the main package. This shouldn't
+# be autodying.
+sub leak_test {
+ return open(my $fh, '<', $_[0]);
+}
+
+package autodie_test_module;
+
+# This should be calling CORE::open
+sub your_open {
+ return open(my $fh, '<', $_[0]);
+}
+
+1;
diff --git a/t/lib/autodie/backcompat.t b/t/lib/autodie/backcompat.t
new file mode 100644
index 0000000..acb8124
--- /dev/null
+++ b/t/lib/autodie/backcompat.t
@@ -0,0 +1,14 @@
+#!/usr/bin/perl -w
+use strict;
+use Fatal qw(open);
+use Test::More tests => 2;
+use constant NO_SUCH_FILE => "xyzzy_this_file_is_not_here";
+
+eval {
+ open(my $fh, '<', NO_SUCH_FILE);
+};
+
+my $old_msg = qr{Can't open\(GLOB\(0x[0-9a-f]+\), <, xyzzy_this_file_is_not_here\): .* at \(eval \d+\)(?:\[.*?\])? line \d+\s+main::__ANON__\('GLOB\(0x[0-9a-f]+\)',\s*'<',\s*'xyzzy_this_file_is_not_here'\) called at \S+ line \d+\s+eval \Q{...}\E called at \S+ line \d+};
+
+like($@,$old_msg,"Backwards compat ugly messages");
+is(ref($@),"", "Exception is a string, not an object");
diff --git a/t/lib/autodie/basic_exceptions.t b/t/lib/autodie/basic_exceptions.t
new file mode 100644
index 0000000..0981e8d
--- /dev/null
+++ b/t/lib/autodie/basic_exceptions.t
@@ -0,0 +1,27 @@
+#!/usr/bin/perl -w
+use strict;
+
+use Test::More tests => 13;
+
+use constant NO_SUCH_FILE => "this_file_had_better_not_exist";
+
+eval {
+ use autodie ':io';
+ open(my $fh, '<', NO_SUCH_FILE);
+};
+
+like($@, qr/Can't open '\w+' for reading: /, "Prety printed open msg");
+like($@, qr{\Q$0\E}, "Our file mention in error message");
+
+like($@, qr{for reading: '.+'}, "Error should be in single-quotes");
+like($@->errno,qr/./, "Errno should not be empty");
+
+like($@, qr{\n$}, "Errors should end with a newline");
+is($@->file, $0, "Correct file");
+is($@->function, 'CORE::open', "Correct dying sub");
+is($@->package, __PACKAGE__, "Correct package");
+is($@->caller,__PACKAGE__."::__ANON__", "Correct caller");
+is($@->args->[1], '<', 'Correct mode arg');
+is($@->args->[2], NO_SUCH_FILE, 'Correct filename arg');
+ok($@->matches('open'), 'Looks like an error from open');
+ok($@->matches(':io'), 'Looks like an error from :io');
diff --git a/t/lib/autodie/context.t b/t/lib/autodie/context.t
new file mode 100755
index 0000000..39b8649
--- /dev/null
+++ b/t/lib/autodie/context.t
@@ -0,0 +1,66 @@
+#!/usr/bin/perl -w
+use strict;
+
+use Test::More;
+
+plan 'no_plan';
+
+sub list_return {
+ return if @_;
+ return qw(foo bar baz);
+}
+
+sub list_return2 {
+ return if @_;
+ return qw(foo bar baz);
+}
+
+# Returns a list presented to it, but also returns a single
+# undef if given a list of a single undef. This mimics the
+# behaviour of many user-defined subs and built-ins (eg: open) that
+# always return undef regardless of context.
+
+sub list_mirror {
+ return undef if (@_ == 1 and not defined $_[0]);
+ return @_;
+
+}
+
+use Fatal qw(list_return);
+use Fatal qw(:void list_return2);
+
+TODO: {
+
+ # Clobbering context was documented as a bug in the original
+ # Fatal, so we'll still consider it a bug here.
+
+ local $TODO = "Fatal clobbers context, just like it always has.";
+
+ my @list = list_return();
+
+ is_deeply(\@list,[qw(foo bar baz)],'fatal sub works in list context');
+}
+
+eval {
+ my @line = list_return(1); # Should die
+};
+
+ok($@,"List return fatalised");
+
+### Tests where we've fatalised our function with :void ###
+
+my @list2 = list_return2();
+
+is_deeply(\@list2,[qw(foo bar baz)],'fatal sub works in list context');
+
+eval {
+ my @line = list_return2(1); # Shouldn't die
+};
+
+ok(! $@,"void List return fatalised survives when non-void");
+
+eval {
+ list_return2(1);
+};
+
+ok($@,"void List return fatalised");
diff --git a/t/lib/autodie/context_lexical.t b/t/lib/autodie/context_lexical.t
new file mode 100755
index 0000000..eeb1a54
--- /dev/null
+++ b/t/lib/autodie/context_lexical.t
@@ -0,0 +1,80 @@
+#!/usr/bin/perl -w
+use strict;
+
+use Test::More;
+
+plan 'no_plan';
+
+# Returns a list presented to it, but also returns a single
+# undef if given a list of a single undef. This mimics the
+# behaviour of many user-defined subs and built-ins (eg: open) that
+# always return undef regardless of context.
+
+sub list_mirror {
+ return undef if (@_ == 1 and not defined $_[0]);
+ return @_;
+
+}
+
+### autodie clobbering tests ###
+
+eval {
+ list_mirror();
+};
+
+is($@, "", "No autodie, no fatality");
+
+eval {
+ use autodie qw(list_mirror);
+ list_mirror();
+};
+
+ok($@, "Autodie fatality for empty return in void context");
+
+eval {
+ list_mirror();
+};
+
+is($@, "", "No autodie, no fatality (after autodie used)");
+
+eval {
+ use autodie qw(list_mirror);
+ list_mirror(undef);
+};
+
+ok($@, "Autodie fatality for undef return in void context");
+
+eval {
+ use autodie qw(list_mirror);
+ my @list = list_mirror();
+};
+
+ok($@,"Autodie fatality for empty list return");
+
+eval {
+ use autodie qw(list_mirror);
+ my @list = list_mirror(undef);
+};
+
+ok($@,"Autodie fatality for undef list return");
+
+eval {
+ use autodie qw(list_mirror);
+ my @list = list_mirror("tada");
+};
+
+ok(! $@,"No Autodie fatality for defined list return");
+
+eval {
+ use autodie qw(list_mirror);
+ my $single = list_mirror("tada");
+};
+
+ok(! $@,"No Autodie fatality for defined scalar return");
+
+eval {
+ use autodie qw(list_mirror);
+ my $single = list_mirror(undef);
+};
+
+ok($@,"Autodie fatality for undefined scalar return");
diff --git a/t/lib/autodie/crickey.t b/t/lib/autodie/crickey.t
new file mode 100644
index 0000000..91a7d78
--- /dev/null
+++ b/t/lib/autodie/crickey.t
@@ -0,0 +1,27 @@
+#!/usr/bin/perl -w
+use strict;
+use FindBin;
+use Test::More 'no_plan';
+
+use lib "$FindBin::Bin/lib";
+
+use constant NO_SUCH_FILE => "crickey_mate_this_file_isnt_here_either";
+
+use autodie::test::au qw(open);
+
+eval {
+ open(my $fh, '<', NO_SUCH_FILE);
+};
+
+ok(my $e = $@, 'Strewth! autodie::test::au should throw an exception on failure');
+
+isa_ok($e, 'autodie::test::au::exception',
+ 'Yeah mate, that should be our test exception.');
+
+like($e, qr/time for a beer/, "Time for a beer mate?");
+
+like( eval { $e->time_for_a_beer; },
+ qr/time for a beer/, "It's always a good time for a beer."
+);
+
+ok($e->matches('open'), "Should be a fair dinkum error from open");
diff --git a/t/lib/autodie/exceptions.t b/t/lib/autodie/exceptions.t
new file mode 100644
index 0000000..2f8c238
--- /dev/null
+++ b/t/lib/autodie/exceptions.t
@@ -0,0 +1,45 @@
+#!/usr/bin/perl -w
+use strict;
+use Test::More;
+
+BEGIN { plan skip_all => "Perl 5.10 only tests" if $] < 5.010; }
+
+# These are tests that depend upon 5.10 (eg, smart-match).
+# Basic tests should go in basic_exceptions.t
+
+use 5.010;
+use constant NO_SUCH_FILE => 'this_file_had_better_not_exist_xyzzy';
+
+plan 'no_plan';
+
+eval {
+ use autodie ':io';
+ open(my $fh, '<', NO_SUCH_FILE);
+};
+
+ok($@, "Exception thrown" );
+ok($@ ~~ 'open', "Exception from open" );
+ok($@ ~~ ':file', "Exception from open / class :file" );
+ok($@ ~~ ':io', "Exception from open / class :io" );
+ok($@ ~~ ':all', "Exception from open / class :all" );
+
+eval {
+ no warnings 'once'; # To prevent the following close from complaining.
+ close(THIS_FILEHANDLE_AINT_OPEN);
+};
+
+ok(! $@, "Close without autodie should fail silent");
+
+eval {
+ use autodie ':io';
+ close(THIS_FILEHANDLE_AINT_OPEN);
+};
+
+like($@, qr{Can't close filehandle 'THIS_FILEHANDLE_AINT_OPEN'},"Nice msg from close");
+
+ok($@, "Exception thrown" );
+ok($@ ~~ 'close', "Exception from close" );
+ok($@ ~~ ':file', "Exception from close / class :file" );
+ok($@ ~~ ':io', "Exception from close / class :io" );
+ok($@ ~~ ':all', "Exception from close / class :all" );
+
diff --git a/t/lib/autodie/exec.t b/t/lib/autodie/exec.t
new file mode 100644
index 0000000..0d4439a
--- /dev/null
+++ b/t/lib/autodie/exec.t
@@ -0,0 +1,12 @@
+#!/usr/bin/perl -w
+use strict;
+use Test::More tests => 3;
+
+eval {
+ use autodie qw(exec);
+ exec("this_command_had_better_not_exist", 1);
+};
+
+isa_ok($@,"autodie::exception", "failed execs should die");
+ok($@->matches('exec'), "exception should match exec");
+ok($@->matches(':system'), "exception should match :system");
diff --git a/t/lib/autodie/filehandles.t b/t/lib/autodie/filehandles.t
new file mode 100644
index 0000000..5bdf732
--- /dev/null
+++ b/t/lib/autodie/filehandles.t
@@ -0,0 +1,60 @@
+#!/usr/bin/perl -w
+
+package main;
+
+use strict;
+use Test::More;
+
+# We may see failures with package filehandles if Fatal/autodie
+# incorrectly pulls out a cached subroutine from a different package.
+
+# We're using Fatal because package filehandles are likely to
+# see more use with Fatal than autodie.
+
+use Fatal qw(open);
+
+eval {
+ open(FILE, '<', $0);
+};
+
+
+if ($@) {
+ # Holy smokes! We couldn't even open our own file, bail out...
+
+ plan skip_all => q{Can't open $0 for filehandle tests}
+}
+
+plan tests => 4;
+
+my $line = <FILE>;
+
+like($line, qr{perl}, 'Looks like we opened $0 correctly');
+
+close(FILE);
+
+package autodie::test;
+use Test::More;
+
+use Fatal qw(open);
+
+eval {
+ open(FILE2, '<', $0);
+};
+
+is($@,"",'Opened $0 in autodie::test');
+
+my $line2 = <FILE2>;
+
+like($line2, qr{perl}, '...and we can read from $0 fine');
+
+close(FILE2);
+
+package main;
+
+# This shouldn't read anything, because FILE2 should be inside
+# autodie::test
+
+no warnings; # Otherwise we see problems with FILE2
+my $wrong_line = <FILE2>;
+
+ok(! defined($wrong_line),q{Filehandles shouldn't leak between packages});
diff --git a/t/lib/autodie/fileno.t b/t/lib/autodie/fileno.t
new file mode 100644
index 0000000..2b9c259
--- /dev/null
+++ b/t/lib/autodie/fileno.t
@@ -0,0 +1,35 @@
+#!/usr/bin/perl -w
+use strict;
+use Test::More tests => 8;
+
+# Basic sanity tests.
+is(fileno(STDIN), 0, "STDIN fileno looks sane");
+is(fileno(STDOUT),1, "STDOUT looks sane");
+
+my $dummy = "foo";
+
+ok(!defined(fileno($dummy)), "Non-filehandles shouldn't be defined.");
+
+
+my $fileno = eval {
+ use autodie qw(fileno);
+ fileno(STDIN);
+};
+
+is($@,"","fileno(STDIN) shouldn't die");
+is($fileno,0,"autodying fileno(STDIN) should be 0");
+
+$fileno = eval {
+ use autodie qw(fileno);
+ fileno(STDOUT);
+};
+
+is($@,"","fileno(STDOUT) shouldn't die");
+is($fileno,1,"autodying fileno(STDOUT) should be 1");
+
+$fileno = eval {
+ use autodie qw(fileno);
+ fileno($dummy);
+};
+
+isa_ok($@,"autodie::exception", 'autodying fileno($dummy) should die');
diff --git a/t/lib/autodie/internal.t b/t/lib/autodie/internal.t
new file mode 100755
index 0000000..8a4e366
--- /dev/null
+++ b/t/lib/autodie/internal.t
@@ -0,0 +1,33 @@
+#!/usr/bin/perl -w
+use strict;
+
+use constant NO_SUCH_FILE => "this_file_or_dir_had_better_not_exist_XYZZY";
+
+use Test::More tests => 6;
+
+# Lexical tests using the internal interface.
+
+eval { Fatal->import(qw(:lexical :void)) };
+like($@, qr{cannot be used with lexical}, ":void can't be used with :lexical");
+
+eval { Fatal->import(qw(open close :lexical)) };
+like($@, qr{:lexical must be used as first}, ":lexical must come first");
+
+{
+ use Fatal qw(:lexical chdir);
+
+ eval { chdir(NO_SUCH_FILE); };
+ like ($@, qr/^Can't chdir/, "Lexical fatal chdir");
+
+ no Fatal qw(:lexical chdir);
+
+ eval { chdir(NO_SUCH_FILE); };
+ is ($@, "", "No lexical fatal chdir");
+
+}
+
+eval { chdir(NO_SUCH_FILE); };
+is($@, "", "Lexical chdir becomes non-fatal out of scope.");
+
+eval { Fatal->import('2+2'); };
+like($@,qr{Bad subroutine name},"Can't use fatal with invalid sub names");
diff --git a/t/lib/autodie/lethal.t b/t/lib/autodie/lethal.t
new file mode 100644
index 0000000..244d2f8
--- /dev/null
+++ b/t/lib/autodie/lethal.t
@@ -0,0 +1,17 @@
+#!/usr/bin/perl -w
+use strict;
+use FindBin;
+use Test::More tests => 4;
+use lib "$FindBin::Bin/lib";
+use lethal qw(open);
+
+use constant NO_SUCH_FILE => "this_file_had_better_not_exist";
+
+eval {
+ open(my $fh, '<', NO_SUCH_FILE);
+};
+
+ok($@, "lethal throws an exception");
+isa_ok($@, 'autodie::exception','...which is the correct class');
+ok($@->matches('open'), "...which matches open");
+is($@->file,__FILE__, "...which reports the correct file");
diff --git a/t/lib/autodie/lib/autodie/test/au.pm b/t/lib/autodie/lib/autodie/test/au.pm
new file mode 100644
index 0000000..7a50e8f
--- /dev/null
+++ b/t/lib/autodie/lib/autodie/test/au.pm
@@ -0,0 +1,14 @@
+package autodie::test::au;
+use strict;
+use warnings;
+
+use base qw(autodie);
+
+use autodie::test::au::exception;
+
+sub throw {
+ my ($this, @args) = @_;
+ return autodie::test::au::exception->new(@args);
+}
+
+1;
diff --git a/t/lib/autodie/lib/autodie/test/au/exception.pm b/t/lib/autodie/lib/autodie/test/au/exception.pm
new file mode 100644
index 0000000..5811fc1
--- /dev/null
+++ b/t/lib/autodie/lib/autodie/test/au/exception.pm
@@ -0,0 +1,19 @@
+package autodie::test::au::exception;
+use strict;
+use warnings;
+
+use base qw(autodie::exception);
+
+sub time_for_a_beer {
+ return "Now's a good time for a beer.";
+}
+
+sub stringify {
+ my ($this) = @_;
+
+ my $base_str = $this->SUPER::stringify;
+
+ return "$base_str\n" . $this->time_for_a_beer;
+}
+
+1;
diff --git a/t/lib/autodie/lib/lethal.pm b/t/lib/autodie/lib/lethal.pm
new file mode 100644
index 0000000..a49600a
--- /dev/null
+++ b/t/lib/autodie/lib/lethal.pm
@@ -0,0 +1,8 @@
+package lethal;
+
+# A dummy package showing how we can trivially subclass autodie
+# to our tastes.
+
+use base qw(autodie);
+
+1;
diff --git a/t/lib/autodie/recv.t b/t/lib/autodie/recv.t
new file mode 100644
index 0000000..cfaa679
--- /dev/null
+++ b/t/lib/autodie/recv.t
@@ -0,0 +1,60 @@
+#!/usr/bin/perl -w
+use strict;
+use Test::More tests => 8;
+use Socket;
+use autodie qw(socketpair);
+
+# All of this code is based around recv returning an empty
+# string when it gets data from a local machine (using AF_UNIX),
+# but returning an undefined value on error. Fatal/autodie
+# should be able to tell the difference.
+
+$SIG{PIPE} = 'IGNORE';
+
+my ($sock1, $sock2);
+socketpair($sock1, $sock2, AF_UNIX, SOCK_STREAM, PF_UNSPEC);
+
+my $buffer;
+send($sock1, "xyz", 0);
+my $ret = recv($sock2, $buffer, 2, 0);
+
+use autodie qw(recv);
+
+SKIP: {
+
+ skip('recv() never returns empty string with socketpair emulation',4)
+ if ($ret);
+
+ is($buffer,'xy',"recv() operational without autodie");
+
+ # Read the last byte from the socket.
+ eval { $ret = recv($sock2, $buffer, 1, 0); };
+
+ is($@, "", "recv should not die on returning an emtpy string.");
+
+ is($buffer,"z","recv() operational with autodie");
+ is($ret,"","recv returns undying empty string for local sockets");
+
+}
+
+eval {
+ # STDIN isn't a socket, so this should fail.
+ recv(STDIN,$buffer,1,0);
+};
+
+ok($@,'recv dies on returning undef');
+isa_ok($@,'autodie::exception');
+
+$buffer = "# Not an empty string\n";
+
+# Terminate writing for $sock1
+shutdown($sock1, 1);
+
+eval {
+ use autodie qw(send);
+ # Writing to a socket terminated for writing should fail.
+ send($sock1,$buffer,0);
+};
+
+ok($@,'send dies on returning undef');
+isa_ok($@,'autodie::exception');
diff --git a/t/lib/autodie/repeat.t b/t/lib/autodie/repeat.t
new file mode 100644
index 0000000..5f85f12
--- /dev/null
+++ b/t/lib/autodie/repeat.t
@@ -0,0 +1,19 @@
+#!/usr/bin/perl -w
+use strict;
+use Test::More 'no_plan';
+use constant NO_SUCH_FILE => "this_file_had_better_not_exist";
+
+eval {
+ use autodie qw(open open open);
+ open(my $fh, '<', NO_SUCH_FILE);
+};
+
+isa_ok($@,q{autodie::exception});
+ok($@->matches('open'),"Exception from open");
+
+eval {
+ open(my $fh, '<', NO_SUCH_FILE);
+};
+
+is($@,"","Repeated autodie should not leak");
+
diff --git a/t/lib/autodie/scope_leak.t b/t/lib/autodie/scope_leak.t
new file mode 100644
index 0000000..3d7b555
--- /dev/null
+++ b/t/lib/autodie/scope_leak.t
@@ -0,0 +1,37 @@
+#!/usr/bin/perl -w
+use strict;
+use FindBin;
+
+# Check for %^H leaking across file boundries. Many thanks
+# to chocolateboy for pointing out this can be a problem.
+
+use lib $FindBin::Bin;
+
+use Test::More 'no_plan';
+
+use constant NO_SUCH_FILE => 'this_file_had_better_not_exist';
+use autodie qw(open);
+
+eval {
+ open(my $fh, '<', NO_SUCH_FILE);
+};
+
+ok($@, "basic autodie test");
+
+use autodie_test_module;
+
+# If things don't work as they should, then the file we've
+# just loaded will still have an autodying main::open (although
+# its own open should be unaffected).
+
+eval {
+ leak_test(NO_SUCH_FILE);
+};
+
+is($@,"","autodying main::open should not leak to other files");
+
+eval {
+ autodie_test_module::your_open(NO_SUCH_FILE);
+};
+
+is($@,"","Other package open should be unaffected");
diff --git a/t/lib/autodie/sysopen.t b/t/lib/autodie/sysopen.t
new file mode 100644
index 0000000..ab489b7
--- /dev/null
+++ b/t/lib/autodie/sysopen.t
@@ -0,0 +1,23 @@
+#!/usr/bin/perl -w
+use strict;
+use Test::More 'no_plan';
+use Fcntl;
+
+use autodie qw(sysopen);
+
+use constant NO_SUCH_FILE => "this_file_had_better_not_be_here_at_all";
+
+my $fh;
+eval {
+ sysopen($fh, $0, O_RDONLY);
+};
+
+is($@, "", "sysopen can open files that exist");
+
+like(scalar( <$fh> ), qr/perl/, "Data in file read");
+
+eval {
+ sysopen(my $fh2, NO_SUCH_FILE, O_RDONLY);
+};
+
+isa_ok($@, 'autodie::exception', 'Opening a bad file fails with sysopen');
diff --git a/t/lib/autodie/usersub.t b/t/lib/autodie/usersub.t
new file mode 100755
index 0000000..7e15576
--- /dev/null
+++ b/t/lib/autodie/usersub.t
@@ -0,0 +1,64 @@
+#!/usr/bin/perl -w
+use strict;
+
+use Test::More 'no_plan';
+
+sub mytest {
+ return $_[0];
+}
+
+is(mytest(q{foo}),q{foo},"Mytest returns input");
+
+my $return = eval { mytest(undef); };
+
+ok(!defined($return), "mytest returns undef without autodie");
+is($@,"","Mytest doesn't throw an exception without autodie");
+
+$return = eval {
+ use autodie qw(mytest);
+
+ mytest('foo');
+};
+
+is($return,'foo',"Mytest returns input with autodie");
+
+$return = eval {
+ use autodie qw(mytest);
+
+ mytest(undef);
+};
+
+isa_ok($@,'autodie::exception',"autodie mytest/undef throws exception");
+
+# We set initial values here because we're expecting $data to be
+# changed to undef later on. Having it as undef to begin with means
+# we can't see mytest(undef) working correctly.
+
+my ($data, $data2) = (1,1);
+
+eval {
+ use autodie qw(mytest);
+
+ {
+ no autodie qw(mytest);
+
+ $data = mytest(undef);
+ $data2 = mytest('foo');
+ }
+};
+
+is($@,"","no autodie can counter use autodie for user subs");
+ok(!defined($data), "mytest(undef) should return undef");
+is($data2, "foo", "mytest(foo) should return foo");
+
+eval {
+ mytest(undef);
+};
+
+is($@,"","No lingering failure effects");
+
+$return = eval {
+ mytest("bar");
+};
+
+is($return,"bar","No lingering return effects");
diff --git a/t/lib/autodie/version.t b/t/lib/autodie/version.t
new file mode 100644
index 0000000..7a68f7f
--- /dev/null
+++ b/t/lib/autodie/version.t
@@ -0,0 +1,17 @@
+#!/usr/bin/perl -w
+use strict;
+use Test::More tests => 3;
+
+# For the moment, we'd like all our versions to be the same.
+# In order to play nicely with some code scanners, they need to be
+# hard-coded into the files, rather than just nicking the version
+# from autodie::exception at run-time.
+
+require Fatal;
+require autodie;
+require autodie::exception;
+require autodie::exception::system;
+
+is($Fatal::VERSION, $autodie::VERSION);
+is($autodie::VERSION, $autodie::exception::VERSION);
+is($autodie::exception::VERSION, $autodie::exception::system::VERSION);
--
1.5.2.2
[Date Prev][Date Next] [Thread Prev][Thread Next] [Date Index][Thread Index][Top&Search][Original]