This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add core_prototype; make pp_prototype use it
authorFather Chrysostomos <sprout@cpan.org>
Tue, 26 Jul 2011 05:33:40 +0000 (22:33 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Tue, 26 Jul 2011 07:09:04 +0000 (00:09 -0700)
This commit moves the code for generating core prototypes into a sepa-
rate function, core_prototype, in op.c. This serves two porpoises:

• It allows the lock and tie exceptional cases to be incorporated into
  the main prototype=generation code, which requires the use of a
  static function in op.c.
• It allows other parts of the core (e.g., the upcoming \&CORE::foo
  feature) to use the same code.

The docs for it are in a section boringly entitled ‘Functions in
op.c’, for lack of a better name. This, I believe, is the only op.c
function that is in perlintern currently, so it’s hard to see what to
name a section that will, at least for now, contain nothing else.

embed.fnc
embed.h
op.c
pp.c
proto.h

index 022f3af..1f0ed0e 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -263,6 +263,9 @@ Afnp        |void   |sv_setpvf_mg_nocontext|NN SV *const sv|NN const char *const pat|...
 Afnp   |int    |fprintf_nocontext|NN PerlIO *stream|NN const char *format|...
 Afnp   |int    |printf_nocontext|NN const char *format|...
 #endif
+: Used in pp.c
+p      |SV *   |core_prototype |NULLOK SV *sv|NN const char *name \
+                               |const STRLEN len|const bool croak
 : Used in sv.c
 p      |void   |cv_ckproto_len |NN const CV* cv|NULLOK const GV* gv\
                                |NULLOK const char* p|const STRLEN len
diff --git a/embed.h b/embed.h
index 38ce471..f0b8214 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define ck_trunc(a)            Perl_ck_trunc(aTHX_ a)
 #define ck_unpack(a)           Perl_ck_unpack(aTHX_ a)
 #define convert(a,b,c)         Perl_convert(aTHX_ a,b,c)
+#define core_prototype(a,b,c,d)        Perl_core_prototype(aTHX_ a,b,c,d)
 #define create_eval_scope(a)   Perl_create_eval_scope(aTHX_ a)
 #define cv_ckproto_len(a,b,c,d)        Perl_cv_ckproto_len(aTHX_ a,b,c,d)
 #define cvgv_set(a,b)          Perl_cvgv_set(aTHX_ a,b)
diff --git a/op.c b/op.c
index 1ff086b..2c829de 100644 (file)
--- a/op.c
+++ b/op.c
@@ -10181,6 +10181,109 @@ Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
        Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
 }
 
+/*
+=head1 Functions in file op.c
+
+=for apidoc core_prototype
+This function assigns the prototype of the named core function to C<sv>, or
+to a new mortal SV if C<sv> is NULL.  It returns the modified C<sv>, or
+NULL if the core function has no prototype.
+
+If the C<name> is not a Perl keyword, it croaks if C<croak> is true, or
+returns NULL if C<croak> is false.
+
+=cut
+*/
+
+SV *
+Perl_core_prototype(pTHX_ SV *sv, const char *name, const STRLEN len,
+                          const bool croak)
+{
+    const int code = keyword(name, len, 1);
+    int i = 0, n = 0, seen_question = 0, defgv = 0;
+    I32 oa;
+#define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
+    char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
+
+    PERL_ARGS_ASSERT_CORE_PROTOTYPE;
+
+    if (!code) {
+       if (croak)
+           return (SV *)Perl_die(aTHX_
+               "Can't find an opnumber for \"%s\"", name
+           );
+       return NULL;
+    }
+
+    if (code > 0) return NULL; /* Not overridable */
+
+    if (!sv) sv = sv_newmortal();
+
+#define retsetpvs(x) sv_setpvs(sv, x); return sv
+
+    switch (-code) {
+    case KEY_and   : case KEY_chop: case KEY_chomp:
+    case KEY_cmp   : case KEY_exec: case KEY_eq   :
+    case KEY_ge    : case KEY_gt  : case KEY_le   :
+    case KEY_lt    : case KEY_ne  : case KEY_or   :
+    case KEY_system: case KEY_x   : case KEY_xor  :
+       return NULL;
+    case KEY_mkdir:
+       retsetpvs("_;$");
+    case KEY_keys: case KEY_values: case KEY_each:
+       retsetpvs("+");
+    case KEY_push: case KEY_unshift:
+       retsetpvs("+@");
+    case KEY_pop: case KEY_shift:
+       retsetpvs(";+");
+    case KEY_splice:
+       retsetpvs("+;$$@");
+    case KEY_lock: case KEY_tied: case KEY_untie:
+       retsetpvs("\\[$@%*]");
+    case KEY_tie:
+       retsetpvs("\\[$@%*]$@");
+    case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
+       retsetpvs("");
+    case KEY_readpipe:
+       name = "backtick";
+    }
+
+#undef retsetpvs
+
+    while (i < MAXO) { /* The slow way. */
+       if (strEQ(name, PL_op_name[i])
+           || strEQ(name, PL_op_desc[i]))
+       {
+           goto found;
+       }
+       i++;
+    }
+    return NULL;    /* Should not happen... */
+  found:
+    defgv = PL_opargs[i] & OA_DEFGV;
+    oa = PL_opargs[i] >> OASHIFT;
+    while (oa) {
+       if (oa & OA_OPTIONAL && !seen_question && !defgv) {
+           seen_question = 1;
+           str[n++] = ';';
+       }
+       if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
+           && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
+           /* But globs are already references (kinda) */
+           && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
+       ) {
+           str[n++] = '\\';
+       }
+       str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
+       oa = oa >> 4;
+    }
+    if (defgv && str[n - 1] == '$')
+       str[n - 1] = '_';
+    str[n++] = '\0';
+    sv_setpvn(sv, str, n - 1);
+    return sv;
+}
+
 #include "XSUB.h"
 
 /* Efficient sub that returns a constant scalar value. */
diff --git a/pp.c b/pp.c
index ccbbf35..8649bec 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -438,85 +438,9 @@ PP(pp_prototype)
     if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
        const char * s = SvPVX_const(TOPs);
        if (strnEQ(s, "CORE::", 6)) {
-           const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
-           if (code < 0) {     /* Overridable. */
-#define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
-               int i = 0, n = 0, seen_question = 0, defgv = 0;
-               I32 oa;
-               char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
-
-               switch (-code) {
-               case KEY_and   : case KEY_chop: case KEY_chomp:
-               case KEY_cmp   : case KEY_exec: case KEY_eq   :
-               case KEY_ge    : case KEY_gt  : case KEY_le   :
-               case KEY_lt    : case KEY_ne  : case KEY_or   :
-               case KEY_system: case KEY_x   : case KEY_xor  :
-                   goto set;
-               case KEY_mkdir:
-                   ret = newSVpvs_flags("_;$", SVs_TEMP);
-                   goto set;
-               case KEY_keys: case KEY_values: case KEY_each:
-                   ret = newSVpvs_flags("+", SVs_TEMP);
-                   goto set;
-               case KEY_push: case KEY_unshift:
-                   ret = newSVpvs_flags("+@", SVs_TEMP);
-                   goto set;
-               case KEY_pop: case KEY_shift:
-                   ret = newSVpvs_flags(";+", SVs_TEMP);
-                   goto set;
-               case KEY_splice:
-                   ret = newSVpvs_flags("+;$$@", SVs_TEMP);
-                   goto set;
-               case KEY_lock: case KEY_tied: case KEY_untie:
-                   ret = newSVpvs_flags("\\[$@%*]", SVs_TEMP);
-                   goto set;
-               case KEY_tie:
-                   ret = newSVpvs_flags("\\[$@%*]$@", SVs_TEMP);
-                   goto set;
-               case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
-                   ret = newSVpvs_flags("", SVs_TEMP);
-                   goto set;
-               case KEY_readpipe:
-                   s = "CORE::backtick";
-               }
-               while (i < MAXO) {      /* The slow way. */
-                   if (strEQ(s + 6, PL_op_name[i])
-                       || strEQ(s + 6, PL_op_desc[i]))
-                   {
-                       goto found;
-                   }
-                   i++;
-               }
-               goto nonesuch;          /* Should not happen... */
-             found:
-               defgv = PL_opargs[i] & OA_DEFGV;
-               oa = PL_opargs[i] >> OASHIFT;
-               while (oa) {
-                   if (oa & OA_OPTIONAL && !seen_question && !defgv) {
-                       seen_question = 1;
-                       str[n++] = ';';
-                   }
-                   if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
-                       && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
-                       /* But globs are already references (kinda) */
-                       && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
-                   ) {
-                       str[n++] = '\\';
-                   }
-                   str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
-                   oa = oa >> 4;
-               }
-               if (defgv && str[n - 1] == '$')
-                   str[n - 1] = '_';
-               str[n++] = '\0';
-               ret = newSVpvn_flags(str, n - 1, SVs_TEMP);
-           }
-           else if (code)              /* Non-Overridable */
-               goto set;
-           else {                      /* None such */
-             nonesuch:
-               DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
-           }
+           SV *const sv = core_prototype(NULL, s + 6, SvCUR(TOPs) - 6, 1);
+           if (sv) ret = sv;
+           goto set;
        }
     }
     cv = sv_2cv(TOPs, &stash, &gv, 0);
diff --git a/proto.h b/proto.h
index e2c2c8c..750b792 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -571,6 +571,11 @@ PERL_CALLCONV void Perl_cop_store_label(pTHX_ COP *const cop, const char *label,
 #define PERL_ARGS_ASSERT_COP_STORE_LABEL       \
        assert(cop); assert(label)
 
+PERL_CALLCONV SV *     Perl_core_prototype(pTHX_ SV *sv, const char *name, const STRLEN len, const bool croak)
+                       __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_CORE_PROTOTYPE        \
+       assert(name)
+
 PERL_CALLCONV PERL_CONTEXT*    Perl_create_eval_scope(pTHX_ U32 flags);
 PERL_CALLCONV void     Perl_croak(pTHX_ const char* pat, ...)
                        __attribute__noreturn__