5.004_56: patch for `use Fatal' again

p4raw-id: //depot/perl@467

diff --git a/MANIFEST b/MANIFEST
index 6099503..8267280 100644 (file)
--- 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 166e046..20c0ae1 100644 (file)
--- 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 a1184c8..bae135b 100644 (file)
--- 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 cfb281d..14bb7eb 100644 (file)
--- 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 79d884d..64411df 100644 (file)
--- 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 080110b..2a4c9cc 100755 (executable)
--- 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 f2a60e1..2317422 100644 (file)
--- 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);