lib/Fatal.pm

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