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.05;
   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 && $sub !~ /^CORE::GLOBAL::/) {
 103         # Stray user subroutine
 104         die "$sub is not a Perl subroutine"
 105     } else {                    # CORE subroutine
 106         $proto = eval { prototype "CORE::$name" };
 107         die "$name is neither a builtin, nor a Perl subroutine"
 108           if $@;
 109         die "Cannot make a non-overridable builtin fatal"
 110           if not defined $proto;
 111         $core = 1;
 112         $call = "CORE::$name";
 113     }
 114     if (defined $proto) {
 115       $real_proto = " ($proto)";
 116     } else {
 117       $real_proto = '';
 118       $proto = '@';
 119     }
 120     $code = <<EOS;
 121 sub$real_proto {
 122         local(\$", \$!) = (', ', 0);
 123 EOS
 124     my @protos = fill_protos($proto);
 125     $code .= write_invocation($core, $call, $name, $void, @protos);
 126     $code .= "}\n";
 127     print $code if $Debug;
 128     {
 129       no strict 'refs'; # to avoid: Can't use string (...) as a symbol ref ...
 130       $code = eval("package $pkg; use Carp; $code");
 131       die if $@;
 132       no warnings;   # to avoid: Subroutine foo redefined ...
 133       *{$sub} = $code;
 134     }
 135 }
 136
 137 1;
 138
 139 __END__
 140
 141 =head1 NAME
 142
 143 Fatal - replace functions with equivalents which succeed or die
 144
 145 =head1 SYNOPSIS
 146
 147     use Fatal qw(open close);
 148
 149     sub juggle { . . . }
 150     import Fatal 'juggle';
 151
 152 =head1 DESCRIPTION
 153
 154 C<Fatal> provides a way to conveniently replace functions which normally
 155 return a false value when they fail with equivalents which raise exceptions
 156 if they are not successful.  This lets you use these functions without
 157 having to test their return values explicitly on each call.  Exceptions
 158 can be caught using C<eval{}>.  See L<perlfunc> and L<perlvar> for details.
 159
 160 The do-or-die equivalents are set up simply by calling Fatal's
 161 C<import> routine, passing it the names of the functions to be
 162 replaced.  You may wrap both user-defined functions and overridable
 163 CORE operators (except C<exec>, C<system> which cannot be expressed
 164 via prototypes) in this way.
 165
 166 If the symbol C<:void> appears in the import list, then functions
 167 named later in that import list raise an exception only when
 168 these are called in void context--that is, when their return
 169 values are ignored.  For example
 170
 171         use Fatal qw/:void open close/;
 172
 173         # properly checked, so no exception raised on error
 174         if(open(FH, "< /bogotic") {
 175                 warn "bogo file, dude: $!";
 176         }
 177
 178         # not checked, so error raises an exception
 179         close FH;
 180
 181 =head1 BUGS
 182
 183 You should not fatalize functions that are called in list context, because this
 184 module tests whether a function has failed by testing the boolean truth of its
 185 return value in scalar context.
 186
 187 =head1 AUTHOR
 188
 189 Lionel Cons (CERN).
 190
 191 Prototype updates by Ilya Zakharevich <ilya@math.ohio-state.edu>.
 192
 193 =cut