lib/Fatal.pm

   1 package Fatal;
   2
   3 use 5.006_001;
   4 use Carp;
   5 use strict;
   6 our($AUTOLOAD, $Debug, $VERSION);
   7
   8 $VERSION = 1.03;
   9
  10 $Debug = 0 unless defined $Debug;
  11
  12 sub import {
  13     my $self = shift(@_);
  14     my($sym, $pkg);
  15     my $void = 0;
  16     $pkg = (caller)[0];
  17     foreach $sym (@_) {
  18         if ($sym eq ":void") {
  19             $void = 1;
  20         }
  21         else {
  22             &_make_fatal($sym, $pkg, $void);
  23         }
  24     }
  25 };
  26
  27 sub AUTOLOAD {
  28     my $cmd = $AUTOLOAD;
  29     $cmd =~ s/.*:://;
  30     &_make_fatal($cmd, (caller)[0]);
  31     goto &$AUTOLOAD;
  32 }
  33
  34 sub fill_protos {
  35   my $proto = shift;
  36   my ($n, $isref, @out, @out1, $seen_semi) = -1;
  37   while ($proto =~ /\S/) {
  38     $n++;
  39     push(@out1,[$n,@out]) if $seen_semi;
  40     push(@out, $1 . "{\$_[$n]}"), next if $proto =~ s/^\s*\\([\@%\$\&])//;
  41     push(@out, "\$_[$n]"), next if $proto =~ s/^\s*([*\$&])//;
  42     push(@out, "\@_[$n..\$#_]"), last if $proto =~ s/^\s*(;\s*)?\@//;
  43     $seen_semi = 1, $n--, next if $proto =~ s/^\s*;//; # XXXX ????
  44     die "Unknown prototype letters: \"$proto\"";
  45   }
  46   push(@out1,[$n+1,@out]);
  47   @out1;
  48 }
  49
  50 sub write_invocation {
  51   my ($core, $call, $name, $void, @argvs) = @_;
  52   if (@argvs == 1) {            # No optional arguments
  53     my @argv = @{$argvs[0]};
  54     shift @argv;
  55     return "\t" . one_invocation($core, $call, $name, $void, @argv) . ";\n";
  56   } else {
  57     my $else = "\t";
  58     my (@out, @argv, $n);
  59     while (@argvs) {
  60       @argv = @{shift @argvs};
  61       $n = shift @argv;
  62       push @out, "$ {else}if (\@_ == $n) {\n";
  63       $else = "\t} els";
  64       push @out,
  65           "\t\treturn " . one_invocation($core, $call, $name, $void, @argv) . ";\n";
  66     }
  67     push @out, <<EOC;
  68         }
  69         die "$name(\@_): Do not expect to get ", scalar \@_, " arguments";
  70 EOC
  71     return join '', @out;
  72   }
  73 }
  74
  75 sub one_invocation {
  76   my ($core, $call, $name, $void, @argv) = @_;
  77   local $" = ', ';
  78   if ($void) {
  79     return qq/(defined wantarray)?$call(@argv):
  80               $call(@argv) || croak "Can't $name(\@_)/ .
  81            ($core ? ': $!' : ', \$! is \"$!\"') . '"'
  82   } else {
  83     return qq{$call(@argv) || croak "Can't $name(\@_)} .
  84            ($core ? ': $!' : ', \$! is \"$!\"') . '"';
  85   }
  86 }
  87
  88 sub _make_fatal {
  89     my($sub, $pkg, $void) = @_;
  90     my($name, $code, $sref, $real_proto, $proto, $core, $call);
  91     my $ini = $sub;
  92
  93     $sub = "${pkg}::$sub" unless $sub =~ /::/;
  94     $name = $sub;
  95     $name =~ s/.*::// or $name =~ s/^&//;
  96     print "# _make_fatal: sub=$sub pkg=$pkg name=$name void=$void\n" if $Debug;
  97     croak "Bad subroutine name for Fatal: $name" unless $name =~ /^\w+$/;
  98     if (defined(&$sub)) {       # user subroutine
  99         $sref = \&$sub;
 100         $proto = prototype $sref;
 101         $call = '&$sref';
 102     } elsif ($sub eq $ini) {    # Stray user subroutine
 103         die "$sub is not a Perl subroutine"
 104     } else {                    # CORE subroutine
 105         $proto = eval { prototype "CORE::$name" };
 106         die "$name is neither a builtin, nor a Perl subroutine"
 107           if $@;
 108         die "Cannot make a non-overridable builtin fatal"
 109           if not defined $proto;
 110         $core = 1;
 111         $call = "CORE::$name";
 112     }
 113     if (defined $proto) {
 114       $real_proto = " ($proto)";
 115     } else {
 116       $real_proto = '';
 117       $proto = '@';
 118     }
 119     $code = <<EOS;
 120 sub$real_proto {
 121         local(\$", \$!) = (', ', 0);
 122 EOS
 123     my @protos = fill_protos($proto);
 124     $code .= write_invocation($core, $call, $name, $void, @protos);
 125     $code .= "}\n";
 126     print $code if $Debug;
 127     {
 128       no strict 'refs'; # to avoid: Can't use string (...) as a symbol ref ...
 129       $code = eval("package $pkg; use Carp; $code");
 130       die if $@;
 131       no warnings;   # to avoid: Subroutine foo redefined ...
 132       *{$sub} = $code;
 133     }
 134 }
 135
 136 1;
 137
 138 __END__
 139
 140 =head1 NAME
 141
 142 Fatal - replace functions with equivalents which succeed or die
 143
 144 =head1 SYNOPSIS
 145
 146     use Fatal qw(open close);
 147
 148     sub juggle { . . . }
 149     import Fatal 'juggle';
 150
 151 =head1 DESCRIPTION
 152
 153 C<Fatal> provides a way to conveniently replace functions which normally
 154 return a false value when they fail with equivalents which raise exceptions
 155 if they are not successful.  This lets you use these functions without
 156 having to test their return values explicitly on each call.  Exceptions
 157 can be caught using C<eval{}>.  See L<perlfunc> and L<perlvar> for details.
 158
 159 The do-or-die equivalents are set up simply by calling Fatal's
 160 C<import> routine, passing it the names of the functions to be
 161 replaced.  You may wrap both user-defined functions and overridable
 162 CORE operators (except C<exec>, C<system> which cannot be expressed
 163 via prototypes) in this way.
 164
 165 If the symbol C<:void> appears in the import list, then functions
 166 named later in that import list raise an exception only when
 167 these are called in void context--that is, when their return
 168 values are ignored.  For example
 169
 170         use Fatal qw/:void open close/;
 171
 172         # properly checked, so no exception raised on error
 173         if(open(FH, "< /bogotic") {
 174                 warn "bogo file, dude: $!";
 175         }
 176
 177         # not checked, so error raises an exception
 178         close FH;
 179
 180 =head1 AUTHOR
 181
 182 Lionel Cons (CERN).
 183
 184 Prototype updates by Ilya Zakharevich <ilya@math.ohio-state.edu>.
 185
 186 =cut