diff options
| -rw-r--r-- | dump.c | 8 | ||||
| -rw-r--r-- | embed.fnc | 5 | ||||
| -rw-r--r-- | embed.h | 2 | ||||
| -rw-r--r-- | global.sym | 1 | ||||
| -rw-r--r-- | mathoms.c | 5 | ||||
| -rw-r--r-- | op.c | 53 | ||||
| -rw-r--r-- | pod/perlapi.pod | 6 | ||||
| -rw-r--r-- | proto.h | 3 | ||||
| -rw-r--r-- | sv.c | 16 | ||||
| -rw-r--r-- | util.c | 4 |
10 files changed, 75 insertions, 28 deletions
@@ -1552,8 +1552,12 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo } break; case SVt_PVCV: - if (SvPOK(sv)) - Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n", SvPV_nolen_const(sv)); + if (SvPOK(sv)) { + STRLEN len; + const char *const proto = SvPV_const(sv, len); + Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n", + (int) len, proto); + } /* FALL THROUGH */ case SVt_PVFM: do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv)); @@ -150,7 +150,10 @@ Afnp |void |sv_setpvf_mg_nocontext|NN SV* sv|NN const char* pat|... Afnp |int |fprintf_nocontext|NN PerlIO* stream|NN const char* fmt|... Afnp |int |printf_nocontext|NN const char* fmt|... #endif -p |void |cv_ckproto |NN const CV* cv|NULLOK const GV* gv|NULLOK const char* p +bp |void |cv_ckproto |NN const CV* cv|NULLOK const GV* gv\ + |NULLOK const char* p +p |void |cv_ckproto_len |NN const CV* cv|NULLOK const GV* gv\ + |NULLOK const char* p|const STRLEN len pd |CV* |cv_clone |NN CV* proto ApdR |SV* |gv_const_sv |NN GV* gv ApdR |SV* |cv_const_sv |NULLOK CV* cv @@ -117,6 +117,7 @@ #endif #ifdef PERL_CORE #define cv_ckproto Perl_cv_ckproto +#define cv_ckproto_len Perl_cv_ckproto_len #define cv_clone Perl_cv_clone #endif #define gv_const_sv Perl_gv_const_sv @@ -2281,6 +2282,7 @@ #endif #ifdef PERL_CORE #define cv_ckproto(a,b,c) Perl_cv_ckproto(aTHX_ a,b,c) +#define cv_ckproto_len(a,b,c,d) Perl_cv_ckproto_len(aTHX_ a,b,c,d) #define cv_clone(a) Perl_cv_clone(aTHX_ a) #endif #define gv_const_sv(a) Perl_gv_const_sv(aTHX_ a) diff --git a/global.sym b/global.sym index ef432ddea0..257a2fcaf0 100644 --- a/global.sym +++ b/global.sym @@ -74,6 +74,7 @@ Perl_sv_catpvf_mg_nocontext Perl_sv_setpvf_mg_nocontext Perl_fprintf_nocontext Perl_printf_nocontext +Perl_cv_ckproto Perl_gv_const_sv Perl_cv_const_sv Perl_cv_undef @@ -1236,6 +1236,11 @@ Perl_sv_usepvn(pTHX_ SV *sv, char *ptr, STRLEN len) sv_usepvn_flags(sv,ptr,len, 0); } +void +Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p) +{ + cv_ckproto_len(cv, gv, p, p ? strlen(p) : 0); +} #endif /* NO_MATHOMS */ /* @@ -4814,9 +4814,15 @@ Perl_cv_undef(pTHX_ CV *cv) } void -Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p) -{ - if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) { +Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p, + const STRLEN len) +{ + /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by + relying on SvCUR, and doubling up the buffer to hold CvFILE(). */ + if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */ + || (p && (len != SvCUR(cv) /* Not the same length. */ + || memNE(p, SvPVX_const(cv), len)))) + && ckWARN_d(WARN_PROTOTYPE)) { SV* const msg = sv_newmortal(); SV* name = NULL; @@ -4831,7 +4837,7 @@ Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p) sv_catpvs(msg, ": none"); sv_catpvs(msg, " vs "); if (p) - Perl_sv_catpvf(aTHX_ msg, "(%s)", p); + Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p); else sv_catpvs(msg, "none"); Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg); @@ -5036,7 +5042,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) { Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype"); } - cv_ckproto((CV*)gv, NULL, ps); + cv_ckproto_len((CV*)gv, NULL, ps, ps_len); } if (ps) sv_setpvn((SV*)gv, ps, ps_len); @@ -5080,7 +5086,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) * skipping the prototype check */ if (exists || SvPOK(cv)) - cv_ckproto(cv, gv, ps); + cv_ckproto_len(cv, gv, ps, ps_len); /* already defined (or promised)? */ if (exists || GvASSUMECV(gv)) { if ((!block @@ -5391,6 +5397,15 @@ Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv) { dVAR; CV* cv; +#ifdef USE_ITHREADS + const char *const temp_p = CopFILE(PL_curcop); + const STRLEN len = strlen(temp_p); +#else + SV *const temp_sv = CopFILESV(PL_curcop); + STRLEN len; + const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL; +#endif + char *const file = temp_p ? savepvn(temp_p, len) : NULL; ENTER; @@ -5407,10 +5422,18 @@ Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv) CopSTASH_set(PL_curcop,stash); } - cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop))); + /* file becomes the CvFILE. For an XS, it's supposed to be static storage, + and so doesn't get free()d. (It's expected to be from the C pre- + processor __FILE__ directive). But we need a dynamically allocated one, + and we need it to get freed. So we cheat, and take advantage of the + fact that the first 0 bytes of any string always look the same. */ + cv = newXS(name, const_sv_xsub, file); CvXSUBANY(cv).any_ptr = sv; CvCONST_on(cv); - sv_setpvn((SV*)cv, "", 0); /* prototype is "" */ + /* prototype is "". But this gets free()d. :-) */ + sv_usepvn_flags((SV*)cv, file, len, SV_HAS_TRAILING_NUL); + /* This gives us a prototype of "", rather than the file name. */ + SvCUR_set(cv, 0); #ifdef USE_ITHREADS if (stash) @@ -7209,6 +7232,7 @@ Perl_ck_subr(pTHX_ OP *o) OP *o2 = prev->op_sibling; OP *cvop; char *proto = NULL; + const char *proto_end = NULL; CV *cv = NULL; GV *namegv = NULL; int optional = 0; @@ -7231,8 +7255,10 @@ Perl_ck_subr(pTHX_ OP *o) tmpop->op_private |= OPpEARLY_CV; else { if (SvPOK(cv)) { + STRLEN len; namegv = CvANON(cv) ? gv : CvGV(cv); - proto = SvPV_nolen((SV*)cv); + proto = SvPV((SV*)cv, len); + proto_end = proto + len; } if (CvASSERTION(cv)) { if (PL_hints & HINT_ASSERTING) { @@ -7269,9 +7295,10 @@ Perl_ck_subr(pTHX_ OP *o) else o3 = o2; if (proto) { - switch (*proto) { - case '\0': + if (proto >= proto_end) return too_many_arguments(o, gv_ename(namegv)); + + switch (*proto) { case ';': optional = 1; proto++; @@ -7437,8 +7464,8 @@ Perl_ck_subr(pTHX_ OP *o) prev = o2; o2 = o2->op_sibling; } /* while */ - if (proto && !optional && - (*proto && *proto != '@' && *proto != '%' && *proto != ';')) + if (proto && !optional && proto_end > proto && + (*proto != '@' && *proto != '%' && *proto != ';')) return too_few_arguments(o, gv_ename(namegv)); if(delete_op) { #ifdef PERL_MAD diff --git a/pod/perlapi.pod b/pod/perlapi.pod index ebc1c27880..225a5cbc09 100644 --- a/pod/perlapi.pod +++ b/pod/perlapi.pod @@ -2121,8 +2121,8 @@ X<savepvn> Perl's version of what C<strndup()> would be if it existed. Returns a pointer to a newly allocated string which is a duplicate of the first -C<len> bytes from C<pv>. The memory allocated for the new string can be -freed with the C<Safefree()> function. +C<len> bytes from C<pv>, plus a trailing NUL byte. The memory allocated for +the new string can be freed with the C<Safefree()> function. char* savepvn(const char* pv, I32 len) @@ -5758,7 +5758,7 @@ that pointer (e.g. ptr + 1) be used. If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC. If C<flags> & SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be NUL, and the realloc -I<may> be skipped. (i.e. the buffer is actually at least 1 byte longer than +will be skipped. (i.e. the buffer is actually at least 1 byte longer than C<len>, and already meets the requirements for storing in C<SvPVX>) void sv_usepvn_flags(SV* sv, char* ptr, STRLEN len, U32 flags) @@ -304,6 +304,9 @@ PERL_CALLCONV int Perl_printf_nocontext(const char* fmt, ...) PERL_CALLCONV void Perl_cv_ckproto(pTHX_ const CV* cv, const GV* gv, const char* p) __attribute__nonnull__(pTHX_1); +PERL_CALLCONV void Perl_cv_ckproto_len(pTHX_ const CV* cv, const GV* gv, const char* p, const STRLEN len) + __attribute__nonnull__(pTHX_1); + PERL_CALLCONV CV* Perl_cv_clone(pTHX_ CV* proto) __attribute__nonnull__(pTHX_1); @@ -3309,8 +3309,9 @@ S_glob_assign_ref(pTHX_ SV *dstr, SV *sstr) { } } if (!intro) - cv_ckproto(cv, (GV*)dstr, - SvPOK(sref) ? SvPVX_const(sref) : NULL); + cv_ckproto_len(cv, (GV*)dstr, + SvPOK(sref) ? SvPVX_const(sref) : NULL, + SvPOK(sref) ? SvCUR(sref) : 0); } GvCVGEN(dstr) = 0; /* Switch off cacheness. */ GvASSUMECV_on(dstr); @@ -3898,7 +3899,7 @@ that pointer (e.g. ptr + 1) be used. If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC. If C<flags> & SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be NUL, and the realloc -I<may> be skipped. (i.e. the buffer is actually at least 1 byte longer than +will be skipped. (i.e. the buffer is actually at least 1 byte longer than C<len>, and already meets the requirements for storing in C<SvPVX>) =cut @@ -3925,20 +3926,21 @@ Perl_sv_usepvn_flags(pTHX_ SV *sv, char *ptr, STRLEN len, U32 flags) allocate = (flags & SV_HAS_TRAILING_NUL) ? len + 1: PERL_STRLEN_ROUNDUP(len + 1); + if (flags & SV_HAS_TRAILING_NUL) { + /* It's long enough - do nothing. + Specfically Perl_newCONSTSUB is relying on this. */ + } else { #ifdef DEBUGGING - { /* Force a move to shake out bugs in callers. */ char *new_ptr = safemalloc(allocate); Copy(ptr, new_ptr, len, char); PoisonFree(ptr,len,char); Safefree(ptr); ptr = new_ptr; - } #else - if (!(flags & SV_HAS_TRAILING_NUL)) { ptr = saferealloc (ptr, allocate); - } #endif + } SvPV_set(sv, ptr); SvCUR_set(sv, len); SvLEN_set(sv, allocate); @@ -895,8 +895,8 @@ Perl_savepv(pTHX_ const char *pv) Perl's version of what C<strndup()> would be if it existed. Returns a pointer to a newly allocated string which is a duplicate of the first -C<len> bytes from C<pv>. The memory allocated for the new string can be -freed with the C<Safefree()> function. +C<len> bytes from C<pv>, plus a trailing NUL byte. The memory allocated for +the new string can be freed with the C<Safefree()> function. =cut */ |