touch lib/Fatal.pm
exit 0

diff -pru perl5.004_03/MANIFEST perl5.004_03.comp/MANIFEST
--- perl5.004_03/MANIFEST	Wed Aug 13 10:07:48 1997
+++ perl5.004_03.comp/MANIFEST	Wed Sep 17 21:48:52 1997
@@ -342,6 +342,7 @@ lib/ExtUtils/Mksymlists.pm	Writes a link
 lib/ExtUtils/testlib.pm		Fixes up @INC to use just-built extension
 lib/ExtUtils/typemap		Extension interface types
 lib/ExtUtils/xsubpp		External subroutine preprocessor
+lib/Fatal.pm		Make errors in functions/builtins fatal
 lib/File/Basename.pm	Emulate the basename program
 lib/File/CheckTree.pm	Perl module supporting wholesale file mode validation
 lib/File/Compare.pm	Emulation of cmp command
--- ./toke.c~	Wed Nov 19 22:25:46 1997
+++ ./toke.c	Fri Nov 21 14:04:52 1997
@@ -1010,9 +1010,18 @@ intuit_method(char *start, GV *gv)
     GV* indirgv;
 
     if (gv) {
+	CV *cv;
 	if (GvIO(gv))
 	    return 0;
-	if (!GvCVu(gv))
+	if ((cv = GvCVu(gv))) {
+	    char *proto = SvPVX(cv);
+	    if (proto) {
+		if (*proto == ';')
+		    proto++;
+		if (*proto == '*')
+		    return 0;
+	    }
+	} else
 	    gv = 0;
     }
     s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
diff -pru perl5.004_03/pod/perlmodlib.pod perl5.004_03.comp/pod/perlmodlib.pod
--- perl5.004_03/pod/perlmodlib.pod	Mon Apr 28 20:41:18 1997
+++ perl5.004_03.comp/pod/perlmodlib.pod	Wed Sep 17 21:49:52 1997
@@ -225,6 +225,10 @@ write linker options files for dynamic e
 
 add blib/* directories to @INC
 
+=item Fatal
+
+make errors in builtins or Perl functions fatal
+
 =item Fcntl
 
 load the C Fcntl.h defines
--- ./pp.c.orig	Mon Oct 20 06:06:40 1997
+++ ./pp.c	Thu Nov  6 01:08:58 1997
@@ -343,9 +343,54 @@ PP(pp_prototype)
     SV *ret;
 
     ret = &sv_undef;
+    if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
+	char *s = SvPVX(TOPs);
+	if (strnEQ(s, "CORE::", 6)) {
+	    int code;
+	    
+	    code = keyword(s + 6, SvCUR(TOPs) - 6);
+	    if (code < 0) {	/* Overridable. */
+#define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
+		int i = 0, n = 0, seen_question = 0;
+		I32 oa;
+		char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
+
+		while (i < MAXO) {	/* The slow way. */
+		    if (strEQ(s + 6, op_name[i]) || strEQ(s + 6, op_desc[i]))
+			goto found;
+		    i++;
+		}
+		goto nonesuch;		/* Should not happen... */
+	      found:
+		oa = opargs[i] >> OASHIFT;
+		while (oa) {
+		    if (oa & OA_OPTIONAL) {
+			seen_question = 1;
+			str[n++] = ';';
+		    } else if (seen_question) 
+			goto set;	/* XXXX system, exec */
+		    if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF 
+			&& (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
+			str[n++] = '\\';
+		    }
+		    /* What to do with R ((un)tie, tied, (sys)read, recv)? */
+		    str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
+		    oa = oa >> 4;
+		}
+		str[n++] = '\0';
+		ret = sv_2mortal(newSVpv(str, n - 1));
+	    } else if (code)		/* Non-Overridable */
+		goto set;
+	    else {			/* None such */
+	      nonesuch:
+		croak("Cannot find an opnumber for \"%s\"", s+6);
+	    }
+	}
+    }
     cv = sv_2cv(TOPs, &stash, &gv, FALSE);
     if (cv && SvPOK(cv))
 	ret = sv_2mortal(newSVpv(SvPVX(cv), SvCUR(cv)));
+  set:
     SETs(ret);
     RETURN;
 }
--- ./pod/perlfunc.pod~	Thu Oct 16 08:45:58 1997
+++ ./pod/perlfunc.pod	Thu Nov  6 01:11:38 1997
@@ -2353,6 +2353,13 @@ Returns the prototype of a function as a
 function has no prototype).  FUNCTION is a reference to, or the name of,
 the function whose prototype you want to retrieve.
 
+If FUNCTION is a string starting with C<CORE::>, the rest is taken as
+a name for Perl builtin.  If builtin is not I<overridable> (such as
+C<qw>) or its arguments cannot be expressed by a prototype (such as
+C<system>) - in other words, the builtin does not behave like a Perl
+function - returns C<undef>.  Otherwise, the string describing the
+equivalent prototype is returned.
+
 =item push ARRAY,LIST
 
 Treats ARRAY as a stack, and pushes the values of LIST
--- ./pod/perldiag.pod~	Thu Oct 16 08:45:58 1997
+++ ./pod/perldiag.pod	Thu Nov  6 00:49:00 1997
@@ -883,6 +883,11 @@ a B<-e> switch.  Maybe your /tmp partiti
 an assignment operator, which implies modifying the value itself.
 Perhaps you need to copy the value to a temporary, and repeat that.
 
+=item Cannot find an opnumber for "%s"
+
+(F) A string of a form C<CORE::word> was given to prototype(), but
+there is no builtin with the name C<word>.
+
 =item Cannot open temporary file
 
 (F) The create routine failed for some reason while trying to process
--- ./t/comp/proto.t.orig	Thu Nov  6 00:38:24 1997
+++ ./t/comp/proto.t	Thu Nov  6 01:20:14 1997
@@ -16,7 +16,7 @@ BEGIN {
 
 use strict;
 
-print "1..76\n";
+print "1..80\n";
 
 my $i = 1;
 
@@ -375,6 +375,20 @@ sub an_array_ref (\@) {
 an_array_ref @array;
 print "not " unless @array == 4;
 print @array;
+
+my $p;
+print "not " if defined prototype('CORE::print');
+print "ok ", $i++, "\n";
+
+print "not " if defined prototype('CORE::system');
+print "ok ", $i++, "\n";
+
+print "# CORE::open => ($p)\nnot " if ($p = prototype('CORE::open')) ne '*;$';
+print "ok ", $i++, "\n";
+
+print "# CORE:Foo => ($p), \$@ => `$@'\nnot " 
+    if defined ($p = eval { prototype('CORE::Foo') or 1 }) or $@ !~ /^Cannot find an opnumber/;
+print "ok ", $i++, "\n";
 
 # correctly note too-short parameter lists that don't end with '$',
 #  a possible regression.
--- ./lib/Fatal.pm.orig	Thu Nov  6 00:38:18 1997
+++ ./lib/Fatal.pm	Thu Nov  6 01:34:40 1997
@@ -0,0 +1,157 @@
+package Fatal;
+
+use Carp;
+use strict;
+use vars qw( $AUTOLOAD $Debug $VERSION);
+
+$VERSION = 1.02;
+
+$Debug = 0 unless defined $Debug;
+
+sub import {
+    my $self = shift(@_);
+    my($sym, $pkg);
+    $pkg = (caller)[0];
+    foreach $sym (@_) {
+	&_make_fatal($sym, $pkg);
+    }
+};
+
+sub AUTOLOAD {
+    my $cmd = $AUTOLOAD;
+    $cmd =~ s/.*:://;
+    &_make_fatal($cmd, (caller)[0]);
+    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, $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+$/;
+    if (defined(&$sub)) {	# user subroutine
+	$sref = \&$sub;
+	$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 {
+      $real_proto = '';
+      $proto = '@';
+    }
+    $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;
+    $code = 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} = $code;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Fatal - replace functions with equivalents which succeed or die
+
+=head1 SYNOPSIS
+
+    use Fatal qw(open close);
+
+    sub juggle { . . . }
+    import Fatal 'juggle';
+
+=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
+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.
+
+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
