Add GPFLAGS and GPf_* to B

[perl5.git] / pad.c

diff --git a/pad.c b/pad.c
index 42f3734..1306a0a 100644 (file)
--- a/pad.c
+++ b/pad.c
@@ -319,10 +319,17 @@ children can still follow the full lexical scope chain.
 void
 Perl_cv_undef(pTHX_ CV *cv)
 {
+    PERL_ARGS_ASSERT_CV_UNDEF;
+    cv_undef_flags(cv, 0);
+}
+
+void
+Perl_cv_undef_flags(pTHX_ CV *cv, U32 flags)
+{
     const PADLIST *padlist = CvPADLIST(cv);
     bool const slabbed = !!CvSLABBED(cv);
 
-    PERL_ARGS_ASSERT_CV_UNDEF;
+    PERL_ARGS_ASSERT_CV_UNDEF_FLAGS;
 
     DEBUG_X(PerlIO_printf(Perl_debug_log,
          "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
@@ -365,8 +372,13 @@ Perl_cv_undef(pTHX_ CV *cv)
 #endif
     SvPOK_off(MUTABLE_SV(cv));         /* forget prototype */
     sv_unmagic((SV *)cv, PERL_MAGIC_checkcall);
-    if (CvNAMED(cv)) CvNAME_HEK_set(cv, NULL);
-    else            CvGV_set(cv, NULL);
+    if (!(flags & CV_UNDEF_KEEP_NAME)) {
+       if (CvNAMED(cv)) {
+           CvNAME_HEK_set(cv, NULL);
+           CvNAMED_off(cv);
+       }
+       else CvGV_set(cv, NULL);
+    }
 
     /* This statement and the subsequence if block was pad_undef().  */
     pad_peg("pad_undef");
@@ -469,9 +481,10 @@ Perl_cv_undef(pTHX_ CV *cv)
        CvXSUB(cv) = NULL;
     }
     /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
-     * ref status of CvOUTSIDE and CvGV, and ANON, which pp_entersub uses
-     * to choose an error message */
-    CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON);
+     * ref status of CvOUTSIDE and CvGV, and ANON, NAMED and
+     * LEXICAL, which are used to determine the sub's name.  */
+    CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON|CVf_LEXICAL
+                  |CVf_NAMED);
 }
 
 /*
@@ -760,8 +773,7 @@ Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
 #else
                    (SVs_PADMY|SVs_PADTMP)
 #endif
-                ) &&
-               !IS_PADGV(sv))
+                ))
                break;
        }
        if (konst) {
@@ -1766,8 +1778,7 @@ Perl_pad_tidy(pTHX_ padtidy_type type)
             * pad are anonymous subs, constants and GVs.
             * The rest are created anew during cloning.
             */
-           if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix])
-                || IS_PADGV(PL_curpad[ix]))
+           if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]))
                continue;
            namesv = namep[ix];
            if (!(PadnamePV(namesv) &&
@@ -1790,12 +1801,9 @@ Perl_pad_tidy(pTHX_ padtidy_type type)
        PADOFFSET ix;
        for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
            if (!namep[ix]) namep[ix] = &PL_sv_undef;
-           if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix])
-                || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
+           if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]))
                continue;
-           if (!SvPADMY(PL_curpad[ix])) {
-               SvPADTMP_on(PL_curpad[ix]);
-           } else if (!SvFAKE(namep[ix])) {
+           if (SvPADMY(PL_curpad[ix]) && !SvFAKE(namep[ix])) {
                /* This is a work around for how the current implementation of
                   ?{ } blocks in regexps interacts with lexicals.
 
@@ -2086,20 +2094,26 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv)
                        assert(SvTYPE(ppad[ix]) == SVt_PVCV);
                        subclones = 1;
                        sv = newSV_type(SVt_PVCV);
+                       CvLEXICAL_on(sv);
                    }
                    else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv))
                    {
                        /* my sub */
                        /* Just provide a stub, but name it.  It will be
                           upgrade to the real thing on scope entry. */
+                        dVAR;
+                       U32 hash;
+                       PERL_HASH(hash, SvPVX_const(namesv)+1,
+                                 SvCUR(namesv) - 1);
                        sv = newSV_type(SVt_PVCV);
                        CvNAME_HEK_set(
                            sv,
                            share_hek(SvPVX_const(namesv)+1,
                                      SvCUR(namesv) - 1
                                         * (SvUTF8(namesv) ? -1 : 1),
-                                     0)
+                                     hash)
                        );
+                       CvLEXICAL_on(sv);
                    }
                    else sv = SvREFCNT_inc(ppad[ix]);
                 else if (sigil == '@')
@@ -2115,7 +2129,7 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv)
            }
          }
        }
-       else if (IS_PADGV(ppad[ix]) || (namesv && PadnamePV(namesv))) {
+       else if (namesv && PadnamePV(namesv)) {
            sv = SvREFCNT_inc_NN(ppad[ix]);
        }
        else {
@@ -2222,6 +2236,49 @@ Perl_cv_clone_into(pTHX_ CV *proto, CV *target)
 }
 
 /*
+=for apidoc cv_name
+
+Returns an SV containing the name of the CV, mainly for use in error
+reporting.  The CV may actually be a GV instead, in which case the returned
+SV holds the GV's name.  Anything other than a GV or CV is treated as a
+string already holding the sub name, but this could change in the future.
+
+An SV may be passed as a second argument.  If so, the name will be assigned
+to it and it will be returned.  Otherwise the returned SV will be a new
+mortal.
+
+=cut
+*/
+
+SV *
+Perl_cv_name(pTHX_ CV *cv, SV *sv)
+{
+    PERL_ARGS_ASSERT_CV_NAME;
+    if (!isGV_with_GP(cv) && SvTYPE(cv) != SVt_PVCV) {
+       if (sv) sv_setsv(sv,(SV *)cv);
+       return sv ? (sv) : (SV *)cv;
+    }
+    {
+       SV * const retsv = sv ? (sv) : sv_newmortal();
+       if (SvTYPE(cv) == SVt_PVCV) {
+           if (CvNAMED(cv)) {
+               if (CvLEXICAL(cv)) sv_sethek(retsv, CvNAME_HEK(cv));
+               else {
+                   sv_sethek(retsv, HvNAME_HEK(CvSTASH(cv)));
+                   sv_catpvs(retsv, "::");
+                   sv_cathek(retsv, CvNAME_HEK(cv));
+               }
+           }
+           else if (CvLEXICAL(cv))
+               sv_sethek(retsv, GvNAME_HEK(GvEGV(CvGV(cv))));
+           else gv_efullname3(retsv, CvGV(cv), NULL);
+       }
+       else gv_efullname3(retsv,(GV *)cv,NULL);
+       return retsv;
+    }
+}
+
+/*
 =for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
 
 For any anon CVs in the pad, change CvOUTSIDE of that CV from
@@ -2318,12 +2375,16 @@ Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
                    else if (sigil == '%')
                        sv = MUTABLE_SV(newHV());
                    else
+                   {
                        sv = newSV(0);
+                       /* For flip-flop targets: */
+                       if (SvPADTMP(oldpad[ix])) SvPADTMP_on(sv);
+                   }
                    av_store(newpad, ix, sv);
                    SvPADMY_on(sv);
                }
            }
-           else if (IS_PADGV(oldpad[ix]) || PadnamePV(names[ix])) {
+           else if (PadnamePV(names[ix])) {
                av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
            }
            else {
@@ -2459,8 +2520,7 @@ Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
                        }
                    }
                }
-               else if (IS_PADGV(oldpad[ix])
-                     || (  names_fill >= ix && names[ix]
+               else if ((  names_fill >= ix && names[ix]
                         && PadnamePV(names[ix])  )) {
                    pad1a[ix] = sv_dup_inc(oldpad[ix], param);
                }