Fatal::Exception - Succeed or throw exception
Index
Code Index:
NAME
Fatal::Exception - Succeed or throw exception
SYNOPSIS
use Fatal::Exception 'Exception::System' => qw< open close >;
open my $fh, "/nonexistent"; # throw Exception::System
use Exception::Base 'Exception::My';
sub juggle { ... }
Fatal::Exception->import('Exception::My' => 'juggle');
juggle; # succeed or throw exception
Fatal::Exception->unimport('juggle');
juggle or die; # restore original behavior
DESCRIPTION
Fatal::Exception 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 is the same as
Fatal module from Perl 5.8 and previous but it throws
Exception::Base object on error.
IMPORTS
- use Fatal::Exception Exception => function, function, ...
-
Replaces the original functions with wrappers which provide do-or-throw
equivalents. You may wrap both user-defined functions and overridable CORE
operators (except exec, system which cannot be expressed via prototypes) in
this way.
If wrapped function occurs fatal error, the error is converted into
Exception::Fatal exception.
If the symbol :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.
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.
If the exception class is not exist, its module is loaded with "use
Exception" automatically.
- no Fatal::Exception function, function, ...
-
Restores original functions for user-defined functions or replaces the
functions with do-without-die wrappers for CORE operators.
In fact, the CORE operators cannot be restored, so the non-fatalized
alternative is provided instead.
The functions can be wrapped and unwrapped all the time.
The Fatal::Exception module was benchmarked with other implementations.
The results are following:
---------------------------------------------------------------
| Module | Success | Failure |
---------------------------------------------------------------
| eval/die | 289616/s | 236308/s |
---------------------------------------------------------------
| Fatal | 94627/s | 8967/s |
---------------------------------------------------------------
| Fatal::Exception | 143479/s | 9677/s |
---------------------------------------------------------------
SEE ALSO
This module is a fork of Fatal module from Perl 5.8. The latest Perl
will replace the Fatal module with autodie module which is similar
to Fatal::Exception.
The Fatal::Exception doesn't work with lexical scope, yet. It also
doesn't support system in perlfunc or exec in perlfunc core functions
and extra import tags. It throws Exception::Base-d exceptions on
failure so they can be handled as other Exception::Base-d exceptions.
More details:
Fatal, autodie, Exception::Base, Exception::System
BUGS
If you find the bug, please report it.
AUTHOR
Piotr Roszatycki <dexter@debian.org>
LICENSE
Copyright (C) 2007, 2008 by Piotr Roszatycki <dexter@debian.org>.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
See http://www.perl.com/perl/misc/Artistic.html
#!/usr/bin/perl -c
package Fatal::Exception;
use 5.006;
use strict;
use warnings;
our $VERSION = 0.05;
use Symbol ();
use Exception::Base (
'+ignore_package' => __PACKAGE__,
);
use Exception::Argument;
use Exception::Fatal;
# Switch to enable dump for created wrapper functions
our $Debug;
# Cache for not fatalized functions. The key is "$sub".
our %Not_Fatalized_Functions;
# Cache for fatalized functions. The key is "$sub:$exception:$void".
our %Fatalized_Functions;
# Export the wrapped functions to the caller
sub import {
my $pkg = shift;
my $exception = shift || return;
Exception::Argument->throw(
message => 'Not enough arguments for "' . __PACKAGE__ . '->import"',
) unless @_;
my $mod_version = $exception->VERSION || 0;
if (not $mod_version) {
eval "use $exception;";
if ($@) {
Exception::Fatal->throw(
message => "Cannot find \"$exception\" exception class",
);
};
};
my $callpkg = caller;
my $void = 0;
foreach my $arg (@_) {
if ($arg eq ':void') {
$void = 1;
}
else {
my $sub = $arg =~ /::/
? $arg
: $callpkg . '::' . $arg;
(my $name = $sub) =~ s/^&?(.*::)?//;
__make_fatal(
exception => $exception,
name => $name,
pkg => $callpkg,
sub => $sub,
void => $void,
);
};
};
return 1;
};
# Restore the non fatalized functions to the caller
sub unimport {
my $pkg = shift;
my $callpkg = caller;
foreach my $arg (@_) {
next if ($arg eq ':void');
my $sub = $arg =~ /::/
? $arg
: $callpkg . '::' . $arg;
(my $name = $sub) =~ s/^&?(.*::)?//;
__make_not_fatal(
name => $name,
pkg => $callpkg,
sub => $sub
);
};
return 1;
};
# Create the wrapper. Stolen from Fatal.
sub __make_fatal {
# args:
# exception - exception class name
# name - base name of sub
# pkg - current package name
# sub - full name of sub
# void - is function called in scalar context?
my (%args) = @_;
# check args
Exception::Argument->throw(
message => 'Not enough arguments for "' . __PACKAGE__ . '->__make_fatal"',
) if grep { not defined } @args{qw< exception name pkg sub >};
Exception::Argument->throw(
message => 'Bad subroutine name for "' . __PACKAGE__ . '": ' . $args{name},
) if not $args{name} =~ /^\w+$/;
my ($proto, $code_proto, $call, $core, $argvs);
my $cache_key = "$args{sub}:$args{exception}:" . ($args{void} ? 1 : 0);
if (defined $Fatalized_Functions{$cache_key} and defined $Not_Fatalized_Functions{$args{sub}}) {
# already wrapped: restore from cache
undef *{ Symbol::qualify_to_ref($args{sub}) };
return *{ Symbol::qualify_to_ref($args{sub}) } = $Fatalized_Functions{$cache_key};
}
elsif (defined(&{$args{sub}}) and not eval { prototype "CORE::$args{name}" }) {
# user subroutine
$call = "&{\$" . __PACKAGE__ . "::Not_Fatalized_Functions{\"$args{sub}\"}}";
$proto = prototype $args{sub};
$Not_Fatalized_Functions{$args{sub}} = \&{$args{sub}}
unless defined $Not_Fatalized_Functions{$args{sub}};
}
else {
# CORE subroutine
$core = 1;
$call = "CORE::$args{name}";
$proto = eval { prototype $call };
# not found as CORE subroutine
Exception::Argument->throw(
message => "\"$args{sub}\" is not a Perl subroutine",
) unless $proto;
# create package's function
if (not defined &{$args{sub}}) {
# not package's function yet
$argvs = __fill_argvs($proto);
my $name = "__$args{name}__Fatal__Exception__not_wrapped";
my $code = "package $args{pkg};\n"
. "sub $name ($proto) {\n"
. " no strict 'refs';\n"
. __write_invocation(
%args,
argvs => $argvs,
call => $call,
orig => 1,
)
. "}\n";
print STDERR $code if $Debug;
eval $code;
if ($@) {
Exception::Fatal->throw(
message => "Cannot create \"$args{sub}\" subroutine",
);
};
my $sub = "$args{pkg}::$name";
print STDERR "*{ $args{sub} } = \\&$sub;\n" if $Debug;
undef *{ Symbol::qualify_to_ref($args{sub}) };
*{ Symbol::qualify_to_ref($args{sub}) } = \&$sub;
};
if (not defined $Not_Fatalized_Functions{$args{sub}}) {
$Not_Fatalized_Functions{$args{sub}} = \&{$args{sub}};
};
};
if (defined $proto) {
$code_proto = " ($proto)";
}
else {
$code_proto = '';
$proto = '@';
};
$argvs = __fill_argvs($proto) if not defined $argvs;
# define new named subroutine (anonymous would be harder to debug from stacktrace)
my $name = "__$args{name}__Fatal__Exception__$args{exception}" . ($args{void} ? '_void' : '') . "__wrapped";
$name =~ tr/:/_/;
my $code = "package $args{pkg};\n"
. "sub $name$code_proto {\n"
. " no strict 'refs';\n"
. __write_invocation(
%args,
argvs => $argvs,
call => $call,
)
. "}\n";
print STDERR $code if $Debug;
my $newsub = eval $code;
if ($@) {
Exception::Fatal->throw(
message => "Cannot create \"$args{sub}\" subroutine",
);
};
my $sub = "$args{pkg}::$name";
print STDERR "*{ $args{sub} } = \\&$sub;\n" if $Debug;
undef *{ Symbol::qualify_to_ref($args{sub}) };
return *{ Symbol::qualify_to_ref($args{sub}) } = $Fatalized_Functions{$cache_key} = \&$sub;
};
# Restore the not-fatalized function.
sub __make_not_fatal {
# args:
# name - base name of sub
# pkg - current package name
# sub - full name of sub
my (%args) = @_;
# check args
Exception::Argument->throw(
message => 'Not enough arguments for "' . __PACKAGE__ . '->__make_non_fatal"',
) if grep { not defined } @args{qw< name pkg sub >};
Exception::Argument->throw(
message => 'Bad subroutine name for "' . __PACKAGE__ . '": ' . $args{name},
) if not $args{name} =~ /^\w+$/;
# not wrapped - do nothing
return unless defined $Not_Fatalized_Functions{$args{sub}};
undef *{ Symbol::qualify_to_ref($args{sub}) };
return *{ Symbol::qualify_to_ref($args{sub}) } = $Not_Fatalized_Functions{$args{sub}};
};
# Fill argvs array based on function prototype. Stolen from Fatal.
sub __fill_argvs {
my $proto = shift;
my $n = -1;
my (@code, @protos, $seen_semi);
while ($proto =~ /\S/) {
$n++;
if ($seen_semi) {
push(@protos,[$n,@code]);
};
if ($proto =~ s/^\s*\\([\@%\$\&])//) {
push(@code, $1 . "{\$_[$n]}");
next;
};
if ($proto =~ s/^\s*([*\$&])//) {
push(@code, "\$_[$n]");
next;
};
if ($proto =~ s/^\s*(;\s*)?\@//) {
push(@code, "\@_[$n..\$#_]");
last;
};
if ($proto =~ s/^\s*;//) {
$seen_semi = 1;
$n--;
next;
};
Exception::Argument->throw(
message => "Unknown prototype letters: \"$proto\"",
);
};
push @protos, [$n+1, @code];
return \@protos;
};
# Write subroutine invocation. Stolen from Fatal.
sub __write_invocation {
# args:
# argvs - ref to prototypes stored as array of array of calling arguments
# call - called sub full name
# exception - exception class name
# name - base name of sub
# orig - is function called as non-fatalized version?
# void - is function called in scalar context?
my (%args) = @_;
# check args
Exception::Argument->throw(
message => 'Not enough arguments for "' . __PACKAGE__ . '->__write_invocation"',
) if grep { not defined } @args{qw< argvs call exception name >};
my @argvs = @{ $args{argvs} };
my $code;
if (@argvs == 1) {
# No optional arguments
my @argv = @{ $argvs[0] };
shift @argv;
$code =
" "
. __one_invocation(
%args,
argv => \@argv,
)
. ";\n";
}
else {
my $else = " ";
my (@out, @argv, $n);
while (@argvs) {
@argv = @{shift @argvs};
$n = shift @argv;
push @out, "${else}if (\@_ == $n) {\n";
$else = " }\n els";
push @out,
" return "
. __one_invocation(
%args,
argv => \@argv,
)
. ";\n";
}
push @out,
" };\n"
. " Exception::Argument->throw(\n"
. " ignore_level => 1,\n"
. " message => \"$args{name}: Do not expect to get \" . scalar \@_ . \" arguments\"\n"
. " );\n";
$code = join '', @out;
};
return $code;
};
# Write subroutine invocation. Stolen from Fatal.
sub __one_invocation {
# args:
# argv - ref to prototypes stored as array of calling arguments
# call - called sub full name
# exception - exception class name
# name - base name of sub
# orig - is function called as non-fatalized version?
# void - is function called in scalar context?
my (%args) = @_;
# check args
Exception::Argument->throw(
message => 'Not enough arguments for "' . __PACKAGE__ . '->__one_invocation"',
) if grep { not defined } @args{qw< argv call exception name >};
my $argv = join ', ', @{$args{argv}};
my $code;
if ($args{orig}) {
return "$args{call}($argv)";
}
elsif ($args{void}) {
$code = "(defined wantarray)\n"
. " ? $args{call}($argv)\n"
. " : do {\n"
. " my \$return = eval {\n"
. " $args{call}($argv);\n"
. " };\n"
. " if (\$@) {\n"
. " Exception::Fatal->throw(\n"
. " ignore_level => 1,\n"
. " message => \"Cannot $args{name}\",\n"
. " );\n"
. " };\n"
. " \$return;\n"
. " } || $args{exception}->throw(\n"
. " ignore_level => 1,\n"
. " message => \"Cannot $args{name}\",\n"
. " )";
}
else {
$code = "$args{call}($argv)\n"
. " || $args{exception}->throw(\n"
. " ignore_level => 1,\n"
. " message => \"Cannot $args{name}\"\n"
. " )";
$code = "(defined wantarray)\n"
. " ? do {\n"
. " my \@return = eval {\n"
. " $args{call}($argv);\n"
. " };\n"
. " if (\$@) {\n"
. " Exception::Fatal->throw(\n"
. " ignore_level => 1,\n"
. " message => \"Cannot $args{name}\",\n"
. " );\n"
. " };\n"
. " \@return;\n"
. " } || $args{exception}->throw(\n"
. " ignore_level => 1,\n"
. " message => \"Cannot $args{name}\",\n"
. " )\n"
. " : do {\n"
. " my \$return = eval {\n"
. " $args{call}($argv);\n"
. " };\n"
. " if (\$@) {\n"
. " Exception::Fatal->throw(\n"
. " ignore_level => 1,\n"
. " message => \"Cannot $args{name}\",\n"
. " );\n"
. " };\n"
. " \$return;\n"
. " } || $args{exception}->throw(\n"
. " ignore_level => 1,\n"
. " message => \"Cannot $args{name}\",\n"
. " )";
};
return $code;
};
1;
__END__