[Summary view] [Print] [Text view]

   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