X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pad.c;h=d80679ad861617f51734de9367766291a297cce0;hb=484c818fbcf400d897228be2cf2b34b67be8a340;hp=d1b9735fa4d025f6ff47f5b7912f28430db72213;hpb=76f68e9bb86f29e34e2aeb5c177571288f05b7ca;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pad.c b/pad.c index d1b9735..d80679a 100644 --- a/pad.c +++ b/pad.c @@ -5,13 +5,17 @@ * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. + */ + +/* + * 'Anyway: there was this Mr. Frodo left an orphan and stranded, as you + * might say, among those queer Bucklanders, being brought up anyhow in + * Brandy Hall. A regular warren, by all accounts. Old Master Gorbadoc + * never had fewer than a couple of hundred relations in the place. + * Mr. Bilbo never did a kinder deed than when he brought the lad back + * to live among decent folk.' --the Gaffer * - * "Anyway: there was this Mr Frodo left an orphan and stranded, as you - * might say, among those queer Bucklanders, being brought up anyhow in - * Brandy Hall. A regular warren, by all accounts. Old Master Gorbadoc - * never had fewer than a couple of hundred relations in the place. Mr - * Bilbo never did a kinder deed than when he brought the lad back to - * live among decent folk." --the Gaffer + * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"] */ /* XXX DAPM @@ -176,7 +180,7 @@ Perl_pad_new(pTHX_ int flags) SAVEI32(PL_max_intro_pending); SAVEBOOL(PL_cv_has_eval); if (flags & padnew_SAVESUB) { - SAVEI32(PL_pad_reset_pending); + SAVEBOOL(PL_pad_reset_pending); } } } @@ -197,7 +201,7 @@ Perl_pad_new(pTHX_ int flags) AV * const a0 = newAV(); /* will be @_ */ av_extend(a0, 0); - av_store(pad, 0, (SV*)a0); + av_store(pad, 0, MUTABLE_SV(a0)); AvREIFY_only(a0); } else { @@ -205,8 +209,8 @@ Perl_pad_new(pTHX_ int flags) } AvREAL_off(padlist); - av_store(padlist, 0, (SV*)padname); - av_store(padlist, 1, (SV*)pad); + av_store(padlist, 0, MUTABLE_SV(padname)); + av_store(padlist, 1, MUTABLE_SV(pad)); /* ... then update state variables */ @@ -319,16 +323,16 @@ Perl_pad_undef(pTHX_ CV* cv) while (ix >= 0) { SV* const sv = AvARRAY(padlist)[ix--]; if (sv) { - if (sv == (SV*)PL_comppad_name) + if (sv == (const SV *)PL_comppad_name) PL_comppad_name = NULL; - else if (sv == (SV*)PL_comppad) { + else if (sv == (const SV *)PL_comppad) { PL_comppad = NULL; PL_curpad = NULL; } } SvREFCNT_dec(sv); } - SvREFCNT_dec((SV*)CvPADLIST(cv)); + SvREFCNT_dec(MUTABLE_SV(CvPADLIST(cv))); CvPADLIST(cv) = NULL; } @@ -351,35 +355,46 @@ If fake, it means we're cloning an existing entry */ PADOFFSET -Perl_pad_add_name(pTHX_ const char *name, HV* typestash, HV* ourstash, bool fake, bool state) +Perl_pad_add_name(pTHX_ const char *name, const STRLEN len, const U32 flags, + HV *typestash, HV *ourstash) { dVAR; const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY); - SV* const namesv - = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV); + SV *namesv; PERL_ARGS_ASSERT_PAD_ADD_NAME; ASSERT_CURPAD_ACTIVE("pad_add_name"); + if (flags & ~(pad_add_STATE|pad_add_FAKE)) + Perl_croak(aTHX_ "panic: pad_add_name illegal flag bits 0x%" UVxf, + (UV)flags); + + namesv = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV); + + /* Until we're using the length for real, cross check that we're being told + the truth. */ + PERL_UNUSED_ARG(len); + assert(strlen(name) == len); + sv_setpv(namesv, name); if (typestash) { assert(SvTYPE(namesv) == SVt_PVMG); SvPAD_TYPED_on(namesv); - SvSTASH_set(namesv, MUTABLE_HV(SvREFCNT_inc_simple_NN((SV*)typestash))); + SvSTASH_set(namesv, MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash)))); } if (ourstash) { SvPAD_OUR_on(namesv); SvOURSTASH_set(namesv, ourstash); SvREFCNT_inc_simple_void_NN(ourstash); } - else if (state) { + else if (flags & pad_add_STATE) { SvPAD_STATE_on(namesv); } av_store(PL_comppad_name, offset, namesv); - if (fake) { + if (flags & pad_add_FAKE) { SvFAKE_on(namesv); DEBUG_Xv(PerlIO_printf(Perl_debug_log, "Pad addname: %ld \"%s\" FAKE\n", (long)offset, name)); @@ -396,9 +411,9 @@ Perl_pad_add_name(pTHX_ const char *name, HV* typestash, HV* ourstash, bool fake /* XXX DAPM since slot has been allocated, replace * av_store with PL_curpad[offset] ? */ if (*name == '@') - av_store(PL_comppad, offset, (SV*)newAV()); + av_store(PL_comppad, offset, MUTABLE_SV(newAV())); else if (*name == '%') - av_store(PL_comppad, offset, (SV*)newHV()); + av_store(PL_comppad, offset, MUTABLE_SV(newHV())); SvPADMY_on(PL_curpad[offset]); DEBUG_Xv(PerlIO_printf(Perl_debug_log, "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n", @@ -536,15 +551,27 @@ C indicates that the name to check is an 'our' declaration /* XXX DAPM integrate this into pad_add_name ??? */ void -Perl_pad_check_dup(pTHX_ const char *name, bool is_our, const HV *ourstash) +Perl_pad_check_dup(pTHX_ const char *name, const STRLEN len, const U32 flags, + const HV *ourstash) { dVAR; SV **svp; PADOFFSET top, off; + const U32 is_our = flags & pad_add_OUR; PERL_ARGS_ASSERT_PAD_CHECK_DUP; ASSERT_CURPAD_ACTIVE("pad_check_dup"); + + if (flags & ~pad_add_OUR) + Perl_croak(aTHX_ "panic: pad_check_dup illegal flag bits 0x%" UVxf, + (UV)flags); + + /* Until we're using the length for real, cross check that we're being told + the truth. */ + PERL_UNUSED_ARG(len); + assert(strlen(name) == len); + if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC)) return; /* nothing to check */ @@ -564,9 +591,9 @@ Perl_pad_check_dup(pTHX_ const char *name, bool is_our, const HV *ourstash) if (is_our && (SvPAD_OUR(sv))) break; /* "our" masking "our" */ Perl_warner(aTHX_ packWARN(WARN_MISC), - "\"%s\" variable %s masks earlier declaration in same %s", + "\"%s\" variable %"SVf" masks earlier declaration in same %s", (is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"), - name, + sv, (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX ? "scope" : "statement")); --off; break; @@ -584,7 +611,7 @@ Perl_pad_check_dup(pTHX_ const char *name, bool is_our, const HV *ourstash) && strEQ(name, SvPVX_const(sv))) { Perl_warner(aTHX_ packWARN(WARN_MISC), - "\"our\" variable %s redeclared", name); + "\"our\" variable %"SVf" redeclared", sv); if ((I32)off <= PL_comppad_name_floor) Perl_warner(aTHX_ packWARN(WARN_MISC), "\t(Did you mean \"local\" instead of \"our\"?)\n"); @@ -608,7 +635,7 @@ Returns the offset in the current pad, or NOT_IN_PAD on failure. */ PADOFFSET -Perl_pad_findmy(pTHX_ const char *name) +Perl_pad_findmy(pTHX_ const char *name, STRLEN len, U32 flags) { dVAR; SV *out_sv; @@ -620,6 +647,22 @@ Perl_pad_findmy(pTHX_ const char *name) PERL_ARGS_ASSERT_PAD_FINDMY; pad_peg("pad_findmy"); + + if (flags) + Perl_croak(aTHX_ "panic: pad_findmy illegal flag bits 0x%" UVxf, + (UV)flags); + + /* Yes, it is a bug (read work in progress) that we're not really using this + length parameter, and instead relying on strlen() later on. But I'm not + comfortable about changing the pad API piecemeal to use and rely on + lengths. This only exists to avoid an "unused parameter" warning. */ + if (len < 2) + return NOT_IN_PAD; + + /* But until we're using the length for real, cross check that we're being + told the truth. */ + assert(strlen(name) == len); + offset = pad_findlex(name, PL_compcv, PL_cop_seqmax, 1, NULL, &out_sv, &out_flags); if ((PADOFFSET)offset != NOT_IN_PAD) @@ -777,9 +820,9 @@ S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn, ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv) : *out_flags & PAD_FAKELEX_ANON) { - if (warn && ckWARN(WARN_CLOSURE)) - Perl_warner(aTHX_ packWARN(WARN_CLOSURE), - "Variable \"%s\" is not available", name); + if (warn) + Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE), + "Variable \"%s\" is not available", name); *out_capture = NULL; } @@ -819,17 +862,16 @@ S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn, if (SvPADSTALE(*out_capture) && !SvPAD_STATE(name_svp[offset])) { - if (ckWARN(WARN_CLOSURE)) - Perl_warner(aTHX_ packWARN(WARN_CLOSURE), - "Variable \"%s\" is not available", name); + Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE), + "Variable \"%s\" is not available", name); *out_capture = NULL; } } if (!*out_capture) { if (*name == '@') - *out_capture = sv_2mortal((SV*)newAV()); + *out_capture = sv_2mortal(MUTABLE_SV(newAV())); else if (*name == '%') - *out_capture = sv_2mortal((SV*)newHV()); + *out_capture = sv_2mortal(MUTABLE_SV(newHV())); else *out_capture = sv_newmortal(); } @@ -871,11 +913,12 @@ S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn, new_offset = pad_add_name( SvPVX_const(*out_name_sv), + SvCUR(*out_name_sv), + /* state variable ? */ + pad_add_FAKE | (SvPAD_STATE(*out_name_sv) ? pad_add_STATE : 0), SvPAD_TYPED(*out_name_sv) ? SvSTASH(*out_name_sv) : NULL, - SvOURSTASH(*out_name_sv), - 1, /* fake */ - SvPAD_STATE(*out_name_sv) ? 1 : 0 /* state variable ? */ + SvOURSTASH(*out_name_sv) ); new_namesv = AvARRAY(PL_comppad_name)[new_offset]; @@ -1062,11 +1105,10 @@ Perl_pad_leavemy(pTHX) if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) { for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) { const SV * const sv = svp[off]; - if (sv && sv != &PL_sv_undef - && !SvFAKE(sv) && ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ packWARN(WARN_INTERNAL), - "%"SVf" never introduced", - SVfARG(sv)); + if (sv && sv != &PL_sv_undef && !SvFAKE(sv)) + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), + "%"SVf" never introduced", + SVfARG(sv)); } } /* "Deintroduce" my variables that are leaving with this scope. */ @@ -1146,8 +1188,8 @@ Mark all the current temporaries for reuse * to a shared TARG. Such an alias will change randomly and unpredictably. * We avoid doing this until we can think of a Better Way. * GSAR 97-10-29 */ -void -Perl_pad_reset(pTHX) +static void +S_pad_reset(pTHX) { dVAR; #ifdef USE_BROKEN_PAD_RESET @@ -1250,7 +1292,7 @@ Perl_pad_tidy(pTHX_ padtidy_type type) /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */ AV * const av = newAV(); /* Will be @_ */ av_extend(av, 0); - av_store(PL_comppad, 0, (SV*)av); + av_store(PL_comppad, 0, MUTABLE_SV(av)); AvREIFY_only(av); } @@ -1306,13 +1348,7 @@ Perl_pad_free(pTHX_ PADOFFSET po) SvPADTMP_off(PL_curpad[po]); #ifdef USE_ITHREADS /* SV could be a shared hash key (eg bugid #19022) */ - if ( -#ifdef PERL_OLD_COPY_ON_WRITE - !SvIsCOW(PL_curpad[po]) -#else - !SvFAKE(PL_curpad[po]) -#endif - ) + if (!SvIsCOW(PL_curpad[po])) SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */ #endif } @@ -1506,7 +1542,7 @@ Perl_cv_clone(pTHX_ CV *proto) CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto); if (SvPOK(proto)) - sv_setpvn((SV*)cv, SvPVX_const(proto), SvCUR(proto)); + sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto)); CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE); @@ -1529,9 +1565,8 @@ Perl_cv_clone(pTHX_ CV *proto) while my $x if $false can leave an active var marked as stale. And state vars are always available */ if (SvPADSTALE(sv) && !SvPAD_STATE(namesv)) { - if (ckWARN(WARN_CLOSURE)) - Perl_warner(aTHX_ packWARN(WARN_CLOSURE), - "Variable \"%s\" is not available", SvPVX_const(namesv)); + Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE), + "Variable \"%s\" is not available", SvPVX_const(namesv)); sv = NULL; } else @@ -1542,9 +1577,9 @@ Perl_cv_clone(pTHX_ CV *proto) if (sigil == '&') sv = SvREFCNT_inc(ppad[ix]); else if (sigil == '@') - sv = (SV*)newAV(); + sv = MUTABLE_SV(newAV()); else if (sigil == '%') - sv = (SV*)newHV(); + sv = MUTABLE_SV(newHV()); else sv = newSV(0); SvPADMY_on(sv); @@ -1668,9 +1703,9 @@ Perl_pad_push(pTHX_ PADLIST *padlist, int depth) else { /* our own lexical */ SV *sv; if (sigil == '@') - sv = (SV*)newAV(); + sv = MUTABLE_SV(newAV()); else if (sigil == '%') - sv = (SV*)newHV(); + sv = MUTABLE_SV(newHV()); else sv = newSV(0); av_store(newpad, ix, sv); @@ -1689,10 +1724,10 @@ Perl_pad_push(pTHX_ PADLIST *padlist, int depth) } av = newAV(); av_extend(av, 0); - av_store(newpad, 0, (SV*)av); + av_store(newpad, 0, MUTABLE_SV(av)); AvREIFY_only(av); - av_store(padlist, depth, (SV*)newpad); + av_store(padlist, depth, MUTABLE_SV(newpad)); AvFILLp(padlist) = depth; } }