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