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