X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FFatal.pm;h=0ea5963df0b0eb6f6941dee81f67b0bb69ef33df;hb=57c7bc0807db52907ce13229410345ba8f983f8a;hp=281474c336525e01b7d0bdfd674b9360d32e0da1;hpb=5f05dabc4054964aa3b10f44f8468547f051cdf8;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/lib/Fatal.pm b/lib/Fatal.pm
index 281474c..0ea5963 100644
--- a/lib/Fatal.pm
+++ b/lib/Fatal.pm
@@ -1,17 +1,26 @@
 package Fatal;
 
+use 5.006_001;
 use Carp;
 use strict;
-use vars qw( $AUTOLOAD $Debug );
+our($AUTOLOAD, $Debug, $VERSION);
 
-$Debug = 0;
+$VERSION = 1.03;
+
+$Debug = 0 unless defined $Debug;
 
 sub import {
     my $self = shift(@_);
     my($sym, $pkg);
+    my $void = 0;
     $pkg = (caller)[0];
     foreach $sym (@_) {
-	&_make_fatal($sym, $pkg);
+	if ($sym eq ":void") {
+	    $void = 1;
+	}
+	else {
+	    &_make_fatal($sym, $pkg, $void);
+	}
     }
 };
 
@@ -22,31 +31,106 @@ 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, $void, @argvs) = @_;
+  if (@argvs == 1) {		# No optional arguments
+    my @argv = @{$argvs[0]};
+    shift @argv;
+    return "\t" . one_invocation($core, $call, $name, $void, @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, $void, @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, $void, @argv) = @_;
+  local $" = ', ';
+  if ($void) { 
+    return qq/(defined wantarray)?$call(@argv):
+              $call(@argv) || croak "Can't $name(\@_)/ . 
+           ($core ? ': $!' : ', \$! is \"$!\"') . '"'
+  } else {
+    return qq{$call(@argv) || croak "Can't $name(\@_)} . 
+           ($core ? ': $!' : ', \$! is \"$!\"') . '"';
+  }
+}
+
 sub _make_fatal {
-    my($sub, $pkg) = @_;
-    my($name, $code, $sref);
+    my($sub, $pkg, $void) = @_;
+    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;
+    print "# _make_fatal: sub=$sub pkg=$pkg name=$name void=$void\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, $void, @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 $@;
+      no warnings;   # to avoid: Subroutine foo redefined ...
+      *{$sub} = $code;
+    }
 }
 
 1;
@@ -59,7 +143,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';
@@ -67,16 +151,36 @@ Fatal - replace functions with equivalents which succeed or die
 =head1 DESCRIPTION
 
 C<Fatal> provides a way to conveniently replace functions which normally
-return a false value when they fail with equivalents which halt execution
+return a false value when they fail with equivalents which raise exceptions
 if they are not successful.  This lets you use these functions without
-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.
+having to test their return values explicitly on each call.  Exceptions
+can be caught using C<eval{}>.  See L<perlfunc> and L<perlvar> for details.
+
+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.
+
+If the symbol C<:void> appears in the import list, then functions
+named later in that import list raise an exception only when
+these are called in void context--that is, when their return
+values are ignored.  For example
 
-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.
+	use Fatal qw/:void open close/;
+
+	# properly checked, so no exception raised on error
+	if(open(FH, "< /bogotic") {
+		warn "bogo file, dude: $!";
+	}
+
+	# not checked, so error raises an exception
+	close FH;
 
 =head1 AUTHOR
 
 Lionel.Cons@cern.ch
+
+prototype updates by Ilya Zakharevich ilya@math.ohio-state.edu
+
+=cut