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     {
 115       no strict 'refs'; # to avoid: Can't use string (...) as a symbol ref ...
 116       $code = eval("package $pkg; use Carp; $code");
 117       die if $@;
 118       local($^W) = 0;   # to avoid: Subroutine foo redefined ...
 119       *{$sub} = $code;
 120     }
 121 }
 122
 123 1;
 124
 125 __END__
 126
 127 =head1 NAME
 128
 129 Fatal - replace functions with equivalents which succeed or die
 130
 131 =head1 SYNOPSIS
 132
 133     use Fatal qw(open close);
 134
 135     sub juggle { . . . }
 136     import Fatal 'juggle';
 137
 138 =head1 DESCRIPTION
 139
 140 C<Fatal> provides a way to conveniently replace functions which normally
 141 return a false value when they fail with equivalents which halt execution
 142 if they are not successful.  This lets you use these functions without
 143 having to test their return values explicitly on each call.   Errors are
 144 reported via C<die>, so you can trap them using C<$SIG{__DIE__}> if you
 145 wish to take some action before the program exits.
 146
 147 The do-or-die equivalents are set up simply by calling Fatal's
 148 C<import> routine, passing it the names of the functions to be
 149 replaced.  You may wrap both user-defined functions and overridable
 150 CORE operators (except C<exec>, C<system> which cannot be expressed
 151 via prototypes) in this way.
 152
 153 =head1 AUTHOR
 154
 155 Lionel.Cons@cern.ch
 156
 157 prototype updates by Ilya Zakharevich ilya@math.ohio-state.edu
 158
 159 =cut