lib/Fatal.pm

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