pad.c

   1 /*    pad.c
   2  *
   3  *    Copyright (c) 2002, Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  *  "Anyway: there was this Mr Frodo left an orphan and stranded, as you
   9  *  might say, among those queer Bucklanders, being brought up anyhow in
  10  *  Brandy Hall. A regular warren, by all accounts. Old Master Gorbadoc
  11  *  never had fewer than a couple of hundred relations in the place. Mr
  12  *  Bilbo never did a kinder deed than when he brought the lad back to
  13  *  live among decent folk." --the Gaffer
  14  */
  15
  16 /* XXX DAPM
  17  * As of Sept 2002, this file is new and may be in a state of flux for
  18  * a while. I've marked things I intent to come back and look at further
  19  * with an 'XXX DAPM' comment.
  20  */
  21
  22 /*
  23 =head1 Pad Data Structures
  24
  25 =for apidoc m|AV *|CvPADLIST|CV *cv
  26 CV's can have CvPADLIST(cv) set to point to an AV.
  27
  28 For these purposes "forms" are a kind-of CV, eval""s are too (except they're
  29 not callable at will and are always thrown away after the eval"" is done
  30 executing).
  31
  32 XSUBs don't have CvPADLIST set - dXSTARG fetches values from PL_curpad,
  33 but that is really the callers pad (a slot of which is allocated by
  34 every entersub).
  35
  36 The CvPADLIST AV has does not have AvREAL set, so REFCNT of component items
  37 is managed "manual" (mostly in pad.c) rather than normal av.c rules.
  38 The items in the AV are not SVs as for a normal AV, but other AVs:
  39
  40 0'th Entry of the CvPADLIST is an AV which represents the "names" or rather
  41 the "static type information" for lexicals.
  42
  43 The CvDEPTH'th entry of CvPADLIST AV is an AV which is the stack frame at that
  44 depth of recursion into the CV.
  45 The 0'th slot of a frame AV is an AV which is @_.
  46 other entries are storage for variables and op targets.
  47
  48 During compilation:
  49 C<PL_comppad_name> is set the the the names AV.
  50 C<PL_comppad> is set the the frame AV for the frame CvDEPTH == 1.
  51 C<PL_curpad> is set the body of the frame AV (i.e. AvARRAY(PL_comppad)).
  52
  53 During execution, C<PL_comppad> and C<PL_curpad> refer to the live
  54 frame of the currently executing sub.
  55
  56 Iterating over the names AV iterates over all possible pad
  57 items. Pad slots that are SVs_PADTMP (targets/GVs/constants) end up having
  58 &PL_sv_undef "names" (see pad_alloc()).
  59
  60 Only my/our variable (SVs_PADMY/SVs_PADOUR) slots get valid names.
  61 The rest are op targets/GVs/constants which are statically allocated
  62 or resolved at compile time.  These don't have names by which they
  63 can be looked up from Perl code at run time through eval"" like
  64 my/our variables can be.  Since they can't be looked up by "name"
  65 but only by their index allocated at compile time (which is usually
  66 in PL_op->op_targ), wasting a name SV for them doesn't make sense.
  67
  68 The SVs in the names AV have their PV being the name of the variable.
  69 NV+1..IV inclusive is a range of cop_seq numbers for which the name is
  70 valid.  For typed lexicals name SV is SVt_PVMG and SvSTASH points at the
  71 type.  For C<our> lexicals, the type is SVt_PVGV, and GvSTASH points at the
  72 stash of the associated global (so that duplicate C<our> delarations in the
  73 same package can be detected).  SvCUR is sometimes hijacked to
  74 store the generation number during compilation.
  75
  76 If SvFAKE is set on the name SV then slot in the frame AVs are
  77 a REFCNT'ed references to a lexical from "outside".
  78
  79 If the 'name' is '&' the the corresponding entry in frame AV
  80 is a CV representing a possible closure.
  81 (SvFAKE and name of '&' is not a meaningful combination currently but could
  82 become so if C<my sub foo {}> is implemented.)
  83
  84 =cut
  85 */
  86
  87
  88 #include "EXTERN.h"
  89 #define PERL_IN_PAD_C
  90 #include "perl.h"
  91
  92
  93 #define PAD_MAX 999999999
  94
  95
  96
  97 /*
  98 =for apidoc pad_new
  99
 100 Create a new compiling padlist, saving and updating the various global
 101 vars at the same time as creating the pad itself. The following flags
 102 can be OR'ed together:
 103
 104     padnew_CLONE        this pad is for a cloned CV
 105     padnew_SAVE         save old globals
 106     padnew_SAVESUB      also save extra stuff for start of sub
 107
 108 =cut
 109 */
 110
 111 PADLIST *
 112 Perl_pad_new(pTHX_ padnew_flags flags)
 113 {
 114     AV *padlist, *padname, *pad, *a0;
 115
 116     ASSERT_CURPAD_LEGAL("pad_new");
 117
 118     /* XXX DAPM really need a new SAVEt_PAD which restores all or most
 119      * vars (based on flags) rather than storing vals + addresses for
 120      * each individually. Also see pad_block_start.
 121      * XXX DAPM Try to see whether all these conditionals are required
 122      */
 123
 124     /* save existing state, ... */
 125
 126     if (flags & padnew_SAVE) {
 127         SAVECOMPPAD();
 128         SAVESPTR(PL_comppad_name);
 129         if (! (flags & padnew_CLONE)) {
 130             SAVEI32(PL_padix);
 131             SAVEI32(PL_comppad_name_fill);
 132             SAVEI32(PL_min_intro_pending);
 133             SAVEI32(PL_max_intro_pending);
 134             if (flags & padnew_SAVESUB) {
 135                 SAVEI32(PL_pad_reset_pending);
 136             }
 137         }
 138     }
 139     /* XXX DAPM interestingly, PL_comppad_name_floor never seems to be
 140      * saved - check at some pt that this is okay */
 141
 142     /* ... create new pad ... */
 143
 144     padlist     = newAV();
 145     padname     = newAV();
 146     pad         = newAV();
 147
 148     if (flags & padnew_CLONE) {
 149         /* XXX DAPM  I dont know why cv_clone needs it
 150          * doing differently yet - perhaps this separate branch can be
 151          * dispensed with eventually ???
 152          */
 153
 154         a0 = newAV();                   /* will be @_ */
 155         av_extend(a0, 0);
 156         av_store(pad, 0, (SV*)a0);
 157         AvFLAGS(a0) = AVf_REIFY;
 158     }
 159     else {
 160         av_store(pad, 0, Nullsv);
 161     }
 162
 163     AvREAL_off(padlist);
 164     av_store(padlist, 0, (SV*)padname);
 165     av_store(padlist, 1, (SV*)pad);
 166
 167     /* ... then update state variables */
 168
 169     PL_comppad_name     = (AV*)(*av_fetch(padlist, 0, FALSE));
 170     PL_comppad          = (AV*)(*av_fetch(padlist, 1, FALSE));
 171     PL_curpad           = AvARRAY(PL_comppad);
 172
 173     if (! (flags & padnew_CLONE)) {
 174         PL_comppad_name_fill = 0;
 175         PL_min_intro_pending = 0;
 176         PL_padix             = 0;
 177     }
 178
 179     DEBUG_X(PerlIO_printf(Perl_debug_log,
 180           "Pad 0x%"UVxf"[0x%"UVxf"] new:       padlist=0x%"UVxf
 181               " name=0x%"UVxf" flags=0x%"UVxf"\n",
 182           PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(padlist),
 183               PTR2UV(padname), (UV)flags
 184         )
 185     );
 186
 187     return (PADLIST*)padlist;
 188 }
 189
 190 /*
 191 =for apidoc pad_undef
 192
 193 Free the padlist associated with a CV.
 194 If parts of it happen to be current, we null the relevant
 195 PL_*pad* global vars so that we don't have any dangling references left.
 196 We also repoint the CvOUTSIDE of any about-to-be-orphaned
 197 inner subs to the outer of this cv.
 198
 199 =cut
 200 */
 201
 202 void
 203 Perl_pad_undef(pTHX_ CV* cv)
 204 {
 205     I32 ix;
 206     PADLIST *padlist = CvPADLIST(cv);
 207
 208     if (!padlist)
 209         return;
 210     if (!SvREFCNT(CvPADLIST(cv))) /* may be during global destruction */
 211         return;
 212
 213     DEBUG_X(PerlIO_printf(Perl_debug_log,
 214           "Pad undef: padlist=0x%"UVxf"\n" , PTR2UV(padlist))
 215     );
 216
 217     /* pads may be cleared out already during global destruction */
 218     if ((CvEVAL(cv) && !CvGV(cv) /* is this eval"" ? */
 219             && !PL_dirty) || CvSPECIAL(cv))
 220     {
 221         CV *outercv = CvOUTSIDE(cv);
 222         U32 seq     = CvOUTSIDE_SEQ(cv);
 223         /* XXX DAPM the following code is very similar to
 224          * pad_fixup_inner_anons(). Merge??? */
 225
 226         /* inner references to eval's/BEGIN's/etc cv must be fixed up */
 227         AV *comppad_name = (AV*)AvARRAY(padlist)[0];
 228         SV **namepad = AvARRAY(comppad_name);
 229         AV *comppad = (AV*)AvARRAY(padlist)[1];
 230         SV **curpad = AvARRAY(comppad);
 231         for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
 232             SV *namesv = namepad[ix];
 233             if (namesv && namesv != &PL_sv_undef
 234                 && *SvPVX(namesv) == '&'
 235                 && ix <= AvFILLp(comppad))
 236             {
 237                 CV *innercv = (CV*)curpad[ix];
 238                 if (innercv && SvTYPE(innercv) == SVt_PVCV
 239                     && CvOUTSIDE(innercv) == cv)
 240                 {
 241                     CvOUTSIDE(innercv) = outercv;
 242                     CvOUTSIDE_SEQ(innercv) = seq;
 243                     /* anon prototypes aren't refcounted */
 244                     if (!CvANON(innercv) || CvCLONED(innercv)) {
 245                         (void)SvREFCNT_inc(outercv);
 246                         if (SvREFCNT(cv))
 247                             SvREFCNT_dec(cv);
 248                     }
 249                 }
 250             }
 251         }
 252     }
 253     ix = AvFILLp(padlist);
 254     while (ix >= 0) {
 255         SV* sv = AvARRAY(padlist)[ix--];
 256         if (!sv)
 257             continue;
 258         if (sv == (SV*)PL_comppad_name)
 259             PL_comppad_name = Nullav;
 260         else if (sv == (SV*)PL_comppad) {
 261             PL_comppad = Null(PAD*);
 262             PL_curpad = Null(SV**);
 263         }
 264         SvREFCNT_dec(sv);
 265     }
 266     SvREFCNT_dec((SV*)CvPADLIST(cv));
 267     CvPADLIST(cv) = Null(PADLIST*);
 268 }
 269
 270
 271
 272
 273 /*
 274 =for apidoc pad_add_name
 275
 276 Create a new name in the current pad at the specified offset.
 277 If C<typestash> is valid, the name is for a typed lexical; set the
 278 name's stash to that value.
 279 If C<ourstash> is valid, it's an our lexical, set the name's
 280 GvSTASH to that value
 281
 282 Also, if the name is @.. or %.., create a new array or hash for that slot
 283
 284 If fake, it means we're cloning an existing entry
 285
 286 =cut
 287 */
 288
 289 /*
 290  * XXX DAPM this doesn't seem the right place to create a new array/hash.
 291  * Whatever we do, we should be consistent - create scalars too, and
 292  * create even if fake. Really need to integrate better the whole entry
 293  * creation business - when + where does the name and value get created?
 294  */
 295
 296 PADOFFSET
 297 Perl_pad_add_name(pTHX_ char *name, HV* typestash, HV* ourstash, bool fake)
 298 {
 299     PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
 300     SV* namesv = NEWSV(1102, 0);
 301     U32 min, max;
 302
 303     ASSERT_CURPAD_ACTIVE("pad_add_name");
 304
 305     if (fake) {
 306         min = PL_curcop->cop_seq;
 307         max = PAD_MAX;
 308     }
 309     else {
 310         /* not yet introduced */
 311         min = PAD_MAX;
 312         max = 0;
 313     }
 314
 315     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 316           "Pad addname: %ld \"%s\", (%lu,%lu)%s\n",
 317            (long)offset, name, (unsigned long)min, (unsigned long)max,
 318           (fake ? " FAKE" : "")
 319           )
 320     );
 321
 322     sv_upgrade(namesv, ourstash ? SVt_PVGV : typestash ? SVt_PVMG : SVt_PVNV);
 323     sv_setpv(namesv, name);
 324
 325     if (typestash) {
 326         SvFLAGS(namesv) |= SVpad_TYPED;
 327         SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*) typestash);
 328     }
 329     if (ourstash) {
 330         SvFLAGS(namesv) |= SVpad_OUR;
 331         GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*) ourstash);
 332     }
 333
 334     av_store(PL_comppad_name, offset, namesv);
 335     SvNVX(namesv) = (NV)min;
 336     SvIVX(namesv) = max;
 337     if (fake)
 338         SvFAKE_on(namesv);
 339     else {
 340         if (!PL_min_intro_pending)
 341             PL_min_intro_pending = offset;
 342         PL_max_intro_pending = offset;
 343         /* XXX DAPM since slot has been allocated, replace
 344          * av_store with PL_curpad[offset] ? */
 345         if (*name == '@')
 346             av_store(PL_comppad, offset, (SV*)newAV());
 347         else if (*name == '%')
 348             av_store(PL_comppad, offset, (SV*)newHV());
 349         SvPADMY_on(PL_curpad[offset]);
 350     }
 351
 352     return offset;
 353 }
 354
 355
 356
 357
 358 /*
 359 =for apidoc pad_alloc
 360
 361 Allocate a new my or tmp pad entry. For a my, simply push a null SV onto
 362 the end of PL_comppad, but for a tmp, scan the pad from PL_padix upwards
 363 for a slot which has no name and and no active value.
 364
 365 =cut
 366 */
 367
 368 /* XXX DAPM integrate alloc(), add_name() and add_anon(),
 369  * or at least rationalise ??? */
 370
 371
 372 PADOFFSET
 373 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
 374 {
 375     SV *sv;
 376     I32 retval;
 377
 378     ASSERT_CURPAD_ACTIVE("pad_alloc");
 379
 380     if (AvARRAY(PL_comppad) != PL_curpad)
 381         Perl_croak(aTHX_ "panic: pad_alloc");
 382     if (PL_pad_reset_pending)
 383         pad_reset();
 384     if (tmptype & SVs_PADMY) {
 385         do {
 386             sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
 387         } while (SvPADBUSY(sv));                /* need a fresh one */
 388         retval = AvFILLp(PL_comppad);
 389     }
 390     else {
 391         SV **names = AvARRAY(PL_comppad_name);
 392         SSize_t names_fill = AvFILLp(PL_comppad_name);
 393         for (;;) {
 394             /*
 395              * "foreach" index vars temporarily become aliases to non-"my"
 396              * values.  Thus we must skip, not just pad values that are
 397              * marked as current pad values, but also those with names.
 398              */
 399             /* HVDS why copy to sv here? we don't seem to use it */
 400             if (++PL_padix <= names_fill &&
 401                    (sv = names[PL_padix]) && sv != &PL_sv_undef)
 402                 continue;
 403             sv = *av_fetch(PL_comppad, PL_padix, TRUE);
 404             if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) &&
 405                 !IS_PADGV(sv) && !IS_PADCONST(sv))
 406                 break;
 407         }
 408         retval = PL_padix;
 409     }
 410     SvFLAGS(sv) |= tmptype;
 411     PL_curpad = AvARRAY(PL_comppad);
 412
 413     DEBUG_X(PerlIO_printf(Perl_debug_log,
 414           "Pad 0x%"UVxf"[0x%"UVxf"] alloc:   %ld for %s\n",
 415           PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
 416           PL_op_name[optype]));
 417     return (PADOFFSET)retval;
 418 }
 419
 420 /*
 421 =for apidoc pad_add_anon
 422
 423 Add an anon code entry to the current compiling pad
 424
 425 =cut
 426 */
 427
 428 PADOFFSET
 429 Perl_pad_add_anon(pTHX_ SV* sv, OPCODE op_type)
 430 {
 431     PADOFFSET ix;
 432     SV* name;
 433
 434     name = NEWSV(1106, 0);
 435     sv_upgrade(name, SVt_PVNV);
 436     sv_setpvn(name, "&", 1);
 437     SvIVX(name) = -1;
 438     SvNVX(name) = 1;
 439     ix = pad_alloc(op_type, SVs_PADMY);
 440     av_store(PL_comppad_name, ix, name);
 441     /* XXX DAPM use PL_curpad[] ? */
 442     av_store(PL_comppad, ix, sv);
 443     SvPADMY_on(sv);
 444     return ix;
 445 }
 446
 447
 448
 449 /*
 450 =for apidoc pad_check_dup
 451
 452 Check for duplicate declarations: report any of:
 453      * a my in the current scope with the same name;
 454      * an our (anywhere in the pad) with the same name and the same stash
 455        as C<ourstash>
 456 C<is_our> indicates that the name to check is an 'our' declaration
 457
 458 =cut
 459 */
 460
 461 /* XXX DAPM integrate this into pad_add_name ??? */
 462
 463 void
 464 Perl_pad_check_dup(pTHX_ char *name, bool is_our, HV *ourstash)
 465 {
 466     SV          **svp, *sv;
 467     PADOFFSET   top, off;
 468
 469     ASSERT_CURPAD_ACTIVE("pad_check_dup");
 470     if (!ckWARN(WARN_MISC) || AvFILLp(PL_comppad_name) < 0)
 471         return; /* nothing to check */
 472
 473     svp = AvARRAY(PL_comppad_name);
 474     top = AvFILLp(PL_comppad_name);
 475     /* check the current scope */
 476     /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
 477      * type ? */
 478     for (off = top; (I32)off > PL_comppad_name_floor; off--) {
 479         if ((sv = svp[off])
 480             && sv != &PL_sv_undef
 481             && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
 482             && (!is_our
 483                 || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
 484             && strEQ(name, SvPVX(sv)))
 485         {
 486             Perl_warner(aTHX_ packWARN(WARN_MISC),
 487                 "\"%s\" variable %s masks earlier declaration in same %s",
 488                 (is_our ? "our" : "my"),
 489                 name,
 490                 (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
 491             --off;
 492             break;
 493         }
 494     }
 495     /* check the rest of the pad */
 496     if (is_our) {
 497         do {
 498             if ((sv = svp[off])
 499                 && sv != &PL_sv_undef
 500                 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
 501                 && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
 502                 && strEQ(name, SvPVX(sv)))
 503             {
 504                 Perl_warner(aTHX_ packWARN(WARN_MISC),
 505                     "\"our\" variable %s redeclared", name);
 506                 Perl_warner(aTHX_ packWARN(WARN_MISC),
 507                     "\t(Did you mean \"local\" instead of \"our\"?)\n");
 508                 break;
 509             }
 510         } while ( off-- > 0 );
 511     }
 512 }
 513
 514
 515
 516 /*
 517 =for apidoc pad_findmy
 518
 519 Given a lexical name, try to find its offset, first in the current pad,
 520 or failing that, in the pads of any lexically enclosing subs (including
 521 the complications introduced by eval). If the name is found in an outer pad,
 522 then a fake entry is added to the current pad.
 523 Returns the offset in the current pad, or NOT_IN_PAD on failure.
 524
 525 =cut
 526 */
 527
 528 PADOFFSET
 529 Perl_pad_findmy(pTHX_ char *name)
 530 {
 531     I32 off;
 532     I32 pendoff = 0;
 533     SV *sv;
 534     SV **svp = AvARRAY(PL_comppad_name);
 535     U32 seq = PL_cop_seqmax;
 536
 537     ASSERT_CURPAD_ACTIVE("pad_findmy");
 538     DEBUG_Xv(PerlIO_printf(Perl_debug_log, "Pad findmy:  \"%s\"\n", name));
 539
 540     /* The one we're looking for is probably just before comppad_name_fill. */
 541     for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
 542         if ((sv = svp[off]) &&
 543             sv != &PL_sv_undef &&
 544             (!SvIVX(sv) ||
 545              (seq <= (U32)SvIVX(sv) &&
 546               seq > (U32)I_32(SvNVX(sv)))) &&
 547             strEQ(SvPVX(sv), name))
 548         {
 549             if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
 550                 return (PADOFFSET)off;
 551             pendoff = off;      /* this pending def. will override import */
 552         }
 553     }
 554
 555     /* See if it's in a nested scope */
 556     off = pad_findlex(name, 0, PL_compcv);
 557     if (!off)                   /* pad_findlex returns 0 for failure...*/
 558         return NOT_IN_PAD;      /* ...but we return NOT_IN_PAD for failure */
 559
 560     /* If there is a pending local definition, this new alias must die */
 561     if (pendoff)
 562         SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
 563     return off;
 564 }
 565
 566
 567
 568 /*
 569 =for apidoc pad_findlex
 570
 571 Find a named lexical anywhere in a chain of nested pads. Add fake entries
 572 in the inner pads if it's found in an outer one. innercv is the CV *inside*
 573 the chain of outer CVs to be searched. If newoff is non-null, this is a
 574 run-time cloning: don't add fake entries, just find the lexical and add a
 575 ref to it at newoff in the current pad.
 576
 577 =cut
 578 */
 579
 580 STATIC PADOFFSET
 581 S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, CV* innercv)
 582 {
 583     CV *cv;
 584     I32 off;
 585     SV *sv;
 586     CV* startcv;
 587     U32 seq;
 588
 589     ASSERT_CURPAD_ACTIVE("pad_findlex");
 590     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 591         "Pad findlex: \"%s\" off=%ld startcv=0x%"UVxf"\n",
 592             name, (long)newoff, PTR2UV(innercv))
 593     );
 594
 595     seq = CvOUTSIDE_SEQ(innercv);
 596     startcv = CvOUTSIDE(innercv);
 597
 598     for (cv = startcv; cv; seq = CvOUTSIDE_SEQ(cv), cv = CvOUTSIDE(cv)) {
 599         AV *curlist = CvPADLIST(cv);
 600         SV **svp = av_fetch(curlist, 0, FALSE);
 601         AV *curname;
 602
 603         DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 604             "             searching: cv=0x%"UVxf" seq=%d\n",
 605             PTR2UV(cv), (int) seq )
 606         );
 607
 608         if (!svp || *svp == &PL_sv_undef)
 609             continue;
 610         curname = (AV*)*svp;
 611         svp = AvARRAY(curname);
 612         for (off = AvFILLp(curname); off > 0; off--) {
 613             I32 depth;
 614             AV *oldpad;
 615             SV *oldsv;
 616
 617             if ( ! (
 618                     (sv = svp[off]) &&
 619                     sv != &PL_sv_undef &&
 620                     seq <= (U32)SvIVX(sv) &&
 621                     seq > (U32)I_32(SvNVX(sv)) &&
 622                     strEQ(SvPVX(sv), name))
 623             )
 624                 continue;
 625
 626             depth = CvDEPTH(cv);
 627             if (!depth) {
 628                 if (newoff) {
 629                     if (SvFAKE(sv))
 630                         continue;
 631                     return 0; /* don't clone from inactive stack frame */
 632                 }
 633                 depth = 1;
 634             }
 635
 636             oldpad = (AV*)AvARRAY(curlist)[depth];
 637             oldsv = *av_fetch(oldpad, off, TRUE);
 638
 639             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 640                         "             matched:   offset %ld"
 641                             " %s(%lu,%lu), sv=0x%"UVxf"\n",
 642                         (long)off,
 643                         SvFAKE(sv) ? "FAKE " : "",
 644                         (unsigned long)I_32(SvNVX(sv)),
 645                         (unsigned long)SvIVX(sv),
 646                         PTR2UV(oldsv)
 647                     )
 648             );
 649
 650             if (!newoff) {              /* Not a mere clone operation. */
 651                 newoff = pad_add_name(
 652                     SvPVX(sv),
 653                     (SvFLAGS(sv) & SVpad_TYPED) ? SvSTASH(sv) : Nullhv,
 654                     (SvFLAGS(sv) & SVpad_OUR)   ? GvSTASH(sv) : Nullhv,
 655                     1  /* fake */
 656                 );
 657
 658                 if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
 659                     /* "It's closures all the way down." */
 660                     CvCLONE_on(PL_compcv);
 661                     if (cv == startcv) {
 662                         if (CvANON(PL_compcv))
 663                             oldsv = Nullsv; /* no need to keep ref */
 664                     }
 665                     else {
 666                         CV *bcv;
 667                         for (bcv = startcv;
 668                              bcv && bcv != cv && !CvCLONE(bcv);
 669                              bcv = CvOUTSIDE(bcv))
 670                         {
 671                             if (CvANON(bcv)) {
 672                                 /* install the missing pad entry in intervening
 673                                  * nested subs and mark them cloneable. */
 674                                 AV *ocomppad_name = PL_comppad_name;
 675                                 PAD *ocomppad = PL_comppad;
 676                                 AV *padlist = CvPADLIST(bcv);
 677                                 PL_comppad_name = (AV*)AvARRAY(padlist)[0];
 678                                 PL_comppad = (AV*)AvARRAY(padlist)[1];
 679                                 PL_curpad = AvARRAY(PL_comppad);
 680                                 pad_add_name(
 681                                     SvPVX(sv),
 682                                     (SvFLAGS(sv) & SVpad_TYPED)
 683                                         ? SvSTASH(sv) : Nullhv,
 684                                     (SvFLAGS(sv) & SVpad_OUR)
 685                                         ? GvSTASH(sv) : Nullhv,
 686                                     1  /* fake */
 687                                 );
 688
 689                                 PL_comppad_name = ocomppad_name;
 690                                 PL_comppad = ocomppad;
 691                                 PL_curpad = ocomppad ?
 692                                         AvARRAY(ocomppad) : Null(SV **);
 693                                 CvCLONE_on(bcv);
 694                             }
 695                             else {
 696                                 if (ckWARN(WARN_CLOSURE)
 697                                     && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
 698                                 {
 699                                     Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
 700                                       "Variable \"%s\" may be unavailable",
 701                                          name);
 702                                 }
 703                                 break;
 704                             }
 705                         }
 706                     }
 707                 }
 708                 else if (!CvUNIQUE(PL_compcv)) {
 709                     if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
 710                         && !(SvFLAGS(sv) & SVpad_OUR))
 711                     {
 712                         Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
 713                             "Variable \"%s\" will not stay shared", name);
 714                     }
 715                 }
 716             }
 717             av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
 718             ASSERT_CURPAD_ACTIVE("pad_findlex 2");
 719             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 720                         "Pad findlex: set offset %ld to sv 0x%"UVxf"\n",
 721                         (long)newoff, PTR2UV(oldsv)
 722                     )
 723             );
 724             return newoff;
 725         }
 726     }
 727     return 0;
 728 }
 729
 730
 731 /*
 732 =for apidoc pad_sv
 733
 734 Get the value at offset po in the current pad.
 735 Use macro PAD_SV instead of calling this function directly.
 736
 737 =cut
 738 */
 739
 740
 741 SV *
 742 Perl_pad_sv(pTHX_ PADOFFSET po)
 743 {
 744     ASSERT_CURPAD_ACTIVE("pad_sv");
 745
 746     if (!po)
 747         Perl_croak(aTHX_ "panic: pad_sv po");
 748     DEBUG_X(PerlIO_printf(Perl_debug_log,
 749         "Pad 0x%"UVxf"[0x%"UVxf"] sv:      %ld sv=0x%"UVxf"\n",
 750         PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
 751     );
 752     return PL_curpad[po];
 753 }
 754
 755
 756 /*
 757 =for apidoc pad_setsv
 758
 759 Set the entry at offset po in the current pad to sv.
 760 Use the macro PAD_SETSV() rather than calling this function directly.
 761
 762 =cut
 763 */
 764
 765 #ifdef DEBUGGING
 766 void
 767 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
 768 {
 769     ASSERT_CURPAD_ACTIVE("pad_setsv");
 770
 771     DEBUG_X(PerlIO_printf(Perl_debug_log,
 772         "Pad 0x%"UVxf"[0x%"UVxf"] setsv:   %ld sv=0x%"UVxf"\n",
 773         PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
 774     );
 775     PL_curpad[po] = sv;
 776 }
 777 #endif
 778
 779
 780
 781 /*
 782 =for apidoc pad_block_start
 783
 784 Update the pad compilation state variables on entry to a new block
 785
 786 =cut
 787 */
 788
 789 /* XXX DAPM perhaps:
 790  *      - integrate this in general state-saving routine ???
 791  *      - combine with the state-saving going on in pad_new ???
 792  *      - introduce a new SAVE type that does all this in one go ?
 793  */
 794
 795 void
 796 Perl_pad_block_start(pTHX_ int full)
 797 {
 798     ASSERT_CURPAD_ACTIVE("pad_block_start");
 799     SAVEI32(PL_comppad_name_floor);
 800     PL_comppad_name_floor = AvFILLp(PL_comppad_name);
 801     if (full)
 802         PL_comppad_name_fill = PL_comppad_name_floor;
 803     if (PL_comppad_name_floor < 0)
 804         PL_comppad_name_floor = 0;
 805     SAVEI32(PL_min_intro_pending);
 806     SAVEI32(PL_max_intro_pending);
 807     PL_min_intro_pending = 0;
 808     SAVEI32(PL_comppad_name_fill);
 809     SAVEI32(PL_padix_floor);
 810     PL_padix_floor = PL_padix;
 811     PL_pad_reset_pending = FALSE;
 812 }
 813
 814
 815 /*
 816 =for apidoc intro_my
 817
 818 "Introduce" my variables to visible status.
 819
 820 =cut
 821 */
 822
 823 U32
 824 Perl_intro_my(pTHX)
 825 {
 826     SV **svp;
 827     SV *sv;
 828     I32 i;
 829
 830     ASSERT_CURPAD_ACTIVE("intro_my");
 831     if (! PL_min_intro_pending)
 832         return PL_cop_seqmax;
 833
 834     svp = AvARRAY(PL_comppad_name);
 835     for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
 836         if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
 837             SvIVX(sv) = PAD_MAX;        /* Don't know scope end yet. */
 838             SvNVX(sv) = (NV)PL_cop_seqmax;
 839             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 840                 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
 841                 (long)i, SvPVX(sv),
 842                 (unsigned long)I_32(SvNVX(sv)), (unsigned long)SvIVX(sv))
 843             );
 844         }
 845     }
 846     PL_min_intro_pending = 0;
 847     PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
 848     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 849                 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax+1)));
 850
 851     return PL_cop_seqmax++;
 852 }
 853
 854 /*
 855 =for apidoc pad_leavemy
 856
 857 Cleanup at end of scope during compilation: set the max seq number for
 858 lexicals in this scope and warn of any lexicals that never got introduced.
 859
 860 =cut
 861 */
 862
 863 void
 864 Perl_pad_leavemy(pTHX)
 865 {
 866     I32 off;
 867     SV **svp = AvARRAY(PL_comppad_name);
 868     SV *sv;
 869
 870     PL_pad_reset_pending = FALSE;
 871
 872     ASSERT_CURPAD_ACTIVE("pad_leavemy");
 873     if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
 874         for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
 875             if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
 876                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
 877                                         "%s never introduced", SvPVX(sv));
 878         }
 879     }
 880     /* "Deintroduce" my variables that are leaving with this scope. */
 881     for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
 882         if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX) {
 883             SvIVX(sv) = PL_cop_seqmax;
 884             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 885                 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
 886                 (long)off, SvPVX(sv),
 887                 (unsigned long)I_32(SvNVX(sv)), (unsigned long)SvIVX(sv))
 888             );
 889         }
 890     }
 891     PL_cop_seqmax++;
 892     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 893             "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
 894 }
 895
 896
 897 /*
 898 =for apidoc pad_swipe
 899
 900 Abandon the tmp in the current pad at offset po and replace with a
 901 new one.
 902
 903 =cut
 904 */
 905
 906 void
 907 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
 908 {
 909     ASSERT_CURPAD_LEGAL("pad_swipe");
 910     if (!PL_curpad)
 911         return;
 912     if (AvARRAY(PL_comppad) != PL_curpad)
 913         Perl_croak(aTHX_ "panic: pad_swipe curpad");
 914     if (!po)
 915         Perl_croak(aTHX_ "panic: pad_swipe po");
 916
 917     DEBUG_X(PerlIO_printf(Perl_debug_log,
 918                 "Pad 0x%"UVxf"[0x%"UVxf"] swipe:   %ld\n",
 919                 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
 920
 921     if (PL_curpad[po])
 922         SvPADTMP_off(PL_curpad[po]);
 923     if (refadjust)
 924         SvREFCNT_dec(PL_curpad[po]);
 925
 926     PL_curpad[po] = NEWSV(1107,0);
 927     SvPADTMP_on(PL_curpad[po]);
 928     if ((I32)po < PL_padix)
 929         PL_padix = po - 1;
 930 }
 931
 932
 933 /*
 934 =for apidoc pad_reset
 935
 936 Mark all the current temporaries for reuse
 937
 938 =cut
 939 */
 940
 941 /* XXX pad_reset() is currently disabled because it results in serious bugs.
 942  * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
 943  * on the stack by OPs that use them, there are several ways to get an alias
 944  * to  a shared TARG.  Such an alias will change randomly and unpredictably.
 945  * We avoid doing this until we can think of a Better Way.
 946  * GSAR 97-10-29 */
 947 void
 948 Perl_pad_reset(pTHX)
 949 {
 950 #ifdef USE_BROKEN_PAD_RESET
 951     register I32 po;
 952
 953     if (AvARRAY(PL_comppad) != PL_curpad)
 954         Perl_croak(aTHX_ "panic: pad_reset curpad");
 955
 956     DEBUG_X(PerlIO_printf(Perl_debug_log,
 957             "Pad 0x%"UVxf"[0x%"UVxf"] reset:     padix %ld -> %ld",
 958             PTR2UV(PL_comppad), PTR2UV(PL_curpad),
 959                 (long)PL_padix, (long)PL_padix_floor
 960             )
 961     );
 962
 963     if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
 964         for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
 965             if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
 966                 SvPADTMP_off(PL_curpad[po]);
 967         }
 968         PL_padix = PL_padix_floor;
 969     }
 970 #endif
 971     PL_pad_reset_pending = FALSE;
 972 }
 973
 974
 975 /*
 976 =for apidoc pad_tidy
 977
 978 Tidy up a pad after we've finished compiling it:
 979     * remove most stuff from the pads of anonsub prototypes;
 980     * give it a @_;
 981     * mark tmps as such.
 982
 983 =cut
 984 */
 985
 986 /* XXX DAPM surely most of this stuff should be done properly
 987  * at the right time beforehand, rather than going around afterwards
 988  * cleaning up our mistakes ???
 989  */
 990
 991 void
 992 Perl_pad_tidy(pTHX_ padtidy_type type)
 993 {
 994     PADOFFSET ix;
 995
 996     ASSERT_CURPAD_ACTIVE("pad_tidy");
 997     /* extend curpad to match namepad */
 998     if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
 999         av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
1000
1001     if (type == padtidy_SUBCLONE) {
1002         SV **namep = AvARRAY(PL_comppad_name);
1003         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1004             SV *namesv;
1005
1006             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1007                 continue;
1008             /*
1009              * The only things that a clonable function needs in its
1010              * pad are references to outer lexicals and anonymous subs.
1011              * The rest are created anew during cloning.
1012              */
1013             if (!((namesv = namep[ix]) != Nullsv &&
1014                   namesv != &PL_sv_undef &&
1015                   (SvFAKE(namesv) ||
1016                    *SvPVX(namesv) == '&')))
1017             {
1018                 SvREFCNT_dec(PL_curpad[ix]);
1019                 PL_curpad[ix] = Nullsv;
1020             }
1021         }
1022     }
1023     else if (type == padtidy_SUB) {
1024         /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1025         AV *av = newAV();                       /* Will be @_ */
1026         av_extend(av, 0);
1027         av_store(PL_comppad, 0, (SV*)av);
1028         AvFLAGS(av) = AVf_REIFY;
1029     }
1030
1031     /* XXX DAPM rationalise these two similar branches */
1032
1033     if (type == padtidy_SUB) {
1034         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1035             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1036                 continue;
1037             if (!SvPADMY(PL_curpad[ix]))
1038                 SvPADTMP_on(PL_curpad[ix]);
1039         }
1040     }
1041     else if (type == padtidy_FORMAT) {
1042         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1043             if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
1044                 SvPADTMP_on(PL_curpad[ix]);
1045         }
1046     }
1047     PL_curpad = AvARRAY(PL_comppad);
1048 }
1049
1050
1051 /*
1052 =for apidoc pad_free
1053
1054 Free the SV at offet po in the current pad.
1055
1056 =cut
1057 */
1058
1059 /* XXX DAPM integrate with pad_swipe ???? */
1060 void
1061 Perl_pad_free(pTHX_ PADOFFSET po)
1062 {
1063     ASSERT_CURPAD_LEGAL("pad_free");
1064     if (!PL_curpad)
1065         return;
1066     if (AvARRAY(PL_comppad) != PL_curpad)
1067         Perl_croak(aTHX_ "panic: pad_free curpad");
1068     if (!po)
1069         Perl_croak(aTHX_ "panic: pad_free po");
1070
1071     DEBUG_X(PerlIO_printf(Perl_debug_log,
1072             "Pad 0x%"UVxf"[0x%"UVxf"] free:    %ld\n",
1073             PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1074     );
1075
1076     if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
1077         SvPADTMP_off(PL_curpad[po]);
1078 #ifdef USE_ITHREADS
1079 #ifdef PERL_COPY_ON_WRITE
1080         if (SvIsCOW(PL_curpad[po])) {
1081             sv_force_normal_flags(PL_curpad[po], SV_COW_DROP_PV);
1082         } else
1083 #endif
1084             SvREADONLY_off(PL_curpad[po]);      /* could be a freed constant */
1085
1086 #endif
1087     }
1088     if ((I32)po < PL_padix)
1089         PL_padix = po - 1;
1090 }
1091
1092
1093
1094 /*
1095 =for apidoc do_dump_pad
1096
1097 Dump the contents of a padlist
1098
1099 =cut
1100 */
1101
1102 void
1103 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1104 {
1105     AV *pad_name;
1106     AV *pad;
1107     SV **pname;
1108     SV **ppad;
1109     SV *namesv;
1110     I32 ix;
1111
1112     if (!padlist) {
1113         return;
1114     }
1115     pad_name = (AV*)*av_fetch((AV*)padlist, 0, FALSE);
1116     pad = (AV*)*av_fetch((AV*)padlist, 1, FALSE);
1117     pname = AvARRAY(pad_name);
1118     ppad = AvARRAY(pad);
1119     Perl_dump_indent(aTHX_ level, file,
1120             "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1121             PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1122     );
1123
1124     for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1125         namesv = pname[ix];
1126         if (namesv && namesv == &PL_sv_undef) {
1127             namesv = Nullsv;
1128         }
1129         if (namesv) {
1130             Perl_dump_indent(aTHX_ level+1, file,
1131                 "%2d. 0x%"UVxf"<%lu> %s (%lu,%lu) \"%s\"\n",
1132                 (int) ix,
1133                 PTR2UV(ppad[ix]),
1134                 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1135                 SvFAKE(namesv) ? "FAKE" : "    ",
1136                 (unsigned long)I_32(SvNVX(namesv)),
1137                 (unsigned long)SvIVX(namesv),
1138                 SvPVX(namesv)
1139             );
1140         }
1141         else if (full) {
1142             Perl_dump_indent(aTHX_ level+1, file,
1143                 "%2d. 0x%"UVxf"<%lu>\n",
1144                 (int) ix,
1145                 PTR2UV(ppad[ix]),
1146                 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1147             );
1148         }
1149     }
1150 }
1151
1152
1153
1154 /*
1155 =for apidoc cv_dump
1156
1157 dump the contents of a CV
1158
1159 =cut
1160 */
1161
1162 #ifdef DEBUGGING
1163 STATIC void
1164 S_cv_dump(pTHX_ CV *cv, char *title)
1165 {
1166     CV *outside = CvOUTSIDE(cv);
1167     AV* padlist = CvPADLIST(cv);
1168
1169     PerlIO_printf(Perl_debug_log,
1170                   "  %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1171                   title,
1172                   PTR2UV(cv),
1173                   (CvANON(cv) ? "ANON"
1174                    : (cv == PL_main_cv) ? "MAIN"
1175                    : CvUNIQUE(cv) ? "UNIQUE"
1176                    : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1177                   PTR2UV(outside),
1178                   (!outside ? "null"
1179                    : CvANON(outside) ? "ANON"
1180                    : (outside == PL_main_cv) ? "MAIN"
1181                    : CvUNIQUE(outside) ? "UNIQUE"
1182                    : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1183
1184     PerlIO_printf(Perl_debug_log,
1185                     "    PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1186     do_dump_pad(1, Perl_debug_log, padlist, 1);
1187 }
1188 #endif /* DEBUGGING */
1189
1190
1191
1192
1193
1194 /*
1195 =for apidoc cv_clone
1196
1197 Clone a CV: make a new CV which points to the same code etc, but which
1198 has a newly-created pad built by copying the prototype pad and capturing
1199 any outer lexicals.
1200
1201 =cut
1202 */
1203
1204 CV *
1205 Perl_cv_clone(pTHX_ CV *proto)
1206 {
1207     CV *cv;
1208
1209     LOCK_CRED_MUTEX;                    /* XXX create separate mutex */
1210     cv = cv_clone2(proto, CvOUTSIDE(proto));
1211     UNLOCK_CRED_MUTEX;                  /* XXX create separate mutex */
1212     return cv;
1213 }
1214
1215
1216 /* XXX DAPM separate out cv and paddish bits ???
1217  * ideally the CV-related stuff shouldn't be in pad.c - how about
1218  * a cv.c? */
1219
1220 STATIC CV *
1221 S_cv_clone2(pTHX_ CV *proto, CV *outside)
1222 {
1223     I32 ix;
1224     AV* protopadlist = CvPADLIST(proto);
1225     AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
1226     AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
1227     SV** pname = AvARRAY(protopad_name);
1228     SV** ppad = AvARRAY(protopad);
1229     I32 fname = AvFILLp(protopad_name);
1230     I32 fpad = AvFILLp(protopad);
1231     AV* comppadlist;
1232     CV* cv;
1233
1234     assert(!CvUNIQUE(proto));
1235
1236     ENTER;
1237     SAVESPTR(PL_compcv);
1238
1239     cv = PL_compcv = (CV*)NEWSV(1104, 0);
1240     sv_upgrade((SV *)cv, SvTYPE(proto));
1241     CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
1242     CvCLONED_on(cv);
1243
1244 #ifdef USE_ITHREADS
1245     CvFILE(cv)          = CvXSUB(proto) ? CvFILE(proto)
1246                                         : savepv(CvFILE(proto));
1247 #else
1248     CvFILE(cv)          = CvFILE(proto);
1249 #endif
1250     CvGV(cv)            = CvGV(proto);
1251     CvSTASH(cv)         = CvSTASH(proto);
1252     CvROOT(cv)          = OpREFCNT_inc(CvROOT(proto));
1253     CvSTART(cv)         = CvSTART(proto);
1254     if (outside) {
1255         CvOUTSIDE(cv)   = (CV*)SvREFCNT_inc(outside);
1256         CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
1257     }
1258
1259     if (SvPOK(proto))
1260         sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
1261
1262     CvPADLIST(cv) = comppadlist = pad_new(padnew_CLONE|padnew_SAVE);
1263
1264     for (ix = fname; ix >= 0; ix--)
1265         av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
1266
1267     av_fill(PL_comppad, fpad);
1268     PL_curpad = AvARRAY(PL_comppad);
1269
1270     for (ix = fpad; ix > 0; ix--) {
1271         SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
1272         if (namesv && namesv != &PL_sv_undef) {
1273             char *name = SvPVX(namesv);    /* XXX */
1274             if (SvFLAGS(namesv) & SVf_FAKE) {   /* lexical from outside? */
1275                 I32 off = pad_findlex(name, ix, cv);
1276                 if (!off)
1277                     PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
1278                 else if (off != ix)
1279                     Perl_croak(aTHX_ "panic: cv_clone: %s", name);
1280             }
1281             else {                              /* our own lexical */
1282                 SV* sv;
1283                 if (*name == '&') {
1284                     /* anon code -- we'll come back for it */
1285                     sv = SvREFCNT_inc(ppad[ix]);
1286                 }
1287                 else if (*name == '@')
1288                     sv = (SV*)newAV();
1289                 else if (*name == '%')
1290                     sv = (SV*)newHV();
1291                 else
1292                     sv = NEWSV(0, 0);
1293                 if (!SvPADBUSY(sv))
1294                     SvPADMY_on(sv);
1295                 PL_curpad[ix] = sv;
1296             }
1297         }
1298         else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
1299             PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
1300         }
1301         else {
1302             SV* sv = NEWSV(0, 0);
1303             SvPADTMP_on(sv);
1304             PL_curpad[ix] = sv;
1305         }
1306     }
1307
1308     /* Now that vars are all in place, clone nested closures. */
1309
1310     for (ix = fpad; ix > 0; ix--) {
1311         SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
1312         if (namesv
1313             && namesv != &PL_sv_undef
1314             && !(SvFLAGS(namesv) & SVf_FAKE)
1315             && *SvPVX(namesv) == '&'
1316             && CvCLONE(ppad[ix]))
1317         {
1318             CV *kid = cv_clone2((CV*)ppad[ix], cv);
1319             SvREFCNT_dec(ppad[ix]);
1320             CvCLONE_on(kid);
1321             SvPADMY_on(kid);
1322             PL_curpad[ix] = (SV*)kid;
1323         }
1324     }
1325
1326     DEBUG_Xv(
1327         PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
1328         cv_dump(outside, "Outside");
1329         cv_dump(proto,   "Proto");
1330         cv_dump(cv,      "To");
1331     );
1332
1333     LEAVE;
1334
1335     if (CvCONST(cv)) {
1336         SV* const_sv = op_const_sv(CvSTART(cv), cv);
1337         assert(const_sv);
1338         /* constant sub () { $x } closing over $x - see lib/constant.pm */
1339         SvREFCNT_dec(cv);
1340         cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
1341     }
1342
1343     return cv;
1344 }
1345
1346
1347 /*
1348 =for apidoc pad_fixup_inner_anons
1349
1350 For any anon CVs in the pad, change CvOUTSIDE of that CV from
1351 old_cv to new_cv if necessary.
1352
1353 =cut
1354 */
1355
1356 void
1357 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
1358 {
1359     I32 ix;
1360     AV *comppad_name = (AV*)AvARRAY(padlist)[0];
1361     AV *comppad = (AV*)AvARRAY(padlist)[1];
1362     SV **namepad = AvARRAY(comppad_name);
1363     SV **curpad = AvARRAY(comppad);
1364     for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
1365         SV *namesv = namepad[ix];
1366         if (namesv && namesv != &PL_sv_undef
1367             && *SvPVX(namesv) == '&')
1368         {
1369             CV *innercv = (CV*)curpad[ix];
1370             if (CvOUTSIDE(innercv) == old_cv) {
1371                 CvOUTSIDE(innercv) = new_cv;
1372                 /* anon prototypes aren't refcounted */
1373                 if (!CvANON(innercv) || CvCLONED(innercv)) {
1374                     (void)SvREFCNT_inc(new_cv);
1375                     SvREFCNT_dec(old_cv);
1376                 }
1377             }
1378         }
1379     }
1380 }
1381
1382 /*
1383 =for apidoc pad_push
1384
1385 Push a new pad frame onto the padlist, unless there's already a pad at
1386 this depth, in which case don't bother creating a new one.
1387 If has_args is true, give the new pad an @_ in slot zero.
1388
1389 =cut
1390 */
1391
1392 void
1393 Perl_pad_push(pTHX_ PADLIST *padlist, int depth, int has_args)
1394 {
1395     if (depth <= AvFILLp(padlist))
1396         return;
1397
1398     {
1399         SV** svp = AvARRAY(padlist);
1400         AV *newpad = newAV();
1401         SV **oldpad = AvARRAY(svp[depth-1]);
1402         I32 ix = AvFILLp((AV*)svp[1]);
1403         I32 names_fill = AvFILLp((AV*)svp[0]);
1404         SV** names = AvARRAY(svp[0]);
1405         SV* sv;
1406         for ( ;ix > 0; ix--) {
1407             if (names_fill >= ix && names[ix] != &PL_sv_undef) {
1408                 char *name = SvPVX(names[ix]);
1409                 if ((SvFLAGS(names[ix]) & SVf_FAKE) || *name == '&') {
1410                     /* outer lexical or anon code */
1411                     av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
1412                 }
1413                 else {          /* our own lexical */
1414                     if (*name == '@')
1415                         av_store(newpad, ix, sv = (SV*)newAV());
1416                     else if (*name == '%')
1417                         av_store(newpad, ix, sv = (SV*)newHV());
1418                     else
1419                         av_store(newpad, ix, sv = NEWSV(0, 0));
1420                     SvPADMY_on(sv);
1421                 }
1422             }
1423             else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
1424                 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
1425             }
1426             else {
1427                 /* save temporaries on recursion? */
1428                 av_store(newpad, ix, sv = NEWSV(0, 0));
1429                 SvPADTMP_on(sv);
1430             }
1431         }
1432         if (has_args) {
1433             AV* av = newAV();
1434             av_extend(av, 0);
1435             av_store(newpad, 0, (SV*)av);
1436             AvFLAGS(av) = AVf_REIFY;
1437         }
1438         av_store(padlist, depth, (SV*)newpad);
1439         AvFILLp(padlist) = depth;
1440     }
1441 }