1N/Apackage Fatal;
1N/A
1N/Ause 5.006_001;
1N/Ause Carp;
1N/Ause strict;
1N/Aour($AUTOLOAD, $Debug, $VERSION);
1N/A
1N/A$VERSION = 1.03;
1N/A
1N/A$Debug = 0 unless defined $Debug;
1N/A
1N/Asub import {
1N/A my $self = shift(@_);
1N/A my($sym, $pkg);
1N/A my $void = 0;
1N/A $pkg = (caller)[0];
1N/A foreach $sym (@_) {
1N/A if ($sym eq ":void") {
1N/A $void = 1;
1N/A }
1N/A else {
1N/A &_make_fatal($sym, $pkg, $void);
1N/A }
1N/A }
1N/A};
1N/A
1N/Asub AUTOLOAD {
1N/A my $cmd = $AUTOLOAD;
1N/A $cmd =~ s/.*:://;
1N/A &_make_fatal($cmd, (caller)[0]);
1N/A goto &$AUTOLOAD;
1N/A}
1N/A
1N/Asub fill_protos {
1N/A my $proto = shift;
1N/A my ($n, $isref, @out, @out1, $seen_semi) = -1;
1N/A while ($proto =~ /\S/) {
1N/A $n++;
1N/A push(@out1,[$n,@out]) if $seen_semi;
1N/A push(@out, $1 . "{\$_[$n]}"), next if $proto =~ s/^\s*\\([\@%\$\&])//;
1N/A push(@out, "\$_[$n]"), next if $proto =~ s/^\s*([*\$&])//;
1N/A push(@out, "\@_[$n..\$#_]"), last if $proto =~ s/^\s*(;\s*)?\@//;
1N/A $seen_semi = 1, $n--, next if $proto =~ s/^\s*;//; # XXXX ????
1N/A die "Unknown prototype letters: \"$proto\"";
1N/A }
1N/A push(@out1,[$n+1,@out]);
1N/A @out1;
1N/A}
1N/A
1N/Asub write_invocation {
1N/A my ($core, $call, $name, $void, @argvs) = @_;
1N/A if (@argvs == 1) { # No optional arguments
1N/A my @argv = @{$argvs[0]};
1N/A shift @argv;
1N/A return "\t" . one_invocation($core, $call, $name, $void, @argv) . ";\n";
1N/A } else {
1N/A my $else = "\t";
1N/A my (@out, @argv, $n);
1N/A while (@argvs) {
1N/A @argv = @{shift @argvs};
1N/A $n = shift @argv;
1N/A push @out, "$ {else}if (\@_ == $n) {\n";
1N/A $else = "\t} els";
1N/A push @out,
1N/A "\t\treturn " . one_invocation($core, $call, $name, $void, @argv) . ";\n";
1N/A }
1N/A push @out, <<EOC;
1N/A }
1N/A die "$name(\@_): Do not expect to get ", scalar \@_, " arguments";
1N/AEOC
1N/A return join '', @out;
1N/A }
1N/A}
1N/A
1N/Asub one_invocation {
1N/A my ($core, $call, $name, $void, @argv) = @_;
1N/A local $" = ', ';
1N/A if ($void) {
1N/A return qq/(defined wantarray)?$call(@argv):
1N/A $call(@argv) || croak "Can't $name(\@_)/ .
1N/A ($core ? ': $!' : ', \$! is \"$!\"') . '"'
1N/A } else {
1N/A return qq{$call(@argv) || croak "Can't $name(\@_)} .
1N/A ($core ? ': $!' : ', \$! is \"$!\"') . '"';
1N/A }
1N/A}
1N/A
1N/Asub _make_fatal {
1N/A my($sub, $pkg, $void) = @_;
1N/A my($name, $code, $sref, $real_proto, $proto, $core, $call);
1N/A my $ini = $sub;
1N/A
1N/A $sub = "${pkg}::$sub" unless $sub =~ /::/;
1N/A $name = $sub;
1N/A $name =~ s/.*::// or $name =~ s/^&//;
1N/A print "# _make_fatal: sub=$sub pkg=$pkg name=$name void=$void\n" if $Debug;
1N/A croak "Bad subroutine name for Fatal: $name" unless $name =~ /^\w+$/;
1N/A if (defined(&$sub)) { # user subroutine
1N/A $sref = \&$sub;
1N/A $proto = prototype $sref;
1N/A $call = '&$sref';
1N/A } elsif ($sub eq $ini) { # Stray user subroutine
1N/A die "$sub is not a Perl subroutine"
1N/A } else { # CORE subroutine
1N/A $proto = eval { prototype "CORE::$name" };
1N/A die "$name is neither a builtin, nor a Perl subroutine"
1N/A if $@;
1N/A die "Cannot make a non-overridable builtin fatal"
1N/A if not defined $proto;
1N/A $core = 1;
1N/A $call = "CORE::$name";
1N/A }
1N/A if (defined $proto) {
1N/A $real_proto = " ($proto)";
1N/A } else {
1N/A $real_proto = '';
1N/A $proto = '@';
1N/A }
1N/A $code = <<EOS;
1N/Asub$real_proto {
1N/A local(\$", \$!) = (', ', 0);
1N/AEOS
1N/A my @protos = fill_protos($proto);
1N/A $code .= write_invocation($core, $call, $name, $void, @protos);
1N/A $code .= "}\n";
1N/A print $code if $Debug;
1N/A {
1N/A no strict 'refs'; # to avoid: Can't use string (...) as a symbol ref ...
1N/A $code = eval("package $pkg; use Carp; $code");
1N/A die if $@;
1N/A no warnings; # to avoid: Subroutine foo redefined ...
1N/A *{$sub} = $code;
1N/A }
1N/A}
1N/A
1N/A1;
1N/A
1N/A__END__
1N/A
1N/A=head1 NAME
1N/A
1N/AFatal - replace functions with equivalents which succeed or die
1N/A
1N/A=head1 SYNOPSIS
1N/A
1N/A use Fatal qw(open close);
1N/A
1N/A sub juggle { . . . }
1N/A import Fatal 'juggle';
1N/A
1N/A=head1 DESCRIPTION
1N/A
1N/AC<Fatal> provides a way to conveniently replace functions which normally
1N/Areturn a false value when they fail with equivalents which raise exceptions
1N/Aif they are not successful. This lets you use these functions without
1N/Ahaving to test their return values explicitly on each call. Exceptions
1N/Acan be caught using C<eval{}>. See L<perlfunc> and L<perlvar> for details.
1N/A
1N/AThe do-or-die equivalents are set up simply by calling Fatal's
1N/AC<import> routine, passing it the names of the functions to be
1N/Areplaced. You may wrap both user-defined functions and overridable
1N/ACORE operators (except C<exec>, C<system> which cannot be expressed
1N/Avia prototypes) in this way.
1N/A
1N/AIf the symbol C<:void> appears in the import list, then functions
1N/Anamed later in that import list raise an exception only when
1N/Athese are called in void context--that is, when their return
1N/Avalues are ignored. For example
1N/A
1N/A use Fatal qw/:void open close/;
1N/A
1N/A # properly checked, so no exception raised on error
1N/A if(open(FH, "< /bogotic") {
1N/A warn "bogo file, dude: $!";
1N/A }
1N/A
1N/A # not checked, so error raises an exception
1N/A close FH;
1N/A
1N/A=head1 AUTHOR
1N/A
1N/ALionel.Cons@cern.ch
1N/A
1N/Aprototype updates by Ilya Zakharevich ilya@math.ohio-state.edu
1N/A
1N/A=cut