X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FFatal.pm;h=d1d95af884854fc489c78f4af04b50830f78daaa;hb=26f2972e6cc14b5198456611d023553a813ccb68;hp=0d9c51b113c89ed62b316a49b495824c7ae33788;hpb=902662995003194c4ae9313f14d74b42cf7e4963;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/lib/Fatal.pm b/lib/Fatal.pm
index 0d9c51b..d1d95af 100644
--- a/lib/Fatal.pm
+++ b/lib/Fatal.pm
@@ -2,9 +2,11 @@ package Fatal;
 
 use Carp;
 use strict;
-use vars qw( $AUTOLOAD $Debug );
+use vars qw( $AUTOLOAD $Debug $VERSION);
 
-$Debug = 0;
+$VERSION = 1.02;
+
+$Debug = 0 unless defined $Debug;
 
 sub import {
     my $self = shift(@_);
@@ -22,31 +24,100 @@ sub AUTOLOAD {
     goto &$AUTOLOAD;
 }
 
+sub fill_protos {
+  my $proto = shift;
+  my ($n, $isref, @out, @out1, $seen_semi) = -1;
+  while ($proto =~ /\S/) {
+    $n++;
+    push(@out1,[$n,@out]) if $seen_semi;
+    push(@out, $1 . "{\$_[$n]}"), next if $proto =~ s/^\s*\\([\@%\$\&])//;
+    push(@out, "\$_[$n]"), next if $proto =~ s/^\s*([*\$&])//;
+    push(@out, "\@_[$n..\$#_]"), last if $proto =~ s/^\s*(;\s*)?\@//;
+    $seen_semi = 1, $n--, next if $proto =~ s/^\s*;//; # XXXX ????
+    die "Unknown prototype letters: \"$proto\"";
+  }
+  push(@out1,[$n+1,@out]);
+  @out1;
+}
+
+sub write_invocation {
+  my ($core, $call, $name, @argvs) = @_;
+  if (@argvs == 1) {		# No optional arguments
+    my @argv = @{$argvs[0]};
+    shift @argv;
+    return "\t" . one_invocation($core, $call, $name, @argv) . ";\n";
+  } else {
+    my $else = "\t";
+    my (@out, @argv, $n);
+    while (@argvs) {
+      @argv = @{shift @argvs};
+      $n = shift @argv;
+      push @out, "$ {else}if (\@_ == $n) {\n";
+      $else = "\t} els";
+      push @out, 
+          "\t\treturn " . one_invocation($core, $call, $name, @argv) . ";\n";
+    }
+    push @out, <<EOC;
+	}
+	die "$name(\@_): Do not expect to get ", scalar \@_, " arguments";
+EOC
+    return join '', @out;
+  }
+}
+
+sub one_invocation {
+  my ($core, $call, $name, @argv) = @_;
+  local $" = ', ';
+  return qq{$call(@argv) || croak "Can't $name(\@_)} . 
+    ($core ? ': $!' : ', \$! is \"$!\"') . '"';
+}
+
 sub _make_fatal {
     my($sub, $pkg) = @_;
-    my($name, $code, $sref);
+    my($name, $code, $sref, $real_proto, $proto, $core, $call);
+    my $ini = $sub;
 
     $sub = "${pkg}::$sub" unless $sub =~ /::/;
     $name = $sub;
     $name =~ s/.*::// or $name =~ s/^&//;
     print "# _make_fatal: sub=$sub pkg=$pkg name=$name\n" if $Debug;
     croak "Bad subroutine name for Fatal: $name" unless $name =~ /^\w+$/;
-    $code = "sub $name {\n\tlocal(\$\", \$!) = (', ', 0);\n";
-    if (defined(&$sub)) {
-	# user subroutine
+    if (defined(&$sub)) {	# user subroutine
 	$sref = \&$sub;
-	$code .= "\t&\$sref";
+	$proto = prototype $sref;
+	$call = '&$sref';
+    } elsif ($sub eq $ini) {	# Stray user subroutine
+	die "$sub is not a Perl subroutine" 
+    } else {			# CORE subroutine
+        $proto = eval { prototype "CORE::$name" };
+	die "$name is neither a builtin, nor a Perl subroutine" 
+	  if $@;
+	die "Cannot make a non-overridable builtin fatal"
+	  if not defined $proto;
+	$core = 1;
+	$call = "CORE::$name";
+    }
+    if (defined $proto) {
+      $real_proto = " ($proto)";
     } else {
-	# CORE subroutine
-	$code .= "\tCORE::$name";
+      $real_proto = '';
+      $proto = '@';
     }
-    $code .= "\(\@_\) || croak \"Can't $name\(\@_\): \$!\";\n}\n";
+    $code = <<EOS;
+sub$real_proto {
+	local(\$", \$!) = (', ', 0);
+EOS
+    my @protos = fill_protos($proto);
+    $code .= write_invocation($core, $call, $name, @protos);
+    $code .= "}\n";
     print $code if $Debug;
-    eval($code);
-    die($@) if $@;
-    local($^W) = 0;   # to avoid: Subroutine foo redefined ...
-    no strict 'refs'; # to avoid: Can't use string (...) as a symbol ref ...
-    *{$sub} = \&{"Fatal::$name"};
+    {
+      no strict 'refs'; # to avoid: Can't use string (...) as a symbol ref ...
+      $code = eval("package $pkg; use Carp; $code");
+      die if $@;
+      local($^W) = 0;   # to avoid: Subroutine foo redefined ...
+      *{$sub} = $code;
+    }
 }
 
 1;
@@ -59,7 +130,7 @@ Fatal - replace functions with equivalents which succeed or die
 
 =head1 SYNOPSIS
 
-    use Fatal qw(open print close);
+    use Fatal qw(open close);
 
     sub juggle { . . . }
     import Fatal 'juggle';
@@ -73,10 +144,16 @@ having to test their return values explicitly on each call.   Errors are
 reported via C<die>, so you can trap them using C<$SIG{__DIE__}> if you
 wish to take some action before the program exits.
 
-The do-or-die equivalents are set up simply by calling Fatal's C<import>
-routine, passing it the names of the functions to be replaced.  You may
-wrap both user-defined functions and CORE operators in this way.
+The do-or-die equivalents are set up simply by calling Fatal's
+C<import> routine, passing it the names of the functions to be
+replaced.  You may wrap both user-defined functions and overridable
+CORE operators (except C<exec>, C<system> which cannot be expressed
+via prototypes) in this way.
 
 =head1 AUTHOR
 
 Lionel.Cons@cern.ch
+
+prototype updates by Ilya Zakharevich ilya@math.ohio-state.edu
+
+=cut