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
*/
SAVEI32(PL_max_intro_pending);
SAVEBOOL(PL_cv_has_eval);
if (flags & padnew_SAVESUB) {
- SAVEI32(PL_pad_reset_pending);
+ SAVEBOOL(PL_pad_reset_pending);
}
}
}
+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, 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) {
- 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, MUTABLE_SV(newAV()));
- else if (*name == '%')
- 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",
- (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 */
+ /* XXX DAPM since slot has been allocated, replace
+ * av_store with PL_curpad[offset] ? */
+ if (*name == '@')
+ av_store(PL_comppad, offset, MUTABLE_SV(newAV()));
+ else if (*name == '%')
+ 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",
+ (long)offset, name, PTR2UV(PL_curpad[offset])));
return offset;
}
=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;
&& !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");
*/
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)
? 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;
}
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;
}
}
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, independant 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 = 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
+static void
S_pad_reset(pTHX)
{
dVAR;
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
}
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
projects / p5sagit/p5-mst-13.2.git / blobdiff