diff options
| -rw-r--r-- | embed.fnc | 3 | ||||
| -rw-r--r-- | embed.h | 1 | ||||
| -rw-r--r-- | op.c | 103 | ||||
| -rw-r--r-- | pp.c | 82 | ||||
| -rw-r--r-- | proto.h | 5 |
5 files changed, 115 insertions, 79 deletions
@@ -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 @@ -1009,6 +1009,7 @@ #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) @@ -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. */ @@ -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); @@ -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__ |