home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _af541603cf30d16b89c49157c201a37c < prev    next >
Text File  |  2004-06-01  |  5KB  |  187 lines

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