diff options
| -rw-r--r-- | embed.fnc | 3 | ||||
| -rw-r--r-- | embed.h | 2 | ||||
| -rw-r--r-- | global.sym | 1 | ||||
| -rw-r--r-- | gv.c | 3 | ||||
| -rw-r--r-- | gv.h | 4 | ||||
| -rw-r--r-- | op.c | 3 | ||||
| -rw-r--r-- | perl.c | 30 | ||||
| -rw-r--r-- | perlio.c | 2 | ||||
| -rw-r--r-- | pp_hot.c | 13 | ||||
| -rw-r--r-- | proto.h | 13 | ||||
| -rwxr-xr-x | t/op/ref.t | 8 | ||||
| -rw-r--r-- | toke.c | 9 |
12 files changed, 65 insertions, 26 deletions
@@ -639,7 +639,8 @@ Apd |I32 |eval_sv |NN SV* sv|I32 flags Apd |SV* |get_sv |NN const char* name|I32 create Apd |AV* |get_av |NN const char* name|I32 create Apd |HV* |get_hv |NN const char* name|I32 create -Apd |CV* |get_cv |NN const char* name|I32 create +Apd |CV* |get_cv |NN const char* name|I32 flags +Apd |CV* |get_cvn_flags |NN const char* name|STRLEN len|I32 flags Ap |int |init_i18nl10n |int printwarn Ap |int |init_i18nl14n |int printwarn Ap |void |new_collate |NULLOK const char* newcoll @@ -647,6 +647,7 @@ #define get_av Perl_get_av #define get_hv Perl_get_hv #define get_cv Perl_get_cv +#define get_cvn_flags Perl_get_cvn_flags #define init_i18nl10n Perl_init_i18nl10n #define init_i18nl14n Perl_init_i18nl14n #define new_collate Perl_new_collate @@ -2858,6 +2859,7 @@ #define get_av(a,b) Perl_get_av(aTHX_ a,b) #define get_hv(a,b) Perl_get_hv(aTHX_ a,b) #define get_cv(a,b) Perl_get_cv(aTHX_ a,b) +#define get_cvn_flags(a,b,c) Perl_get_cvn_flags(aTHX_ a,b,c) #define init_i18nl10n(a) Perl_init_i18nl10n(aTHX_ a) #define init_i18nl14n(a) Perl_init_i18nl14n(aTHX_ a) #define new_collate(a) Perl_new_collate(aTHX_ a) diff --git a/global.sym b/global.sym index d59dd24f65..21d7532522 100644 --- a/global.sym +++ b/global.sym @@ -368,6 +368,7 @@ Perl_get_sv Perl_get_av Perl_get_hv Perl_get_cv +Perl_get_cvn_flags Perl_init_i18nl10n Perl_init_i18nl14n Perl_new_collate @@ -806,8 +806,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, HV *stash = NULL; const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT); const I32 no_expand = flags & GV_NOEXPAND; - const I32 add = - flags & ~SVf_UTF8 & ~GV_NOADD_NOINIT & ~GV_NOEXPAND & ~GV_NOTQUAL; + const I32 add = flags & ~GV_NOADD_MASK; const char *const name_end = nambeg + full_len; const char *const name_em1 = name_end - 1; @@ -207,6 +207,10 @@ Return the SV from the GV. /* SVf_UTF8 (more accurately the return value from SvUTF8) is also valid as a flag to gv_fetch_pvn_flags, so ensure it lies outside this range. */ + +#define GV_NOADD_MASK (SVf_UTF8|GV_NOADD_NOINIT|GV_NOEXPAND|GV_NOTQUAL) +/* The bit flags that don't cause gv_fetchpv() to add a symbol if not found */ + #define gv_fullname3(sv,gv,prefix) gv_fullname4(sv,gv,prefix,TRUE) #define gv_efullname3(sv,gv,prefix) gv_efullname4(sv,gv,prefix,TRUE) #define gv_fetchmethod(stash, name) gv_fetchmethod_autoload(stash, name, TRUE) @@ -2063,7 +2063,8 @@ Perl_newPROG(pTHX_ OP *o) /* Register with debugger */ if (PERLDB_INTER) { - CV * const cv = get_cv("DB::postponed", FALSE); + CV * const cv + = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0); if (cv) { dSP; PUSHMARK(SP); @@ -2476,33 +2476,47 @@ Perl_get_hv(pTHX_ const char *name, I32 create) /* =head1 CV Manipulation Functions +=for apidoc p||get_cvn_flags + +Returns the CV of the specified Perl subroutine. C<flags> are passed to +C<gv_fetchpvn_flags>. If C<GV_ADD> is set and the Perl subroutine does not +exist then it will be declared (which has the same effect as saying +C<sub name;>). If C<GV_ADD> is not set and the subroutine does not exist +then NULL is returned. + =for apidoc p||get_cv -Returns the CV of the specified Perl subroutine. If C<create> is set and -the Perl subroutine does not exist then it will be declared (which has the -same effect as saying C<sub name;>). If C<create> is not set and the -subroutine does not exist then NULL is returned. +Uses C<strlen> to get the length of C<name>, then calls C<get_cvn_flags>. =cut */ CV* -Perl_get_cv(pTHX_ const char *name, I32 create) +Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len, I32 flags) { - GV* const gv = gv_fetchpv(name, create, SVt_PVCV); + GV* const gv = gv_fetchpvn_flags(name, len, flags, SVt_PVCV); /* XXX unsafe for threads if eval_owner isn't held */ /* XXX this is probably not what they think they're getting. * It has the same effect as "sub name;", i.e. just a forward * declaration! */ - if (create && !GvCVu(gv)) + if ((flags & ~GV_NOADD_MASK) && !GvCVu(gv)) { + SV *const sv = newSVpvn(name,len); + SvFLAGS(sv) |= flags & SVf_UTF8; return newSUB(start_subparse(FALSE, 0), - newSVOP(OP_CONST, 0, newSVpv(name,0)), + newSVOP(OP_CONST, 0, sv), NULL, NULL); + } if (gv) return GvCVu(gv); return NULL; } +CV* +Perl_get_cv(pTHX_ const char *name, I32 flags) +{ + return get_cvn_flags(name, strlen(name), flags); +} + /* Be sure to refetch the stack pointer after calling these routines. */ /* @@ -796,7 +796,7 @@ PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load) } else { SV * const pkgsv = newSVpvs("PerlIO"); SV * const layer = newSVpvn(name, len); - CV * const cv = get_cv("PerlIO::Layer::NoWarnings", FALSE); + CV * const cv = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("PerlIO::Layer::NoWarnings"), 0); ENTER; SAVEINT(PL_in_load_module); if (cv) { @@ -2710,6 +2710,7 @@ PP(pp_entersub) default: if (!SvROK(sv)) { const char *sym; + STRLEN len; if (sv == &PL_sv_yes) { /* unfound import, ignore */ if (hasargs) SP = PL_stack_base + POPMARK; @@ -2719,16 +2720,22 @@ PP(pp_entersub) mg_get(sv); if (SvROK(sv)) goto got_rv; - sym = SvPOKp(sv) ? SvPVX_const(sv) : NULL; + if (SvPOKp(sv)) { + sym = SvPVX_const(sv); + len = SvCUR(sv); + } else { + sym = NULL; + len = 0; + } } else { - sym = SvPV_nolen_const(sv); + sym = SvPV_const(sv, len); } if (!sym) DIE(aTHX_ PL_no_usym, "a subroutine"); if (PL_op->op_private & HINT_STRICT_REFS) DIE(aTHX_ PL_no_symref, sym, "a subroutine"); - cv = get_cv(sym, TRUE); + cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv)); break; } got_rv: @@ -1769,7 +1769,10 @@ PERL_CALLCONV AV* Perl_get_av(pTHX_ const char* name, I32 create) PERL_CALLCONV HV* Perl_get_hv(pTHX_ const char* name, I32 create) __attribute__nonnull__(pTHX_1); -PERL_CALLCONV CV* Perl_get_cv(pTHX_ const char* name, I32 create) +PERL_CALLCONV CV* Perl_get_cv(pTHX_ const char* name, I32 flags) + __attribute__nonnull__(pTHX_1); + +PERL_CALLCONV CV* Perl_get_cvn_flags(pTHX_ const char* name, STRLEN len, I32 flags) __attribute__nonnull__(pTHX_1); PERL_CALLCONV int Perl_init_i18nl10n(pTHX_ int printwarn); @@ -2603,10 +2606,6 @@ PERL_CALLCONV int Perl_yyparse(pTHX); PERL_CALLCONV void Perl_parser_free(pTHX_ const yy_parser *) __attribute__nonnull__(pTHX_1); -PERL_CALLCONV yy_parser* Perl_parser_dup(pTHX_ const yy_parser *proto, CLONE_PARAMS* param) - __attribute__nonnull__(pTHX_1) - __attribute__nonnull__(pTHX_2); - PERL_CALLCONV int Perl_yywarn(pTHX_ const char* s) __attribute__nonnull__(pTHX_1); @@ -2864,6 +2863,10 @@ PERL_CALLCONV void Perl_rvpv_dup(pTHX_ SV* dstr, const SV *sstr, CLONE_PARAMS* p __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); +PERL_CALLCONV yy_parser* Perl_parser_dup(pTHX_ const yy_parser *proto, CLONE_PARAMS* param) + __attribute__nonnull__(pTHX_1) + __attribute__nonnull__(pTHX_2); + #endif PERL_CALLCONV PTR_TBL_t* Perl_ptr_table_new(pTHX) __attribute__malloc__ diff --git a/t/op/ref.t b/t/op/ref.t index 1c713a977e..9d8818259e 100755 --- a/t/op/ref.t +++ b/t/op/ref.t @@ -8,7 +8,7 @@ BEGIN { require 'test.pl'; use strict qw(refs subs); -plan(119); +plan(121); # Test glob operations. @@ -468,6 +468,12 @@ TODO: { my $glob2 = *{$name2}; isnt ($glob1, $glob2, "We get different typeglobs"); + + *{$name1} = sub {"One"}; + *{$name2} = sub {"Two"}; + + is (&{$name1}, "One"); + is (&{$name2}, "Two"); } # test derefs after list slice @@ -4795,12 +4795,12 @@ Perl_yylex(pTHX) t++; } while (isSPACE(*t)); if (isIDFIRST_lazy_if(t,UTF)) { - STRLEN dummylen; + STRLEN len; t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, - &dummylen); + &len); while (isSPACE(*t)) t++; - if (*t == ';' && get_cv(tmpbuf, FALSE)) + if (*t == ';' && get_cvn_flags(tmpbuf, len, 0)) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "You need to quote \"%s\"", tmpbuf); @@ -10738,7 +10738,8 @@ S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRL } if (PL_lex_state == LEX_NORMAL) { if (ckWARN(WARN_AMBIGUOUS) && - (keyword(dest, d - dest, 0) || get_cv(dest, FALSE))) + (keyword(dest, d - dest, 0) + || get_cvn_flags(dest, d - dest, 0))) { if (funny == '#') funny = '@'; |