*
* 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
Note that formats are treated as anon subs, and are cloned each time
write is called (if necessary).
-The flag SVf_PADSTALE is cleared on lexicals each time the my() is executed,
+The flag SVs_PADSTALE is cleared on lexicals each time the my() is executed,
and set on scope exit. This allows the 'Variable $x is not available' warning
to be generated in evals, such as
{ my $x = 1; sub f { eval '$x'} } f();
-For state vars, SVf_PADSTALE is overloaded to mean 'not yet initialised'
+For state vars, SVs_PADSTALE is overloaded to mean 'not yet initialised'
=cut
*/
#define PARENT_FAKELEX_FLAGS_set(sv,val) \
STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
-#define PAD_MAX I32_MAX
+#define PAD_MAX U32_MAX
#ifdef PERL_MAD
void pad_peg(const char* s) {
- static int pegcnt;
+ static int pegcnt; /* XXX not threadsafe */
+ PERL_UNUSED_ARG(s);
PERL_ARGS_ASSERT_PAD_PEG;
{
dVAR;
AV *padlist, *padname, *pad;
+ SV **ary;
ASSERT_CURPAD_LEGAL("pad_new");
SAVEI32(PL_max_intro_pending);
SAVEBOOL(PL_cv_has_eval);
if (flags & padnew_SAVESUB) {
- SAVEI32(PL_pad_reset_pending);
+ SAVEBOOL(PL_pad_reset_pending);
}
}
}
*/
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 {
}
AvREAL_off(padlist);
- av_store(padlist, 0, (SV*)padname);
- av_store(padlist, 1, (SV*)pad);
+ /* Most subroutines never recurse, hence only need 2 entries in the padlist
+ array - names, and depth=1. The default for av_store() is to allocate
+ 0..3, and even an explicit call to av_extend() with <3 will be rounded
+ up, so we inline the allocation of the array here. */
+ Newx(ary, 2, SV*);
+ AvFILLp(padlist) = 1;
+ AvMAX(padlist) = 1;
+ AvALLOC(padlist) = ary;
+ AvARRAY(padlist) = ary;
+ ary[0] = MUTABLE_SV(padname);
+ ary[1] = MUTABLE_SV(pad);
/* ... then update state variables */
- PL_comppad_name = (AV*)(*av_fetch(padlist, 0, FALSE));
- PL_comppad = (AV*)(*av_fetch(padlist, 1, FALSE));
- PL_curpad = AvARRAY(PL_comppad);
+ PL_comppad_name = padname;
+ PL_comppad = pad;
+ PL_curpad = AvARRAY(pad);
if (! (flags & padnew_CLONE)) {
PL_comppad_name_fill = 0;
return (PADLIST*)padlist;
}
+
/*
-=for apidoc pad_undef
+=head1 Embedding Functions
-Free the padlist associated with a CV.
-If parts of it happen to be current, we null the relevant
-PL_*pad* global vars so that we don't have any dangling references left.
-We also repoint the CvOUTSIDE of any about-to-be-orphaned
-inner subs to the outer of this cv.
+=for apidoc cv_undef
-(This function should really be called pad_free, but the name was already
-taken)
+Clear out all the active components of a CV. This can happen either
+by an explicit C<undef &foo>, or by the reference count going to zero.
+In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
+children can still follow the full lexical scope chain.
=cut
*/
void
-Perl_pad_undef(pTHX_ CV* cv)
+Perl_cv_undef(pTHX_ CV *cv)
{
dVAR;
- I32 ix;
- const PADLIST * const padlist = CvPADLIST(cv);
+ const PADLIST *padlist = CvPADLIST(cv);
- PERL_ARGS_ASSERT_PAD_UNDEF;
-
- pad_peg("pad_undef");
- if (!padlist)
- return;
- if (SvIS_FREED(padlist)) /* may be during global destruction */
- return;
+ PERL_ARGS_ASSERT_CV_UNDEF;
DEBUG_X(PerlIO_printf(Perl_debug_log,
- "Pad undef: cv=0x%"UVxf" padlist=0x%"UVxf" comppad=0x%"UVxf"\n",
- PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad))
+ "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
+ PTR2UV(cv), PTR2UV(PL_comppad))
);
- /* detach any '&' anon children in the pad; if afterwards they
- * are still live, fix up their CvOUTSIDEs to point to our outside,
- * bypassing us. */
- /* XXX DAPM for efficiency, we should only do this if we know we have
- * children, or integrate this loop with general cleanup */
-
- if (!PL_dirty) { /* don't bother during global destruction */
- CV * const outercv = CvOUTSIDE(cv);
- const U32 seq = CvOUTSIDE_SEQ(cv);
- AV * const comppad_name = (AV*)AvARRAY(padlist)[0];
- SV ** const namepad = AvARRAY(comppad_name);
- AV * const comppad = (AV*)AvARRAY(padlist)[1];
- SV ** const curpad = AvARRAY(comppad);
- for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
- SV * const namesv = namepad[ix];
- if (namesv && namesv != &PL_sv_undef
- && *SvPVX_const(namesv) == '&')
- {
- CV * const innercv = (CV*)curpad[ix];
- U32 inner_rc = SvREFCNT(innercv);
- assert(inner_rc);
- namepad[ix] = NULL;
- SvREFCNT_dec(namesv);
-
- if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */
- curpad[ix] = NULL;
- SvREFCNT_dec(innercv);
- inner_rc--;
- }
+#ifdef USE_ITHREADS
+ if (CvFILE(cv) && !CvISXSUB(cv)) {
+ /* for XSUBs CvFILE point directly to static memory; __FILE__ */
+ Safefree(CvFILE(cv));
+ }
+ CvFILE(cv) = NULL;
+#endif
- /* in use, not just a prototype */
- if (inner_rc && (CvOUTSIDE(innercv) == cv)) {
- assert(CvWEAKOUTSIDE(innercv));
- /* don't relink to grandfather if he's being freed */
- if (outercv && SvREFCNT(outercv)) {
- CvWEAKOUTSIDE_off(innercv);
- CvOUTSIDE(innercv) = outercv;
- CvOUTSIDE_SEQ(innercv) = seq;
- SvREFCNT_inc_simple_void_NN(outercv);
- }
- else {
- CvOUTSIDE(innercv) = NULL;
+ if (!CvISXSUB(cv) && CvROOT(cv)) {
+ if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
+ Perl_croak(aTHX_ "Can't undef active subroutine");
+ ENTER;
+
+ PAD_SAVE_SETNULLPAD();
+
+ op_free(CvROOT(cv));
+ CvROOT(cv) = NULL;
+ CvSTART(cv) = NULL;
+ LEAVE;
+ }
+ SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
+ CvGV_set(cv, NULL);
+
+ /* This statement and the subsequence if block was pad_undef(). */
+ pad_peg("pad_undef");
+
+ if (padlist && !SvIS_FREED(padlist) /* may be during global destruction */
+ ) {
+ I32 ix;
+
+ /* Free the padlist associated with a CV.
+ If parts of it happen to be current, we null the relevant PL_*pad*
+ global vars so that we don't have any dangling references left.
+ We also repoint the CvOUTSIDE of any about-to-be-orphaned inner
+ subs to the outer of this cv. */
+
+ DEBUG_X(PerlIO_printf(Perl_debug_log,
+ "Pad undef: cv=0x%"UVxf" padlist=0x%"UVxf" comppad=0x%"UVxf"\n",
+ PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad))
+ );
+
+ /* detach any '&' anon children in the pad; if afterwards they
+ * are still live, fix up their CvOUTSIDEs to point to our outside,
+ * bypassing us. */
+ /* XXX DAPM for efficiency, we should only do this if we know we have
+ * children, or integrate this loop with general cleanup */
+
+ if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */
+ CV * const outercv = CvOUTSIDE(cv);
+ const U32 seq = CvOUTSIDE_SEQ(cv);
+ AV * const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
+ SV ** const namepad = AvARRAY(comppad_name);
+ AV * const comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
+ SV ** const curpad = AvARRAY(comppad);
+ for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
+ SV * const namesv = namepad[ix];
+ if (namesv && namesv != &PL_sv_undef
+ && *SvPVX_const(namesv) == '&')
+ {
+ CV * const innercv = MUTABLE_CV(curpad[ix]);
+ U32 inner_rc = SvREFCNT(innercv);
+ assert(inner_rc);
+ namepad[ix] = NULL;
+ SvREFCNT_dec(namesv);
+
+ if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */
+ curpad[ix] = NULL;
+ SvREFCNT_dec(innercv);
+ inner_rc--;
+ }
+
+ /* in use, not just a prototype */
+ if (inner_rc && (CvOUTSIDE(innercv) == cv)) {
+ assert(CvWEAKOUTSIDE(innercv));
+ /* don't relink to grandfather if he's being freed */
+ if (outercv && SvREFCNT(outercv)) {
+ CvWEAKOUTSIDE_off(innercv);
+ CvOUTSIDE(innercv) = outercv;
+ CvOUTSIDE_SEQ(innercv) = seq;
+ SvREFCNT_inc_simple_void_NN(outercv);
+ }
+ else {
+ CvOUTSIDE(innercv) = NULL;
+ }
+ }
}
- }
}
}
- }
- ix = AvFILLp(padlist);
- while (ix >= 0) {
- SV* const sv = AvARRAY(padlist)[ix--];
- if (sv) {
- if (sv == (SV*)PL_comppad_name)
- PL_comppad_name = NULL;
- else if (sv == (SV*)PL_comppad) {
- PL_comppad = NULL;
- PL_curpad = NULL;
+ ix = AvFILLp(padlist);
+ while (ix > 0) {
+ SV* const sv = AvARRAY(padlist)[ix--];
+ if (sv) {
+ if (sv == (const SV *)PL_comppad) {
+ PL_comppad = NULL;
+ PL_curpad = NULL;
+ }
+ SvREFCNT_dec(sv);
}
}
- SvREFCNT_dec(sv);
+ {
+ SV *const sv = AvARRAY(padlist)[0];
+ if (sv == (const SV *)PL_comppad_name)
+ PL_comppad_name = NULL;
+ SvREFCNT_dec(sv);
+ }
+ SvREFCNT_dec(MUTABLE_SV(CvPADLIST(cv)));
+ CvPADLIST(cv) = NULL;
+ }
+
+
+ /* remove CvOUTSIDE unless this is an undef rather than a free */
+ if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
+ if (!CvWEAKOUTSIDE(cv))
+ SvREFCNT_dec(CvOUTSIDE(cv));
+ CvOUTSIDE(cv) = NULL;
}
- SvREFCNT_dec((SV*)CvPADLIST(cv));
- CvPADLIST(cv) = NULL;
+ if (CvCONST(cv)) {
+ SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
+ CvCONST_off(cv);
+ }
+ if (CvISXSUB(cv) && CvXSUB(cv)) {
+ CvXSUB(cv) = NULL;
+ }
+ /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
+ * ref status of CvOUTSIDE and CvGV */
+ CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC);
}
+static PADOFFSET
+S_pad_add_name_sv(pTHX_ SV *namesv, const U32 flags, HV *typestash,
+ HV *ourstash)
+{
+ dVAR;
+ const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
+
+ PERL_ARGS_ASSERT_PAD_ADD_NAME_SV;
+
+ ASSERT_CURPAD_ACTIVE("pad_add_name");
+ if (typestash) {
+ assert(SvTYPE(namesv) == SVt_PVMG);
+ SvPAD_TYPED_on(namesv);
+ 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 (flags & padadd_STATE) {
+ SvPAD_STATE_on(namesv);
+ }
+ av_store(PL_comppad_name, offset, namesv);
+ return offset;
+}
/*
=for apidoc pad_add_name
*/
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);
+ PADOFFSET offset;
+ SV *namesv;
PERL_ARGS_ASSERT_PAD_ADD_NAME;
- ASSERT_CURPAD_ACTIVE("pad_add_name");
+ if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK))
+ 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, (HV*)SvREFCNT_inc_simple_NN((SV*)typestash));
- }
- if (ourstash) {
- SvPAD_OUR_on(namesv);
- SvOURSTASH_set(namesv, ourstash);
- SvREFCNT_inc_simple_void_NN(ourstash);
- }
- else if (state) {
- SvPAD_STATE_on(namesv);
+ if ((flags & padadd_NO_DUP_CHECK) == 0) {
+ /* check for duplicate declaration */
+ pad_check_dup(namesv, flags & padadd_OUR, ourstash);
}
- av_store(PL_comppad_name, offset, namesv);
- if (fake) {
- SvFAKE_on(namesv);
- DEBUG_Xv(PerlIO_printf(Perl_debug_log,
- "Pad addname: %ld \"%s\" FAKE\n", (long)offset, name));
- }
- else {
- /* not yet introduced */
- COP_SEQ_RANGE_LOW_set(namesv, PAD_MAX); /* min */
- COP_SEQ_RANGE_HIGH_set(namesv, 0); /* max */
-
- if (!PL_min_intro_pending)
- PL_min_intro_pending = offset;
- PL_max_intro_pending = offset;
- /* if it's not a simple scalar, replace with an AV or HV */
- /* XXX DAPM since slot has been allocated, replace
- * av_store with PL_curpad[offset] ? */
- if (*name == '@')
- av_store(PL_comppad, offset, (SV*)newAV());
- else if (*name == '%')
- av_store(PL_comppad, offset, (SV*)newHV());
- SvPADMY_on(PL_curpad[offset]);
- DEBUG_Xv(PerlIO_printf(Perl_debug_log,
- "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
- (long)offset, name, PTR2UV(PL_curpad[offset])));
- }
+ offset = pad_add_name_sv(namesv, flags, typestash, ourstash);
+
+ /* not yet introduced */
+ COP_SEQ_RANGE_LOW_set(namesv, PAD_MAX); /* min */
+ COP_SEQ_RANGE_HIGH_set(namesv, 0); /* max */
+
+ if (!PL_min_intro_pending)
+ PL_min_intro_pending = offset;
+ PL_max_intro_pending = offset;
+ /* if it's not a simple scalar, replace with an AV or HV */
+ assert(SvTYPE(PL_curpad[offset]) == SVt_NULL);
+ assert(SvREFCNT(PL_curpad[offset]) == 1);
+ if (*name == '@')
+ sv_upgrade(PL_curpad[offset], SVt_PVAV);
+ else if (*name == '%')
+ sv_upgrade(PL_curpad[offset], SVt_PVHV);
+ assert(SvPADMY(PL_curpad[offset]));
+ DEBUG_Xv(PerlIO_printf(Perl_debug_log,
+ "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
+ (long)offset, name, PTR2UV(PL_curpad[offset])));
return offset;
}
PERL_ARGS_ASSERT_PAD_ADD_ANON;
pad_peg("add_anon");
- sv_setpvn(name, "&", 1);
+ sv_setpvs(name, "&");
/* Are these two actually ever read? */
- COP_SEQ_RANGE_HIGH_set(name, ~0);
+ COP_SEQ_RANGE_HIGH_set(name, PAD_MAX);
COP_SEQ_RANGE_LOW_set(name, 1);
ix = pad_alloc(op_type, SVs_PADMY);
av_store(PL_comppad_name, ix, name);
/* to avoid ref loops, we never have parent + child referencing each
* other simultaneously */
- if (CvOUTSIDE((CV*)sv)) {
- assert(!CvWEAKOUTSIDE((CV*)sv));
- CvWEAKOUTSIDE_on((CV*)sv);
- SvREFCNT_dec(CvOUTSIDE((CV*)sv));
+ if (CvOUTSIDE((const CV *)sv)) {
+ assert(!CvWEAKOUTSIDE((const CV *)sv));
+ CvWEAKOUTSIDE_on(MUTABLE_CV(sv));
+ SvREFCNT_dec(CvOUTSIDE(MUTABLE_CV(sv)));
}
return ix;
}
=cut
*/
-/* XXX DAPM integrate this into pad_add_name ??? */
-
-void
-Perl_pad_check_dup(pTHX_ const char *name, bool is_our, const HV *ourstash)
+STATIC void
+S_pad_check_dup(pTHX_ SV *name, const U32 flags, const HV *ourstash)
{
dVAR;
SV **svp;
PADOFFSET top, off;
+ const U32 is_our = flags & padadd_OUR;
PERL_ARGS_ASSERT_PAD_CHECK_DUP;
ASSERT_CURPAD_ACTIVE("pad_check_dup");
+
+ assert((flags & ~padadd_OUR) == 0);
+
if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC))
return; /* nothing to check */
&& sv != &PL_sv_undef
&& !SvFAKE(sv)
&& (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX || COP_SEQ_RANGE_HIGH(sv) == 0)
- && strEQ(name, SvPVX_const(sv)))
+ && sv_eq(name, sv))
{
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;
}
/* check the rest of the pad */
if (is_our) {
- do {
+ while (off > 0) {
SV * const sv = svp[off];
if (sv
&& sv != &PL_sv_undef
&& !SvFAKE(sv)
&& (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX || COP_SEQ_RANGE_HIGH(sv) == 0)
&& SvOURSTASH(sv) == ourstash
- && strEQ(name, SvPVX_const(sv)))
+ && sv_eq(name, 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");
break;
}
- } while ( off-- > 0 );
+ --off;
+ }
}
}
*/
PADOFFSET
-Perl_pad_findmy(pTHX_ const char *name)
+Perl_pad_findmy(pTHX_ const char *name, STRLEN len, U32 flags)
{
dVAR;
SV *out_sv;
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)
* our $foo = 0 unless defined $foo;
* to not give a warning. (Yes, this is a hack) */
- nameav = (AV*)AvARRAY(CvPADLIST(PL_compcv))[0];
+ nameav = MUTABLE_AV(AvARRAY(CvPADLIST(PL_compcv))[0]);
name_svp = AvARRAY(nameav);
for (offset = AvFILLp(nameav); offset > 0; offset--) {
const SV * const namesv = name_svp[offset];
}
/*
+ * Returns a lexical $_, if there is one, at run time ; or the global one
+ * otherwise.
+ */
+
+SV *
+Perl_find_rundefsv(pTHX)
+{
+ SV *namesv;
+ int flags;
+ PADOFFSET po;
+
+ po = pad_findlex("$_", find_runcv(NULL), PL_curcop->cop_seq, 1,
+ NULL, &namesv, &flags);
+
+ if (po == NOT_IN_PAD
+ || (SvFLAGS(namesv) & (SVpad_NAME|SVpad_OUR)) == (SVpad_NAME|SVpad_OUR))
+ return DEFSV;
+
+ return PAD_SVl(po);
+}
+
+/*
=for apidoc pad_findlex
Find a named lexical anywhere in a chain of nested pads. Add fake entries
if (padlist) { /* not an undef CV */
I32 fake_offset = 0;
- const AV * const nameav = (AV*)AvARRAY(padlist)[0];
+ const AV * const nameav = MUTABLE_AV(AvARRAY(padlist)[0]);
SV * const * const name_svp = AvARRAY(nameav);
for (offset = AvFILLp(nameav); offset > 0; offset--) {
* instances. For now, we just test !CvUNIQUE(cv), but
* ideally, we should detect my's declared within loops
* etc - this would allow a wider range of 'not stayed
- * shared' warnings. We also treated alreadly-compiled
+ * shared' warnings. We also treated already-compiled
* lexes as not multi as viewed from evals. */
*out_flags = CvANON(cv) ?
? 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;
}
return offset;
}
- *out_capture = AvARRAY((AV*)AvARRAY(padlist)[
- CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset];
+ *out_capture = AvARRAY(MUTABLE_AV(AvARRAY(padlist)[
+ CvDEPTH(cv) ? CvDEPTH(cv) : 1]))[offset];
DEBUG_Xv(PerlIO_printf(Perl_debug_log,
"Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
PTR2UV(cv), PTR2UV(*out_capture)));
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();
}
return 0; /* this dummy (and invalid) value isnt used by the caller */
{
- SV *new_namesv;
+ /* This relies on sv_setsv_flags() upgrading the destination to the same
+ type as the source, independent of the flags set, and on it being
+ "good" and only copying flag bits and pointers that it understands.
+ */
+ SV *new_namesv = newSVsv(*out_name_sv);
AV * const ocomppad_name = PL_comppad_name;
PAD * const ocomppad = PL_comppad;
- PL_comppad_name = (AV*)AvARRAY(padlist)[0];
- PL_comppad = (AV*)AvARRAY(padlist)[1];
+ PL_comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
+ PL_comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
PL_curpad = AvARRAY(PL_comppad);
- new_offset = pad_add_name(
- SvPVX_const(*out_name_sv),
- 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 ? */
- );
+ new_offset
+ = pad_add_name_sv(new_namesv,
+ (SvPAD_STATE(*out_name_sv) ? padadd_STATE : 0),
+ SvPAD_TYPED(*out_name_sv)
+ ? SvSTASH(*out_name_sv) : NULL,
+ SvOURSTASH(*out_name_sv)
+ );
- new_namesv = AvARRAY(PL_comppad_name)[new_offset];
+ SvFAKE_on(new_namesv);
+ DEBUG_Xv(PerlIO_printf(Perl_debug_log,
+ "Pad addname: %ld \"%.*s\" FAKE\n",
+ (long)new_offset,
+ (int) SvCUR(new_namesv), SvPVX(new_namesv)));
PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags);
PARENT_PAD_INDEX_set(new_namesv, 0);
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. */
* 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
* so that for example the eval's CV in C<< sub { eval '$x' } >> gets
* the right CvOUTSIDE.
* If running with -d, *any* sub may potentially have an eval
- * excuted within it.
+ * executed within it.
*/
if (PL_cv_has_eval || PL_perldb) {
else if (type == padtidy_SUB) {
/* 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);
}
- /* XXX DAPM rationalise these two similar branches */
-
- if (type == padtidy_SUB) {
+ if (type == padtidy_SUB || type == padtidy_FORMAT) {
+ SV * const * const namep = AvARRAY(PL_comppad_name);
PADOFFSET ix;
for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
continue;
- if (!SvPADMY(PL_curpad[ix]))
- SvPADTMP_on(PL_curpad[ix]);
- }
- }
- else if (type == padtidy_FORMAT) {
- PADOFFSET ix;
- for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
- if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
+ if (!SvPADMY(PL_curpad[ix])) {
SvPADTMP_on(PL_curpad[ix]);
+ } else if (!SvFAKE(namep[ix])) {
+ /* This is a work around for how the current implementation of
+ ?{ } blocks in regexps interacts with lexicals.
+
+ One of our lexicals.
+ Can't do this on all lexicals, otherwise sub baz() won't
+ compile in
+
+ my $foo;
+
+ sub bar { ++$foo; }
+
+ sub baz { ++$foo; }
+
+ because completion of compiling &bar calling pad_tidy()
+ would cause (top level) $foo to be marked as stale, and
+ "no longer available". */
+ SvPADSTALE_on(PL_curpad[ix]);
+ }
}
}
PL_curpad = AvARRAY(PL_comppad);
if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
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
- )
- SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
-#endif
}
if ((I32)po < PL_padix)
PL_padix = po - 1;
if (!padlist) {
return;
}
- pad_name = (AV*)*av_fetch((AV*)padlist, 0, FALSE);
- pad = (AV*)*av_fetch((AV*)padlist, 1, FALSE);
+ pad_name = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 0, FALSE));
+ pad = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 1, FALSE));
pname = AvARRAY(pad_name);
ppad = AvARRAY(pad);
Perl_dump_indent(aTHX_ level, file,
dVAR;
I32 ix;
AV* const protopadlist = CvPADLIST(proto);
- const AV* const protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
- const AV* const protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
+ const AV *const protopad_name = (const AV *)*av_fetch(protopadlist, 0, FALSE);
+ const AV *const protopad = (const AV *)*av_fetch(protopadlist, 1, FALSE);
SV** const pname = AvARRAY(protopad_name);
SV** const ppad = AvARRAY(protopad);
const I32 fname = AvFILLp(protopad_name);
ENTER;
SAVESPTR(PL_compcv);
- cv = PL_compcv = (CV*)newSV_type(SvTYPE(proto));
- CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE);
+ cv = PL_compcv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
+ CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC);
CvCLONED_on(cv);
#ifdef USE_ITHREADS
#else
CvFILE(cv) = CvFILE(proto);
#endif
- CvGV(cv) = CvGV(proto);
- CvSTASH(cv) = CvSTASH(proto);
+ CvGV_set(cv,CvGV(proto));
+ CvSTASH_set(cv, CvSTASH(proto));
OP_REFCNT_LOCK;
CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
OP_REFCNT_UNLOCK;
CvSTART(cv) = CvSTART(proto);
- CvOUTSIDE(cv) = (CV*)SvREFCNT_inc_simple(outside);
+ CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
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);
av_fill(PL_comppad, fpad);
- for (ix = fname; ix >= 0; ix--)
+ for (ix = fname; ix > 0; ix--)
av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
PL_curpad = AvARRAY(PL_comppad);
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
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);
{
dVAR;
I32 ix;
- AV * const comppad_name = (AV*)AvARRAY(padlist)[0];
- AV * const comppad = (AV*)AvARRAY(padlist)[1];
+ AV * const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
+ AV * const comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
SV ** const namepad = AvARRAY(comppad_name);
SV ** const curpad = AvARRAY(comppad);
if (namesv && namesv != &PL_sv_undef
&& *SvPVX_const(namesv) == '&')
{
- CV * const innercv = (CV*)curpad[ix];
+ CV * const innercv = MUTABLE_CV(curpad[ix]);
assert(CvWEAKOUTSIDE(innercv));
assert(CvOUTSIDE(innercv) == old_cv);
CvOUTSIDE(innercv) = new_cv;
SV** const svp = AvARRAY(padlist);
AV* const newpad = newAV();
SV** const oldpad = AvARRAY(svp[depth-1]);
- I32 ix = AvFILLp((AV*)svp[1]);
- const I32 names_fill = AvFILLp((AV*)svp[0]);
+ I32 ix = AvFILLp((const AV *)svp[1]);
+ const I32 names_fill = AvFILLp((const AV *)svp[0]);
SV** const names = AvARRAY(svp[0]);
AV *av;
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);
}
}
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;
}
}
return NULL;
}
+#if defined(USE_ITHREADS)
+
+# define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
+
+AV *
+Perl_padlist_dup(pTHX_ AV *const srcpad, CLONE_PARAMS *const param)
+{
+ AV *dstpad;
+ PERL_ARGS_ASSERT_PADLIST_DUP;
+
+ if (!srcpad)
+ return NULL;
+
+ assert(!AvREAL(srcpad));
+
+ if (param->flags & CLONEf_COPY_STACKS
+ || SvREFCNT(AvARRAY(srcpad)[1]) > 1) {
+ /* XXX padlists are real, but pretend to be not */
+ AvREAL_on(srcpad);
+ dstpad = av_dup_inc(srcpad, param);
+ AvREAL_off(srcpad);
+ AvREAL_off(dstpad);
+ assert (SvREFCNT(AvARRAY(srcpad)[1]) == 1);
+ } else {
+ /* CvDEPTH() on our subroutine will be set to 0, so there's no need
+ to build anything other than the first level of pads. */
+
+ I32 ix = AvFILLp((const AV *)AvARRAY(srcpad)[1]);
+ AV *pad1;
+ const I32 names_fill = AvFILLp((const AV *)(AvARRAY(srcpad)[0]));
+ const AV *const srcpad1 = (const AV *) AvARRAY(srcpad)[1];
+ SV **oldpad = AvARRAY(srcpad1);
+ SV **names;
+ SV **pad1a;
+ AV *args;
+ /* look for it in the table first.
+ I *think* that it shouldn't be possible to find it there.
+ Well, except for how Perl_sv_compile_2op() "works" :-( */
+ dstpad = (AV*)ptr_table_fetch(PL_ptr_table, srcpad);
+
+ if (dstpad)
+ return dstpad;
+
+ dstpad = newAV();
+ ptr_table_store(PL_ptr_table, srcpad, dstpad);
+ AvREAL_off(dstpad);
+ av_extend(dstpad, 1);
+ AvARRAY(dstpad)[0] = MUTABLE_SV(av_dup_inc(AvARRAY(srcpad)[0], param));
+ names = AvARRAY(AvARRAY(dstpad)[0]);
+
+ pad1 = newAV();
+
+ av_extend(pad1, ix);
+ AvARRAY(dstpad)[1] = MUTABLE_SV(pad1);
+ pad1a = AvARRAY(pad1);
+ AvFILLp(dstpad) = 1;
+
+ if (ix > -1) {
+ AvFILLp(pad1) = ix;
+
+ for ( ;ix > 0; ix--) {
+ if (!oldpad[ix]) {
+ pad1a[ix] = NULL;
+ } else if (names_fill >= ix && names[ix] != &PL_sv_undef) {
+ const char sigil = SvPVX_const(names[ix])[0];
+ if ((SvFLAGS(names[ix]) & SVf_FAKE)
+ || (SvFLAGS(names[ix]) & SVpad_STATE)
+ || sigil == '&')
+ {
+ /* outer lexical or anon code */
+ pad1a[ix] = sv_dup_inc(oldpad[ix], param);
+ }
+ else { /* our own lexical */
+ if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
+ /* This is a work around for how the current
+ implementation of ?{ } blocks in regexps
+ interacts with lexicals. */
+ pad1a[ix] = sv_dup_inc(oldpad[ix], param);
+ } else {
+ SV *sv;
+
+ if (sigil == '@')
+ sv = MUTABLE_SV(newAV());
+ else if (sigil == '%')
+ sv = MUTABLE_SV(newHV());
+ else
+ sv = newSV(0);
+ pad1a[ix] = sv;
+ SvPADMY_on(sv);
+ }
+ }
+ }
+ else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
+ pad1a[ix] = sv_dup_inc(oldpad[ix], param);
+ }
+ else {
+ /* save temporaries on recursion? */
+ SV * const sv = newSV(0);
+ pad1a[ix] = sv;
+
+ /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
+ FIXTHAT before merging this branch.
+ (And I know how to) */
+ if (SvPADMY(oldpad[ix]))
+ SvPADMY_on(sv);
+ else
+ SvPADTMP_on(sv);
+ }
+ }
+
+ if (oldpad[0]) {
+ args = newAV(); /* Will be @_ */
+ AvREIFY_only(args);
+ pad1a[0] = (SV *)args;
+ }
+ }
+ }
+
+ return dstpad;
+}
+
+#endif
+
/*
* Local variables:
* c-indentation-style: bsd
https://perl5.git.perl.org / perl5.git / blobdiff