5.004_56: patch for `use Fatal' again

p4raw-id: //depot/perl@467

7 files changed, 87 insertions, 2 deletions

diff --git a/MANIFEST b/MANIFEST
index 60995036dd..8267280595 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -382,6 +382,7 @@ lib/ExtUtils/Mksymlists.pm	Writes a linker options file for extensions
 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
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 166e046f22..20c0ae1325 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -883,6 +883,11 @@ a B<-e> switch.  Maybe your /tmp partition is full, or clobbered.
 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
diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod
index a1184c8a08..bae135bc92 100644
--- a/pod/perlfunc.pod
+++ b/pod/perlfunc.pod
@@ -2374,6 +2374,13 @@ Returns the prototype of a function as a string (or C<undef> if the
 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
diff --git a/pod/perlmodlib.pod b/pod/perlmodlib.pod
index cfb281dcc7..14bb7ebfa4 100644
--- a/pod/perlmodlib.pod
+++ b/pod/perlmodlib.pod
@@ -225,6 +225,10 @@ write linker options files for dynamic extension
 
 add blib/* directories to @INC
 
+=item Fatal
+
+make errors in builtins or Perl functions fatal
+
 =item Fcntl
 
 load the C Fcntl.h defines
diff --git a/pp.c b/pp.c
index 79d884d115..64411df5c2 100644
--- a/pp.c
+++ b/pp.c
@@ -360,9 +360,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;
 }
diff --git a/t/comp/proto.t b/t/comp/proto.t
index 080110bdcc..2a4c9ccce5 100755
--- a/t/comp/proto.t
+++ b/t/comp/proto.t
@@ -16,7 +16,7 @@ BEGIN {
 
 use strict;
 
-print "1..76\n";
+print "1..80\n";
 
 my $i = 1;
 
@@ -377,6 +377,20 @@ sub array_ref_plus (\@@) {
 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.
 
diff --git a/toke.c b/toke.c
index f2a60e1c98..23174221d0 100644
--- a/toke.c
+++ b/toke.c
@@ -1042,9 +1042,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);