Do not try to load a feature bundle when doing "no VERSION"

[perl5.git] / pad.c

diff --git a/pad.c b/pad.c
index c4b8e5e..f941252 100644 (file)
--- a/pad.c
+++ b/pad.c
@@ -1,16 +1,21 @@
 /*    pad.c
  *
 /*    pad.c
  *

- *    Copyright (C) 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
+ *    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
+ *    by Larry Wall and others

  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
  *
  *    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
  */
 
 /* XXX DAPM


@@ -96,12 +101,14 @@ become so if C<my sub foo {}> is implemented.)
 Note that formats are treated as anon subs, and are cloned each time
 write is called (if necessary).
 
 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();
 
 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, SVs_PADSTALE is overloaded to mean 'not yet initialised'
+

 =cut
 */
 
 =cut
 */
 


@@ -126,6 +133,9 @@ to be generated in evals, such as
 #ifdef PERL_MAD
 void pad_peg(const char* s) {
     static int pegcnt;
 #ifdef PERL_MAD
 void pad_peg(const char* s) {
     static int pegcnt;

+
+    PERL_ARGS_ASSERT_PAD_PEG;
+

     pegcnt++;
 }
 #endif
     pegcnt++;
 }
 #endif


@@ -168,9 +178,9 @@ Perl_pad_new(pTHX_ int flags)
            SAVEI32(PL_comppad_name_fill);
            SAVEI32(PL_min_intro_pending);
            SAVEI32(PL_max_intro_pending);
            SAVEI32(PL_comppad_name_fill);
            SAVEI32(PL_min_intro_pending);
            SAVEI32(PL_max_intro_pending);

-           SAVEI32(PL_cv_has_eval);
+           SAVEBOOL(PL_cv_has_eval);

            if (flags & padnew_SAVESUB) {
            if (flags & padnew_SAVESUB) {

-               SAVEI32(PL_pad_reset_pending);
+               SAVEBOOL(PL_pad_reset_pending);

            }
        }
     }
            }
        }
     }


@@ -191,7 +201,7 @@ Perl_pad_new(pTHX_ int flags)
 
         AV * const a0 = newAV();                       /* will be @_ */
        av_extend(a0, 0);
 
         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 {
        AvREIFY_only(a0);
     }
     else {


@@ -199,13 +209,13 @@ Perl_pad_new(pTHX_ int flags)
     }
 
     AvREAL_off(padlist);
     }
 
     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 */
 
 
     /* ... then update state variables */
 

-    PL_comppad_name    = (AV*)(*av_fetch(padlist, 0, FALSE));
-    PL_comppad         = (AV*)(*av_fetch(padlist, 1, FALSE));
+    PL_comppad_name    = MUTABLE_AV((*av_fetch(padlist, 0, FALSE)));
+    PL_comppad         = MUTABLE_AV((*av_fetch(padlist, 1, FALSE)));

     PL_curpad          = AvARRAY(PL_comppad);
 
     if (! (flags & padnew_CLONE)) {
     PL_curpad          = AvARRAY(PL_comppad);
 
     if (! (flags & padnew_CLONE)) {


@@ -248,6 +258,8 @@ Perl_pad_undef(pTHX_ CV* cv)
     I32 ix;
     const PADLIST * const padlist = CvPADLIST(cv);
 
     I32 ix;
     const PADLIST * const padlist = CvPADLIST(cv);
 

+    PERL_ARGS_ASSERT_PAD_UNDEF;
+

     pad_peg("pad_undef");
     if (!padlist)
        return;
     pad_peg("pad_undef");
     if (!padlist)
        return;


@@ -255,8 +267,8 @@ Perl_pad_undef(pTHX_ CV* cv)
        return;
 
     DEBUG_X(PerlIO_printf(Perl_debug_log,
        return;
 
     DEBUG_X(PerlIO_printf(Perl_debug_log,

-         "Pad undef: cv=0x%"UVxf" padlist=0x%"UVxf"\n",
-           PTR2UV(cv), PTR2UV(padlist))
+         "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
     );
 
     /* detach any '&' anon children in the pad; if afterwards they


@@ -268,16 +280,16 @@ Perl_pad_undef(pTHX_ CV* cv)
     if (!PL_dirty) { /* don't bother during global destruction */
        CV * const outercv = CvOUTSIDE(cv);
         const U32 seq = CvOUTSIDE_SEQ(cv);
     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];
+       AV *  const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);

        SV ** const namepad = AvARRAY(comppad_name);
        SV ** const namepad = AvARRAY(comppad_name);

-       AV *  const comppad = (AV*)AvARRAY(padlist)[1];
+       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) == '&')
            {
        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];
+               CV * const innercv = MUTABLE_CV(curpad[ix]);

                U32 inner_rc = SvREFCNT(innercv);
                assert(inner_rc);
                namepad[ix] = NULL;
                U32 inner_rc = SvREFCNT(innercv);
                assert(inner_rc);
                namepad[ix] = NULL;


@@ -309,24 +321,53 @@ Perl_pad_undef(pTHX_ CV* cv)
 
     ix = AvFILLp(padlist);
     while (ix >= 0) {
 
     ix = AvFILLp(padlist);
     while (ix >= 0) {

-       const SV* const sv = AvARRAY(padlist)[ix--];
+       SV* const sv = AvARRAY(padlist)[ix--];

        if (sv) {
        if (sv) {

-           if (sv == (SV*)PL_comppad_name)
+           if (sv == (const SV *)PL_comppad_name)

                PL_comppad_name = NULL;
                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);
     }
                PL_comppad = NULL;
                PL_curpad = NULL;
            }
        }
        SvREFCNT_dec(sv);
     }

-    SvREFCNT_dec((SV*)CvPADLIST(cv));
+    SvREFCNT_dec(MUTABLE_SV(CvPADLIST(cv)));

     CvPADLIST(cv) = NULL;
 }
 
 
 
 
     CvPADLIST(cv) = NULL;
 }
 
 
 
 

+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
 
 /*
 =for apidoc pad_add_name
 


@@ -343,58 +384,53 @@ If fake, it means we're cloning an existing entry
 */
 
 PADOFFSET
 */
 
 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;
 {
     dVAR;

-    const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
-    SV* const namesv = newSV(0);
+    PADOFFSET offset;
+    SV *namesv;

 
 

-    ASSERT_CURPAD_ACTIVE("pad_add_name");
+    PERL_ARGS_ASSERT_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_upgrade(namesv, (ourstash || typestash) ? SVt_PVMG : SVt_PVNV);

     sv_setpv(namesv, name);
 
     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 */
+    /* 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;
 }
 
     return offset;
 }


@@ -485,10 +521,12 @@ Perl_pad_add_anon(pTHX_ SV* sv, OPCODE op_type)
 {
     dVAR;
     PADOFFSET ix;
 {
     dVAR;
     PADOFFSET ix;

-    SV* const name = newSV(0);
+    SV* const name = newSV_type(SVt_PVNV);
+
+    PERL_ARGS_ASSERT_PAD_ADD_ANON;
+

     pad_peg("add_anon");
     pad_peg("add_anon");

-    sv_upgrade(name, SVt_PVNV);
-    sv_setpvn(name, "&", 1);
+    sv_setpvs(name, "&");

     /* Are these two actually ever read? */
     COP_SEQ_RANGE_HIGH_set(name, ~0);
     COP_SEQ_RANGE_LOW_set(name, 1);
     /* Are these two actually ever read? */
     COP_SEQ_RANGE_HIGH_set(name, ~0);
     COP_SEQ_RANGE_LOW_set(name, 1);


@@ -500,10 +538,10 @@ Perl_pad_add_anon(pTHX_ SV* sv, OPCODE op_type)
 
     /* to avoid ref loops, we never have parent + child referencing each
      * other simultaneously */
 
     /* 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;
 }
     }
     return ix;
 }


@@ -522,16 +560,20 @@ C<is_our> indicates that the name to check is an 'our' declaration
 =cut
 */
 
 =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;
 {
     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_CURPAD_ACTIVE("pad_check_dup");

+
+    assert((flags & ~padadd_OUR) == 0);
+

     if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC))
        return; /* nothing to check */
 
     if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC))
        return; /* nothing to check */
 


@@ -546,14 +588,14 @@ Perl_pad_check_dup(pTHX_ const char *name, bool is_our, const HV *ourstash)
            && sv != &PL_sv_undef
            && !SvFAKE(sv)
            && (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX || COP_SEQ_RANGE_HIGH(sv) == 0)
            && 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),
        {
            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",
-               (is_our ? "our" : PL_in_my == KEY_my ? "my" : "state"),
-               name,
+               "\"%s\" variable %"SVf" masks earlier declaration in same %s",
+               (is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"),
+               sv,

                (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX ? "scope" : "statement"));
            --off;
            break;
                (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX ? "scope" : "statement"));
            --off;
            break;


@@ -568,10 +610,10 @@ Perl_pad_check_dup(pTHX_ const char *name, bool is_our, const HV *ourstash)
                && !SvFAKE(sv)
                && (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX || COP_SEQ_RANGE_HIGH(sv) == 0)
                && SvOURSTASH(sv) == ourstash
                && !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),
            {
                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");
                if ((I32)off <= PL_comppad_name_floor)
                    Perl_warner(aTHX_ packWARN(WARN_MISC),
                        "\t(Did you mean \"local\" instead of \"our\"?)\n");


@@ -595,7 +637,7 @@ Returns the offset in the current pad, or NOT_IN_PAD on failure.
 */
 
 PADOFFSET
 */
 
 PADOFFSET

-Perl_pad_findmy(pTHX_ const char *name)
+Perl_pad_findmy(pTHX_ const char *name, STRLEN len, U32 flags)

 {
     dVAR;
     SV *out_sv;
 {
     dVAR;
     SV *out_sv;


@@ -604,7 +646,25 @@ Perl_pad_findmy(pTHX_ const char *name)
     const AV *nameav;
     SV **name_svp;
 
     const AV *nameav;
     SV **name_svp;
 

+    PERL_ARGS_ASSERT_PAD_FINDMY;
+

     pad_peg("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) 
     offset = pad_findlex(name, PL_compcv, PL_cop_seqmax, 1,
                NULL, &out_sv, &out_flags);
     if ((PADOFFSET)offset != NOT_IN_PAD) 


@@ -614,7 +674,7 @@ Perl_pad_findmy(pTHX_ const char *name)
      *    our $foo = 0 unless defined $foo;
      * to not give a warning. (Yes, this is a hack) */
 
      *    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];
     name_svp = AvARRAY(nameav);
     for (offset = AvFILLp(nameav); offset > 0; offset--) {
         const SV * const namesv = name_svp[offset];


@@ -685,6 +745,8 @@ S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn,
     SV **new_capturep;
     const AV * const padlist = CvPADLIST(cv);
 
     SV **new_capturep;
     const AV * const padlist = CvPADLIST(cv);
 

+    PERL_ARGS_ASSERT_PAD_FINDLEX;
+

     *out_flags = 0;
 
     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
     *out_flags = 0;
 
     DEBUG_Xv(PerlIO_printf(Perl_debug_log,


@@ -695,7 +757,7 @@ S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn,
 
     if (padlist) { /* not an undef CV */
        I32 fake_offset = 0;
 
     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--) {
        SV * const * const name_svp = AvARRAY(nameav);
 
        for (offset = AvFILLp(nameav); offset > 0; offset--) {


@@ -760,9 +822,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)
                {
                        ? 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;
                }
 
                    *out_capture = NULL;
                }
 


@@ -770,6 +832,7 @@ S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn,
                else {
                    int newwarn = warn;
                    if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
                else {
                    int newwarn = warn;
                    if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)

+                        && !SvPAD_STATE(name_svp[offset])

                         && warn && ckWARN(WARN_CLOSURE)) {
                        newwarn = 0;
                        Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
                         && warn && ckWARN(WARN_CLOSURE)) {
                        newwarn = 0;
                        Perl_warner(aTHX_ packWARN(WARN_CLOSURE),


@@ -792,24 +855,25 @@ S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn,
                        return offset;
                    }
 
                        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)));
 
                    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)) {
-                       if (ckWARN(WARN_CLOSURE))
-                           Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
-                               "Variable \"%s\" is not available", name);
+                   if (SvPADSTALE(*out_capture)
+                       && !SvPAD_STATE(name_svp[offset]))
+                   {
+                       Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
+                                      "Variable \"%s\" is not available", name);

                        *out_capture = NULL;
                    }
                }
                if (!*out_capture) {
                    if (*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 == '%')
                    else if (*name == '%')

-                       *out_capture = sv_2mortal((SV*)newHV());
+                       *out_capture = sv_2mortal(MUTABLE_SV(newHV()));

                    else
                        *out_capture = sv_newmortal();
                }
                    else
                        *out_capture = sv_newmortal();
                }


@@ -842,23 +906,30 @@ S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn,
        return 0; /* this dummy (and invalid) value isnt used by the caller */
 
     {
        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;
        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);
 
        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 */
-           0   /* not a 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);
        PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags);
 
        PARENT_PAD_INDEX_set(new_namesv, 0);


@@ -928,6 +999,9 @@ void
 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
 {
     dVAR;
 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
 {
     dVAR;

+
+    PERL_ARGS_ASSERT_PAD_SETSV;
+

     ASSERT_CURPAD_ACTIVE("pad_setsv");
 
     DEBUG_X(PerlIO_printf(Perl_debug_log,
     ASSERT_CURPAD_ACTIVE("pad_setsv");
 
     DEBUG_X(PerlIO_printf(Perl_debug_log,


@@ -1039,11 +1113,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 (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",
-                           (void*)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. */
        }
     }
     /* "Deintroduce" my variables that are leaving with this scope. */


@@ -1123,8 +1196,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 */
  * 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
 {
     dVAR;
 #ifdef USE_BROKEN_PAD_RESET


@@ -1227,7 +1300,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);
        /* 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);
     }
 
        AvREIFY_only(av);
     }
 


@@ -1283,13 +1356,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) */
        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
     }
            SvREADONLY_off(PL_curpad[po]);      /* could be a freed constant */
 #endif
     }


@@ -1317,11 +1384,13 @@ Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
     SV **ppad;
     I32 ix;
 
     SV **ppad;
     I32 ix;
 

+    PERL_ARGS_ASSERT_DO_DUMP_PAD;
+

     if (!padlist) {
        return;
     }
     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,
     pname = AvARRAY(pad_name);
     ppad = AvARRAY(pad);
     Perl_dump_indent(aTHX_ level, file,


@@ -1386,6 +1455,8 @@ S_cv_dump(pTHX_ const CV *cv, const char *title)
     const CV * const outside = CvOUTSIDE(cv);
     AV* const padlist = CvPADLIST(cv);
 
     const CV * const outside = CvOUTSIDE(cv);
     AV* const padlist = CvPADLIST(cv);
 

+    PERL_ARGS_ASSERT_CV_DUMP;
+

     PerlIO_printf(Perl_debug_log,
                  "  %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
                  title,
     PerlIO_printf(Perl_debug_log,
                  "  %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
                  title,


@@ -1428,8 +1499,8 @@ Perl_cv_clone(pTHX_ CV *proto)
     dVAR;
     I32 ix;
     AV* const protopadlist = CvPADLIST(proto);
     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);
     SV** const pname = AvARRAY(protopad_name);
     SV** const ppad = AvARRAY(protopad);
     const I32 fname = AvFILLp(protopad_name);


@@ -1439,6 +1510,8 @@ Perl_cv_clone(pTHX_ CV *proto)
     CV* outside;
     long depth;
 
     CV* outside;
     long depth;
 

+    PERL_ARGS_ASSERT_CV_CLONE;
+

     assert(!CvUNIQUE(proto));
 
     /* Since cloneable anon subs can be nested, CvOUTSIDE may point
     assert(!CvUNIQUE(proto));
 
     /* Since cloneable anon subs can be nested, CvOUTSIDE may point


@@ -1457,8 +1530,7 @@ Perl_cv_clone(pTHX_ CV *proto)
     ENTER;
     SAVESPTR(PL_compcv);
 
     ENTER;
     SAVESPTR(PL_compcv);
 

-    cv = PL_compcv = (CV*)newSV(0);
-    sv_upgrade((SV *)cv, SvTYPE(proto));
+    cv = PL_compcv = MUTABLE_CV(newSV_type(SvTYPE(proto)));

     CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE);
     CvCLONED_on(cv);
 
     CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE);
     CvCLONED_on(cv);
 


@@ -1474,11 +1546,11 @@ Perl_cv_clone(pTHX_ CV *proto)
     CvROOT(cv)         = OpREFCNT_inc(CvROOT(proto));
     OP_REFCNT_UNLOCK;
     CvSTART(cv)                = CvSTART(proto);
     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))
     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);
 
 
     CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
 


@@ -1497,29 +1569,31 @@ Perl_cv_clone(pTHX_ CV *proto)
            if (SvFAKE(namesv)) {   /* lexical from outside? */
                sv = outpad[PARENT_PAD_INDEX(namesv)];
                assert(sv);
            if (SvFAKE(namesv)) {   /* lexical from outside? */
                sv = outpad[PARENT_PAD_INDEX(namesv)];
                assert(sv);

-               /* formats may have an inactive parent */
-               if (SvTYPE(proto) == SVt_PVFM && SvPADSTALE(sv)) {
-                   if (ckWARN(WARN_CLOSURE))
-                       Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
-                           "Variable \"%s\" is not available", SvPVX_const(namesv));
+               /* formats may have an inactive parent,
+                  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)) {
+                   Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
+                                  "Variable \"%s\" is not available", SvPVX_const(namesv));

                    sv = NULL;
                }
                    sv = NULL;
                }

-               else {
-                   assert(!SvPADSTALE(sv));
+               else 

                    SvREFCNT_inc_simple_void_NN(sv);
                    SvREFCNT_inc_simple_void_NN(sv);

-               }

            }
            if (!sv) {
                 const char sigil = SvPVX_const(namesv)[0];
                 if (sigil == '&')
                    sv = SvREFCNT_inc(ppad[ix]);
                 else if (sigil == '@')
            }
            if (!sv) {
                 const char sigil = SvPVX_const(namesv)[0];
                 if (sigil == '&')
                    sv = SvREFCNT_inc(ppad[ix]);
                 else if (sigil == '@')

-                   sv = (SV*)newAV();
+                   sv = MUTABLE_SV(newAV());

                 else if (sigil == '%')
                 else if (sigil == '%')

-                   sv = (SV*)newHV();
+                   sv = MUTABLE_SV(newHV());

                else
                    sv = newSV(0);
                SvPADMY_on(sv);
                else
                    sv = newSV(0);
                SvPADMY_on(sv);

+               /* reset the 'assign only once' flag on each state var */
+               if (SvPAD_STATE(namesv))
+                   SvPADSTALE_on(sv);

            }
        }
        else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
            }
        }
        else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {


@@ -1576,10 +1650,12 @@ Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
 {
     dVAR;
     I32 ix;
 {
     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);
     SV ** const namepad = AvARRAY(comppad_name);
     SV ** const curpad = AvARRAY(comppad);

+
+    PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;

     PERL_UNUSED_ARG(old_cv);
 
     for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
     PERL_UNUSED_ARG(old_cv);
 
     for (ix = AvFILLp(comppad_name); ix > 0; ix--) {


@@ -1587,7 +1663,7 @@ Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
        if (namesv && namesv != &PL_sv_undef
            && *SvPVX_const(namesv) == '&')
        {
        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;
            assert(CvWEAKOUTSIDE(innercv));
            assert(CvOUTSIDE(innercv) == old_cv);
            CvOUTSIDE(innercv) = new_cv;


@@ -1610,28 +1686,34 @@ void
 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
 {
     dVAR;
 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
 {
     dVAR;

+
+    PERL_ARGS_ASSERT_PAD_PUSH;
+

     if (depth > AvFILLp(padlist)) {
        SV** const svp = AvARRAY(padlist);
        AV* const newpad = newAV();
        SV** const oldpad = AvARRAY(svp[depth-1]);
     if (depth > AvFILLp(padlist)) {
        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;
 
        for ( ;ix > 0; ix--) {
            if (names_fill >= ix && names[ix] != &PL_sv_undef) {
                const char sigil = SvPVX_const(names[ix])[0];
        SV** const names = AvARRAY(svp[0]);
        AV *av;
 
        for ( ;ix > 0; ix--) {
            if (names_fill >= ix && names[ix] != &PL_sv_undef) {
                const char sigil = SvPVX_const(names[ix])[0];

-               if ((SvFLAGS(names[ix]) & SVf_FAKE) || sigil == '&') {
+               if ((SvFLAGS(names[ix]) & SVf_FAKE)
+                       || (SvFLAGS(names[ix]) & SVpad_STATE)
+                       || sigil == '&')
+               {

                    /* outer lexical or anon code */
                    av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
                }
                else {          /* our own lexical */
                    SV *sv; 
                    if (sigil == '@')
                    /* outer lexical or anon code */
                    av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
                }
                else {          /* our own lexical */
                    SV *sv; 
                    if (sigil == '@')

-                       sv = (SV*)newAV();
+                       sv = MUTABLE_SV(newAV());

                    else if (sigil == '%')
                    else if (sigil == '%')

-                       sv = (SV*)newHV();
+                       sv = MUTABLE_SV(newHV());

                    else
                        sv = newSV(0);
                    av_store(newpad, ix, sv);
                    else
                        sv = newSV(0);
                    av_store(newpad, ix, sv);


@@ -1650,10 +1732,10 @@ Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
        }
        av = newAV();
        av_extend(av, 0);
        }
        av = newAV();
        av_extend(av, 0);

-       av_store(newpad, 0, (SV*)av);
+       av_store(newpad, 0, MUTABLE_SV(av));

        AvREIFY_only(av);
 
        AvREIFY_only(av);
 

-       av_store(padlist, depth, (SV*)newpad);
+       av_store(padlist, depth, MUTABLE_SV(newpad));

        AvFILLp(padlist) = depth;
     }
 }
        AvFILLp(padlist) = depth;
     }
 }