X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FFatal.pm;h=0b4bf9bc99cee0e10a6c1ff647c68d610453089d;hb=867b93c3db1d647f2ded7b5266dcc89a480cbc44;hp=d033d627135d8add1413a463c2a622d8b4814f14;hpb=59d9ee20c174dac13d86b680b0685e43c9fe2074;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/lib/Fatal.pm b/lib/Fatal.pm
index d033d62..0b4bf9b 100644
--- a/lib/Fatal.pm
+++ b/lib/Fatal.pm
@@ -1,20 +1,26 @@
 package Fatal;
 
-use 5.005_64;
+use 5.006_001;
 use Carp;
 use strict;
 our($AUTOLOAD, $Debug, $VERSION);
 
-$VERSION = 1.02;
+$VERSION = 1.06;
 
 $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);
+	}
     }
 };
 
@@ -32,7 +38,7 @@ sub fill_protos {
     $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]"), 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\"";
@@ -42,11 +48,11 @@ sub fill_protos {
 }
 
 sub write_invocation {
-  my ($core, $call, $name, @argvs) = @_;
+  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, @argv) . ";\n";
+    return "\t" . one_invocation($core, $call, $name, $void, @argv) . ";\n";
   } else {
     my $else = "\t";
     my (@out, @argv, $n);
@@ -56,7 +62,7 @@ sub write_invocation {
       push @out, "$ {else}if (\@_ == $n) {\n";
       $else = "\t} els";
       push @out, 
-          "\t\treturn " . one_invocation($core, $call, $name, @argv) . ";\n";
+          "\t\treturn " . one_invocation($core, $call, $name, $void, @argv) . ";\n";
     }
     push @out, <<EOC;
 	}
@@ -67,33 +73,40 @@ EOC
 }
 
 sub one_invocation {
-  my ($core, $call, $name, @argv) = @_;
+  my ($core, $call, $name, $void, @argv) = @_;
   local $" = ', ';
-  return qq{$call(@argv) || croak "Can't $name(\@_)} . 
-    ($core ? ': $!' : ', \$! is \"$!\"') . '"';
+  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($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+$/;
     if (defined(&$sub)) {	# user subroutine
 	$sref = \&$sub;
 	$proto = prototype $sref;
 	$call = '&$sref';
-    } elsif ($sub eq $ini) {	# Stray user subroutine
+    } elsif ($sub eq $ini && $sub !~ /^CORE::GLOBAL::/) {
+	# 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"
+	die "Cannot make the non-overridable builtin $name fatal"
 	  if not defined $proto;
 	$core = 1;
 	$call = "CORE::$name";
@@ -109,7 +122,7 @@ sub$real_proto {
 	local(\$", \$!) = (', ', 0);
 EOS
     my @protos = fill_protos($proto);
-    $code .= write_invocation($core, $call, $name, @protos);
+    $code .= write_invocation($core, $call, $name, $void, @protos);
     $code .= "}\n";
     print $code if $Debug;
     {
@@ -150,10 +163,31 @@ 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
+
+	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 BUGS
+
+You should not fatalize functions that are called in list context, because this
+module tests whether a function has failed by testing the boolean truth of its
+return value in scalar context.
+
 =head1 AUTHOR
 
-Lionel.Cons@cern.ch
+Lionel Cons (CERN).
 
-prototype updates by Ilya Zakharevich ilya@math.ohio-state.edu
+Prototype updates by Ilya Zakharevich <ilya@math.ohio-state.edu>.
 
 =cut