pad.c

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