pad.c

   1 /*    pad.c
   2  *
   3  *    Copyright (c) 2002, Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  *  "Anyway: there was this Mr Frodo left an orphan and stranded, as you
   9  *  might say, among those queer Bucklanders, being brought up anyhow in
  10  *  Brandy Hall. A regular warren, by all accounts. Old Master Gorbadoc
  11  *  never had fewer than a couple of hundred relations in the place. Mr
  12  *  Bilbo never did a kinder deed than when he brought the lad back to
  13  *  live among decent folk." --the Gaffer
  14  */
  15
  16 /* XXX DAPM
  17  * As of Sept 2002, this file is new and may be in a state of flux for
  18  * a while. I've marked things I intent to come back and look at further
  19  * with an 'XXX DAPM' comment.
  20  */
  21
  22 /*
  23 =head1 Pad Data Structures
  24
  25 =for apidoc m|AV *|CvPADLIST|CV *cv
  26 CV's can have CvPADLIST(cv) set to point to an AV.
  27
  28 For these purposes "forms" are a kind-of CV, eval""s are too (except they're
  29 not callable at will and are always thrown away after the eval"" is done
  30 executing).
  31
  32 XSUBs don't have CvPADLIST set - dXSTARG fetches values from PL_curpad,
  33 but that is really the callers pad (a slot of which is allocated by
  34 every entersub).
  35
  36 The CvPADLIST AV has does not have AvREAL set, so REFCNT of component items
  37 is managed "manual" (mostly in pad.c) rather than normal av.c rules.
  38 The items in the AV are not SVs as for a normal AV, but other AVs:
  39
  40 0'th Entry of the CvPADLIST is an AV which represents the "names" or rather
  41 the "static type information" for lexicals.
  42
  43 The CvDEPTH'th entry of CvPADLIST AV is an AV which is the stack frame at that
  44 depth of recursion into the CV.
  45 The 0'th slot of a frame AV is an AV which is @_.
  46 other entries are storage for variables and op targets.
  47
  48 During compilation:
  49 C<PL_comppad_name> is set the the the names AV.
  50 C<PL_comppad> is set the the frame AV for the frame CvDEPTH == 1.
  51 C<PL_curpad> is set the body of the frame AV (i.e. AvARRAY(PL_comppad)).
  52
  53 During execution, C<PL_comppad> and C<PL_curpad> refer to the live
  54 frame of the currently executing sub.
  55
  56 Iterating over the names AV iterates over all possible pad
  57 items. Pad slots that are SVs_PADTMP (targets/GVs/constants) end up having
  58 &PL_sv_undef "names" (see pad_alloc()).
  59
  60 Only my/our variable (SVs_PADMY/SVs_PADOUR) slots get valid names.
  61 The rest are op targets/GVs/constants which are statically allocated
  62 or resolved at compile time.  These don't have names by which they
  63 can be looked up from Perl code at run time through eval"" like
  64 my/our variables can be.  Since they can't be looked up by "name"
  65 but only by their index allocated at compile time (which is usually
  66 in PL_op->op_targ), wasting a name SV for them doesn't make sense.
  67
  68 The SVs in the names AV have their PV being the name of the variable.
  69 NV+1..IV inclusive is a range of cop_seq numbers for which the name is
  70 valid.  For typed lexicals name SV is SVt_PVMG and SvSTASH points at the
  71 type.  For C<our> lexicals, the type is SVt_PVGV, and GvSTASH points at the
  72 stash of the associated global (so that duplicate C<our> delarations in the
  73 same package can be detected).  SvCUR is sometimes hijacked to
  74 store the generation number during compilation.
  75
  76 If SvFAKE is set on the name SV then slot in the frame AVs are
  77 a REFCNT'ed references to a lexical from "outside". In this case,
  78 the name SV does not have a cop_seq range, since it is in scope
  79 throughout.
  80
  81 If the 'name' is '&' the the corresponding entry in frame AV
  82 is a CV representing a possible closure.
  83 (SvFAKE and name of '&' is not a meaningful combination currently but could
  84 become so if C<my sub foo {}> is implemented.)
  85
  86 =cut
  87 */
  88
  89
  90 #include "EXTERN.h"
  91 #define PERL_IN_PAD_C
  92 #include "perl.h"
  93
  94
  95 #define PAD_MAX 999999999
  96
  97
  98
  99 /*
 100 =for apidoc pad_new
 101
 102 Create a new compiling padlist, saving and updating the various global
 103 vars at the same time as creating the pad itself. The following flags
 104 can be OR'ed together:
 105
 106     padnew_CLONE        this pad is for a cloned CV
 107     padnew_SAVE         save old globals
 108     padnew_SAVESUB      also save extra stuff for start of sub
 109
 110 =cut
 111 */
 112
 113 PADLIST *
 114 Perl_pad_new(pTHX_ 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 (
 556                    (   seq >  (U32)I_32(SvNVX(sv))      /* min */
 557                     && seq <= (U32)SvIVX(sv))           /* max */
 558                 ||
 559                     /* 'our' is visible before introduction */
 560                     (!SvIVX(sv) && (SvFLAGS(sv) & SVpad_OUR))
 561             )
 562                 return off;
 563         }
 564     }
 565     if (fake_off)
 566         return fake_off;
 567
 568     /* See if it's in a nested scope */
 569     off = pad_findlex(name, 0, PL_compcv);
 570     if (!off)                   /* pad_findlex returns 0 for failure...*/
 571         return NOT_IN_PAD;      /* ...but we return NOT_IN_PAD for failure */
 572
 573     return off;
 574 }
 575
 576
 577
 578 /*
 579 =for apidoc pad_findlex
 580
 581 Find a named lexical anywhere in a chain of nested pads. Add fake entries
 582 in the inner pads if it's found in an outer one. innercv is the CV *inside*
 583 the chain of outer CVs to be searched. If newoff is non-null, this is a
 584 run-time cloning: don't add fake entries, just find the lexical and add a
 585 ref to it at newoff in the current pad.
 586
 587 =cut
 588 */
 589
 590 STATIC PADOFFSET
 591 S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, CV* innercv)
 592 {
 593     CV *cv;
 594     I32 off = 0;
 595     SV *sv;
 596     CV* startcv;
 597     U32 seq;
 598     I32 depth;
 599     AV *oldpad;
 600     SV *oldsv;
 601     AV *curlist;
 602
 603     ASSERT_CURPAD_ACTIVE("pad_findlex");
 604     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 605         "Pad findlex: \"%s\" off=%ld startcv=0x%"UVxf"\n",
 606             name, (long)newoff, PTR2UV(innercv))
 607     );
 608
 609     seq = CvOUTSIDE_SEQ(innercv);
 610     startcv = CvOUTSIDE(innercv);
 611
 612     for (cv = startcv; cv; seq = CvOUTSIDE_SEQ(cv), cv = CvOUTSIDE(cv)) {
 613         SV **svp;
 614         AV *curname;
 615         I32 fake_off = 0;
 616
 617         DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 618             "             searching: cv=0x%"UVxf" seq=%d\n",
 619             PTR2UV(cv), (int) seq )
 620         );
 621
 622         curlist = CvPADLIST(cv);
 623         if (!curlist)
 624             continue; /* an undef CV */
 625         svp = av_fetch(curlist, 0, FALSE);
 626         if (!svp || *svp == &PL_sv_undef)
 627             continue;
 628         curname = (AV*)*svp;
 629         svp = AvARRAY(curname);
 630
 631         depth = CvDEPTH(cv);
 632         for (off = AvFILLp(curname); off > 0; off--) {
 633             sv = svp[off];
 634             if (!sv || sv == &PL_sv_undef || !strEQ(SvPVX(sv), name))
 635                 continue;
 636             if (SvFAKE(sv)) {
 637                 /* we'll use this later if we don't find a real entry */
 638                 fake_off = off;
 639                 continue;
 640             }
 641             else {
 642                 if (   seq >  (U32)I_32(SvNVX(sv))      /* min */
 643                     && seq <= (U32)SvIVX(sv)            /* max */
 644                     && !(newoff && !depth) /* ignore inactive when cloning */
 645                 )
 646                     goto found;
 647             }
 648         }
 649
 650         /* no real entry - but did we find a fake one? */
 651         if (fake_off) {
 652             if (newoff && !depth)
 653                 return 0; /* don't clone from inactive stack frame */
 654             off = fake_off;
 655             sv = svp[off];
 656             goto found;
 657         }
 658     }
 659     return 0;
 660
 661 found:
 662
 663     if (!depth)
 664         depth = 1;
 665
 666     oldpad = (AV*)AvARRAY(curlist)[depth];
 667     oldsv = *av_fetch(oldpad, off, TRUE);
 668
 669 #ifdef DEBUGGING
 670     if (SvFAKE(sv))
 671         DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 672                 "             matched:   offset %ld"
 673                     " FAKE, sv=0x%"UVxf"\n",
 674                 (long)off,
 675                 PTR2UV(oldsv)
 676             )
 677         );
 678     else
 679         DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 680                 "             matched:   offset %ld"
 681                     " (%lu,%lu), sv=0x%"UVxf"\n",
 682                 (long)off,
 683                 (unsigned long)I_32(SvNVX(sv)),
 684                 (unsigned long)SvIVX(sv),
 685                 PTR2UV(oldsv)
 686             )
 687         );
 688 #endif
 689
 690     if (!newoff) {              /* Not a mere clone operation. */
 691         newoff = pad_add_name(
 692             SvPVX(sv),
 693             (SvFLAGS(sv) & SVpad_TYPED) ? SvSTASH(sv) : Nullhv,
 694             (SvFLAGS(sv) & SVpad_OUR)   ? GvSTASH(sv) : Nullhv,
 695             1  /* fake */
 696         );
 697
 698         if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
 699             /* "It's closures all the way down." */
 700             CvCLONE_on(PL_compcv);
 701             if (cv == startcv) {
 702                 if (CvANON(PL_compcv))
 703                     oldsv = Nullsv; /* no need to keep ref */
 704             }
 705             else {
 706                 CV *bcv;
 707                 for (bcv = startcv;
 708                      bcv && bcv != cv && !CvCLONE(bcv);
 709                      bcv = CvOUTSIDE(bcv))
 710                 {
 711                     if (CvANON(bcv)) {
 712                         /* install the missing pad entry in intervening
 713                          * nested subs and mark them cloneable. */
 714                         AV *ocomppad_name = PL_comppad_name;
 715                         PAD *ocomppad = PL_comppad;
 716                         AV *padlist = CvPADLIST(bcv);
 717                         PL_comppad_name = (AV*)AvARRAY(padlist)[0];
 718                         PL_comppad = (AV*)AvARRAY(padlist)[1];
 719                         PL_curpad = AvARRAY(PL_comppad);
 720                         pad_add_name(
 721                             SvPVX(sv),
 722                             (SvFLAGS(sv) & SVpad_TYPED)
 723                                 ? SvSTASH(sv) : Nullhv,
 724                             (SvFLAGS(sv) & SVpad_OUR)
 725                                 ? GvSTASH(sv) : Nullhv,
 726                             1  /* fake */
 727                         );
 728
 729                         PL_comppad_name = ocomppad_name;
 730                         PL_comppad = ocomppad;
 731                         PL_curpad = ocomppad ?
 732                                 AvARRAY(ocomppad) : Null(SV **);
 733                         CvCLONE_on(bcv);
 734                     }
 735                     else {
 736                         if (ckWARN(WARN_CLOSURE)
 737                             && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
 738                         {
 739                             Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
 740                               "Variable \"%s\" may be unavailable",
 741                                  name);
 742                         }
 743                         break;
 744                     }
 745                 }
 746             }
 747         }
 748         else if (!CvUNIQUE(PL_compcv)) {
 749             if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
 750                 && !(SvFLAGS(sv) & SVpad_OUR))
 751             {
 752                 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
 753                     "Variable \"%s\" will not stay shared", name);
 754             }
 755         }
 756     }
 757     av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
 758     ASSERT_CURPAD_ACTIVE("pad_findlex 2");
 759     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 760                 "Pad findlex: set offset %ld to sv 0x%"UVxf"\n",
 761                 (long)newoff, PTR2UV(oldsv)
 762             )
 763     );
 764     return newoff;
 765 }
 766
 767
 768 /*
 769 =for apidoc pad_sv
 770
 771 Get the value at offset po in the current pad.
 772 Use macro PAD_SV instead of calling this function directly.
 773
 774 =cut
 775 */
 776
 777
 778 SV *
 779 Perl_pad_sv(pTHX_ PADOFFSET po)
 780 {
 781     ASSERT_CURPAD_ACTIVE("pad_sv");
 782
 783     if (!po)
 784         Perl_croak(aTHX_ "panic: pad_sv po");
 785     DEBUG_X(PerlIO_printf(Perl_debug_log,
 786         "Pad 0x%"UVxf"[0x%"UVxf"] sv:      %ld sv=0x%"UVxf"\n",
 787         PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
 788     );
 789     return PL_curpad[po];
 790 }
 791
 792
 793 /*
 794 =for apidoc pad_setsv
 795
 796 Set the entry at offset po in the current pad to sv.
 797 Use the macro PAD_SETSV() rather than calling this function directly.
 798
 799 =cut
 800 */
 801
 802 #ifdef DEBUGGING
 803 void
 804 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
 805 {
 806     ASSERT_CURPAD_ACTIVE("pad_setsv");
 807
 808     DEBUG_X(PerlIO_printf(Perl_debug_log,
 809         "Pad 0x%"UVxf"[0x%"UVxf"] setsv:   %ld sv=0x%"UVxf"\n",
 810         PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
 811     );
 812     PL_curpad[po] = sv;
 813 }
 814 #endif
 815
 816
 817
 818 /*
 819 =for apidoc pad_block_start
 820
 821 Update the pad compilation state variables on entry to a new block
 822
 823 =cut
 824 */
 825
 826 /* XXX DAPM perhaps:
 827  *      - integrate this in general state-saving routine ???
 828  *      - combine with the state-saving going on in pad_new ???
 829  *      - introduce a new SAVE type that does all this in one go ?
 830  */
 831
 832 void
 833 Perl_pad_block_start(pTHX_ int full)
 834 {
 835     ASSERT_CURPAD_ACTIVE("pad_block_start");
 836     SAVEI32(PL_comppad_name_floor);
 837     PL_comppad_name_floor = AvFILLp(PL_comppad_name);
 838     if (full)
 839         PL_comppad_name_fill = PL_comppad_name_floor;
 840     if (PL_comppad_name_floor < 0)
 841         PL_comppad_name_floor = 0;
 842     SAVEI32(PL_min_intro_pending);
 843     SAVEI32(PL_max_intro_pending);
 844     PL_min_intro_pending = 0;
 845     SAVEI32(PL_comppad_name_fill);
 846     SAVEI32(PL_padix_floor);
 847     PL_padix_floor = PL_padix;
 848     PL_pad_reset_pending = FALSE;
 849 }
 850
 851
 852 /*
 853 =for apidoc intro_my
 854
 855 "Introduce" my variables to visible status.
 856
 857 =cut
 858 */
 859
 860 U32
 861 Perl_intro_my(pTHX)
 862 {
 863     SV **svp;
 864     SV *sv;
 865     I32 i;
 866
 867     ASSERT_CURPAD_ACTIVE("intro_my");
 868     if (! PL_min_intro_pending)
 869         return PL_cop_seqmax;
 870
 871     svp = AvARRAY(PL_comppad_name);
 872     for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
 873         if ((sv = svp[i]) && sv != &PL_sv_undef
 874                 && !SvFAKE(sv) && !SvIVX(sv))
 875         {
 876             SvIVX(sv) = PAD_MAX;        /* Don't know scope end yet. */
 877             SvNVX(sv) = (NV)PL_cop_seqmax;
 878             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 879                 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
 880                 (long)i, SvPVX(sv),
 881                 (unsigned long)I_32(SvNVX(sv)), (unsigned long)SvIVX(sv))
 882             );
 883         }
 884     }
 885     PL_min_intro_pending = 0;
 886     PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
 887     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 888                 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax+1)));
 889
 890     return PL_cop_seqmax++;
 891 }
 892
 893 /*
 894 =for apidoc pad_leavemy
 895
 896 Cleanup at end of scope during compilation: set the max seq number for
 897 lexicals in this scope and warn of any lexicals that never got introduced.
 898
 899 =cut
 900 */
 901
 902 void
 903 Perl_pad_leavemy(pTHX)
 904 {
 905     I32 off;
 906     SV **svp = AvARRAY(PL_comppad_name);
 907     SV *sv;
 908
 909     PL_pad_reset_pending = FALSE;
 910
 911     ASSERT_CURPAD_ACTIVE("pad_leavemy");
 912     if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
 913         for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
 914             if ((sv = svp[off]) && sv != &PL_sv_undef
 915                     && !SvFAKE(sv) && ckWARN_d(WARN_INTERNAL))
 916                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
 917                                         "%s never introduced", SvPVX(sv));
 918         }
 919     }
 920     /* "Deintroduce" my variables that are leaving with this scope. */
 921     for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
 922         if ((sv = svp[off]) && sv != &PL_sv_undef
 923                 && !SvFAKE(sv) && SvIVX(sv) == PAD_MAX)
 924         {
 925             SvIVX(sv) = PL_cop_seqmax;
 926             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 927                 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
 928                 (long)off, SvPVX(sv),
 929                 (unsigned long)I_32(SvNVX(sv)), (unsigned long)SvIVX(sv))
 930             );
 931         }
 932     }
 933     PL_cop_seqmax++;
 934     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 935             "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
 936 }
 937
 938
 939 /*
 940 =for apidoc pad_swipe
 941
 942 Abandon the tmp in the current pad at offset po and replace with a
 943 new one.
 944
 945 =cut
 946 */
 947
 948 void
 949 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
 950 {
 951     ASSERT_CURPAD_LEGAL("pad_swipe");
 952     if (!PL_curpad)
 953         return;
 954     if (AvARRAY(PL_comppad) != PL_curpad)
 955         Perl_croak(aTHX_ "panic: pad_swipe curpad");
 956     if (!po)
 957         Perl_croak(aTHX_ "panic: pad_swipe po");
 958
 959     DEBUG_X(PerlIO_printf(Perl_debug_log,
 960                 "Pad 0x%"UVxf"[0x%"UVxf"] swipe:   %ld\n",
 961                 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
 962
 963     if (PL_curpad[po])
 964         SvPADTMP_off(PL_curpad[po]);
 965     if (refadjust)
 966         SvREFCNT_dec(PL_curpad[po]);
 967
 968     PL_curpad[po] = NEWSV(1107,0);
 969     SvPADTMP_on(PL_curpad[po]);
 970     if ((I32)po < PL_padix)
 971         PL_padix = po - 1;
 972 }
 973
 974
 975 /*
 976 =for apidoc pad_reset
 977
 978 Mark all the current temporaries for reuse
 979
 980 =cut
 981 */
 982
 983 /* XXX pad_reset() is currently disabled because it results in serious bugs.
 984  * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
 985  * on the stack by OPs that use them, there are several ways to get an alias
 986  * to  a shared TARG.  Such an alias will change randomly and unpredictably.
 987  * We avoid doing this until we can think of a Better Way.
 988  * GSAR 97-10-29 */
 989 void
 990 Perl_pad_reset(pTHX)
 991 {
 992 #ifdef USE_BROKEN_PAD_RESET
 993     register I32 po;
 994
 995     if (AvARRAY(PL_comppad) != PL_curpad)
 996         Perl_croak(aTHX_ "panic: pad_reset curpad");
 997
 998     DEBUG_X(PerlIO_printf(Perl_debug_log,
 999             "Pad 0x%"UVxf"[0x%"UVxf"] reset:     padix %ld -> %ld",
1000             PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1001                 (long)PL_padix, (long)PL_padix_floor
1002             )
1003     );
1004
1005     if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
1006         for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
1007             if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
1008                 SvPADTMP_off(PL_curpad[po]);
1009         }
1010         PL_padix = PL_padix_floor;
1011     }
1012 #endif
1013     PL_pad_reset_pending = FALSE;
1014 }
1015
1016
1017 /*
1018 =for apidoc pad_tidy
1019
1020 Tidy up a pad after we've finished compiling it:
1021     * remove most stuff from the pads of anonsub prototypes;
1022     * give it a @_;
1023     * mark tmps as such.
1024
1025 =cut
1026 */
1027
1028 /* XXX DAPM surely most of this stuff should be done properly
1029  * at the right time beforehand, rather than going around afterwards
1030  * cleaning up our mistakes ???
1031  */
1032
1033 void
1034 Perl_pad_tidy(pTHX_ padtidy_type type)
1035 {
1036     PADOFFSET ix;
1037
1038     ASSERT_CURPAD_ACTIVE("pad_tidy");
1039     /* extend curpad to match namepad */
1040     if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1041         av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
1042
1043     if (type == padtidy_SUBCLONE) {
1044         SV **namep = AvARRAY(PL_comppad_name);
1045         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1046             SV *namesv;
1047
1048             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1049                 continue;
1050             /*
1051              * The only things that a clonable function needs in its
1052              * pad are references to outer lexicals and anonymous subs.
1053              * The rest are created anew during cloning.
1054              */
1055             if (!((namesv = namep[ix]) != Nullsv &&
1056                   namesv != &PL_sv_undef &&
1057                   (SvFAKE(namesv) ||
1058                    *SvPVX(namesv) == '&')))
1059             {
1060                 SvREFCNT_dec(PL_curpad[ix]);
1061                 PL_curpad[ix] = Nullsv;
1062             }
1063         }
1064     }
1065     else if (type == padtidy_SUB) {
1066         /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1067         AV *av = newAV();                       /* Will be @_ */
1068         av_extend(av, 0);
1069         av_store(PL_comppad, 0, (SV*)av);
1070         AvFLAGS(av) = AVf_REIFY;
1071     }
1072
1073     /* XXX DAPM rationalise these two similar branches */
1074
1075     if (type == padtidy_SUB) {
1076         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1077             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1078                 continue;
1079             if (!SvPADMY(PL_curpad[ix]))
1080                 SvPADTMP_on(PL_curpad[ix]);
1081         }
1082     }
1083     else if (type == padtidy_FORMAT) {
1084         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1085             if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
1086                 SvPADTMP_on(PL_curpad[ix]);
1087         }
1088     }
1089     PL_curpad = AvARRAY(PL_comppad);
1090 }
1091
1092
1093 /*
1094 =for apidoc pad_free
1095
1096 Free the SV at offet po in the current pad.
1097
1098 =cut
1099 */
1100
1101 /* XXX DAPM integrate with pad_swipe ???? */
1102 void
1103 Perl_pad_free(pTHX_ PADOFFSET po)
1104 {
1105     ASSERT_CURPAD_LEGAL("pad_free");
1106     if (!PL_curpad)
1107         return;
1108     if (AvARRAY(PL_comppad) != PL_curpad)
1109         Perl_croak(aTHX_ "panic: pad_free curpad");
1110     if (!po)
1111         Perl_croak(aTHX_ "panic: pad_free po");
1112
1113     DEBUG_X(PerlIO_printf(Perl_debug_log,
1114             "Pad 0x%"UVxf"[0x%"UVxf"] free:    %ld\n",
1115             PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1116     );
1117
1118     if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
1119         SvPADTMP_off(PL_curpad[po]);
1120 #ifdef USE_ITHREADS
1121         /* SV could be a shared hash key (eg bugid #19022) */
1122         if (
1123 #ifdef PERL_COPY_ON_WRITE
1124             !SvIsCOW(PL_curpad[po])
1125 #else
1126             !SvFAKE(PL_curpad[po])
1127 #endif
1128             )
1129             SvREADONLY_off(PL_curpad[po]);      /* could be a freed constant */
1130 #endif
1131     }
1132     if ((I32)po < PL_padix)
1133         PL_padix = po - 1;
1134 }
1135
1136
1137
1138 /*
1139 =for apidoc do_dump_pad
1140
1141 Dump the contents of a padlist
1142
1143 =cut
1144 */
1145
1146 void
1147 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1148 {
1149     AV *pad_name;
1150     AV *pad;
1151     SV **pname;
1152     SV **ppad;
1153     SV *namesv;
1154     I32 ix;
1155
1156     if (!padlist) {
1157         return;
1158     }
1159     pad_name = (AV*)*av_fetch((AV*)padlist, 0, FALSE);
1160     pad = (AV*)*av_fetch((AV*)padlist, 1, FALSE);
1161     pname = AvARRAY(pad_name);
1162     ppad = AvARRAY(pad);
1163     Perl_dump_indent(aTHX_ level, file,
1164             "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1165             PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1166     );
1167
1168     for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1169         namesv = pname[ix];
1170         if (namesv && namesv == &PL_sv_undef) {
1171             namesv = Nullsv;
1172         }
1173         if (namesv) {
1174             if (SvFAKE(namesv))
1175                 Perl_dump_indent(aTHX_ level+1, file,
1176                     "%2d. 0x%"UVxf"<%lu> FAKE \"%s\"\n",
1177                     (int) ix,
1178                     PTR2UV(ppad[ix]),
1179                     (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1180                     SvPVX(namesv)
1181                 );
1182             else
1183                 Perl_dump_indent(aTHX_ level+1, file,
1184                     "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
1185                     (int) ix,
1186                     PTR2UV(ppad[ix]),
1187                     (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1188                     (unsigned long)I_32(SvNVX(namesv)),
1189                     (unsigned long)SvIVX(namesv),
1190                     SvPVX(namesv)
1191                 );
1192         }
1193         else if (full) {
1194             Perl_dump_indent(aTHX_ level+1, file,
1195                 "%2d. 0x%"UVxf"<%lu>\n",
1196                 (int) ix,
1197                 PTR2UV(ppad[ix]),
1198                 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1199             );
1200         }
1201     }
1202 }
1203
1204
1205
1206 /*
1207 =for apidoc cv_dump
1208
1209 dump the contents of a CV
1210
1211 =cut
1212 */
1213
1214 #ifdef DEBUGGING
1215 STATIC void
1216 S_cv_dump(pTHX_ CV *cv, char *title)
1217 {
1218     CV *outside = CvOUTSIDE(cv);
1219     AV* padlist = CvPADLIST(cv);
1220
1221     PerlIO_printf(Perl_debug_log,
1222                   "  %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1223                   title,
1224                   PTR2UV(cv),
1225                   (CvANON(cv) ? "ANON"
1226                    : (cv == PL_main_cv) ? "MAIN"
1227                    : CvUNIQUE(cv) ? "UNIQUE"
1228                    : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1229                   PTR2UV(outside),
1230                   (!outside ? "null"
1231                    : CvANON(outside) ? "ANON"
1232                    : (outside == PL_main_cv) ? "MAIN"
1233                    : CvUNIQUE(outside) ? "UNIQUE"
1234                    : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1235
1236     PerlIO_printf(Perl_debug_log,
1237                     "    PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1238     do_dump_pad(1, Perl_debug_log, padlist, 1);
1239 }
1240 #endif /* DEBUGGING */
1241
1242
1243
1244
1245
1246 /*
1247 =for apidoc cv_clone
1248
1249 Clone a CV: make a new CV which points to the same code etc, but which
1250 has a newly-created pad built by copying the prototype pad and capturing
1251 any outer lexicals.
1252
1253 =cut
1254 */
1255
1256 CV *
1257 Perl_cv_clone(pTHX_ CV *proto)
1258 {
1259     CV *cv;
1260
1261     LOCK_CRED_MUTEX;                    /* XXX create separate mutex */
1262     cv = cv_clone2(proto, CvOUTSIDE(proto));
1263     UNLOCK_CRED_MUTEX;                  /* XXX create separate mutex */
1264     return cv;
1265 }
1266
1267
1268 /* XXX DAPM separate out cv and paddish bits ???
1269  * ideally the CV-related stuff shouldn't be in pad.c - how about
1270  * a cv.c? */
1271
1272 STATIC CV *
1273 S_cv_clone2(pTHX_ CV *proto, CV *outside)
1274 {
1275     I32 ix;
1276     AV* protopadlist = CvPADLIST(proto);
1277     AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
1278     AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
1279     SV** pname = AvARRAY(protopad_name);
1280     SV** ppad = AvARRAY(protopad);
1281     I32 fname = AvFILLp(protopad_name);
1282     I32 fpad = AvFILLp(protopad);
1283     AV* comppadlist;
1284     CV* cv;
1285
1286     assert(!CvUNIQUE(proto));
1287
1288     ENTER;
1289     SAVESPTR(PL_compcv);
1290
1291     cv = PL_compcv = (CV*)NEWSV(1104, 0);
1292     sv_upgrade((SV *)cv, SvTYPE(proto));
1293     CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE);
1294     CvCLONED_on(cv);
1295
1296 #ifdef USE_ITHREADS
1297     CvFILE(cv)          = CvXSUB(proto) ? CvFILE(proto)
1298                                         : savepv(CvFILE(proto));
1299 #else
1300     CvFILE(cv)          = CvFILE(proto);
1301 #endif
1302     CvGV(cv)            = CvGV(proto);
1303     CvSTASH(cv)         = CvSTASH(proto);
1304     CvROOT(cv)          = OpREFCNT_inc(CvROOT(proto));
1305     CvSTART(cv)         = CvSTART(proto);
1306     if (outside) {
1307         CvOUTSIDE(cv)   = (CV*)SvREFCNT_inc(outside);
1308         CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
1309     }
1310
1311     if (SvPOK(proto))
1312         sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
1313
1314     CvPADLIST(cv) = comppadlist = pad_new(padnew_CLONE|padnew_SAVE);
1315
1316     for (ix = fname; ix >= 0; ix--)
1317         av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
1318
1319     av_fill(PL_comppad, fpad);
1320     PL_curpad = AvARRAY(PL_comppad);
1321
1322     for (ix = fpad; ix > 0; ix--) {
1323         SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
1324         if (namesv && namesv != &PL_sv_undef) {
1325             char *name = SvPVX(namesv);    /* XXX */
1326             if (SvFLAGS(namesv) & SVf_FAKE) {   /* lexical from outside? */
1327                 I32 off = pad_findlex(name, ix, cv);
1328                 if (!off)
1329                     PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
1330                 else if (off != ix)
1331                     Perl_croak(aTHX_ "panic: cv_clone: %s", name);
1332             }
1333             else {                              /* our own lexical */
1334                 SV* sv;
1335                 if (*name == '&') {
1336                     /* anon code -- we'll come back for it */
1337                     sv = SvREFCNT_inc(ppad[ix]);
1338                 }
1339                 else if (*name == '@')
1340                     sv = (SV*)newAV();
1341                 else if (*name == '%')
1342                     sv = (SV*)newHV();
1343                 else
1344                     sv = NEWSV(0, 0);
1345                 SvPADMY_on(sv);
1346                 PL_curpad[ix] = sv;
1347             }
1348         }
1349         else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
1350             PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
1351         }
1352         else {
1353             SV* sv = NEWSV(0, 0);
1354             SvPADTMP_on(sv);
1355             PL_curpad[ix] = sv;
1356         }
1357     }
1358
1359     /* Now that vars are all in place, clone nested closures. */
1360
1361     for (ix = fpad; ix > 0; ix--) {
1362         SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
1363         if (namesv
1364             && namesv != &PL_sv_undef
1365             && !(SvFLAGS(namesv) & SVf_FAKE)
1366             && *SvPVX(namesv) == '&'
1367             && CvCLONE(ppad[ix]))
1368         {
1369             CV *kid = cv_clone2((CV*)ppad[ix], cv);
1370             SvREFCNT_dec(ppad[ix]);
1371             CvCLONE_on(kid);
1372             SvPADMY_on(kid);
1373             PL_curpad[ix] = (SV*)kid;
1374             /* '&' entry points to child, so child mustn't refcnt parent */
1375             CvWEAKOUTSIDE_on(kid);
1376             SvREFCNT_dec(cv);
1377         }
1378     }
1379
1380     DEBUG_Xv(
1381         PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
1382         cv_dump(outside, "Outside");
1383         cv_dump(proto,   "Proto");
1384         cv_dump(cv,      "To");
1385     );
1386
1387     LEAVE;
1388
1389     if (CvCONST(cv)) {
1390         SV* const_sv = op_const_sv(CvSTART(cv), cv);
1391         assert(const_sv);
1392         /* constant sub () { $x } closing over $x - see lib/constant.pm */
1393         SvREFCNT_dec(cv);
1394         cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
1395     }
1396
1397     return cv;
1398 }
1399
1400
1401 /*
1402 =for apidoc pad_fixup_inner_anons
1403
1404 For any anon CVs in the pad, change CvOUTSIDE of that CV from
1405 old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
1406 moved to a pre-existing CV struct.
1407
1408 =cut
1409 */
1410
1411 void
1412 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
1413 {
1414     I32 ix;
1415     AV *comppad_name = (AV*)AvARRAY(padlist)[0];
1416     AV *comppad = (AV*)AvARRAY(padlist)[1];
1417     SV **namepad = AvARRAY(comppad_name);
1418     SV **curpad = AvARRAY(comppad);
1419     for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
1420         SV *namesv = namepad[ix];
1421         if (namesv && namesv != &PL_sv_undef
1422             && *SvPVX(namesv) == '&')
1423         {
1424             CV *innercv = (CV*)curpad[ix];
1425             assert(CvWEAKOUTSIDE(innercv));
1426             assert(CvOUTSIDE(innercv) == old_cv);
1427             CvOUTSIDE(innercv) = new_cv;
1428         }
1429     }
1430 }
1431
1432
1433 /*
1434 =for apidoc pad_push
1435
1436 Push a new pad frame onto the padlist, unless there's already a pad at
1437 this depth, in which case don't bother creating a new one.
1438 If has_args is true, give the new pad an @_ in slot zero.
1439
1440 =cut
1441 */
1442
1443 void
1444 Perl_pad_push(pTHX_ PADLIST *padlist, int depth, int has_args)
1445 {
1446     if (depth <= AvFILLp(padlist))
1447         return;
1448
1449     {
1450         SV** svp = AvARRAY(padlist);
1451         AV *newpad = newAV();
1452         SV **oldpad = AvARRAY(svp[depth-1]);
1453         I32 ix = AvFILLp((AV*)svp[1]);
1454         I32 names_fill = AvFILLp((AV*)svp[0]);
1455         SV** names = AvARRAY(svp[0]);
1456         SV* sv;
1457         for ( ;ix > 0; ix--) {
1458             if (names_fill >= ix && names[ix] != &PL_sv_undef) {
1459                 char *name = SvPVX(names[ix]);
1460                 if ((SvFLAGS(names[ix]) & SVf_FAKE) || *name == '&') {
1461                     /* outer lexical or anon code */
1462                     av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
1463                 }
1464                 else {          /* our own lexical */
1465                     if (*name == '@')
1466                         av_store(newpad, ix, sv = (SV*)newAV());
1467                     else if (*name == '%')
1468                         av_store(newpad, ix, sv = (SV*)newHV());
1469                     else
1470                         av_store(newpad, ix, sv = NEWSV(0, 0));
1471                     SvPADMY_on(sv);
1472                 }
1473             }
1474             else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
1475                 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
1476             }
1477             else {
1478                 /* save temporaries on recursion? */
1479                 av_store(newpad, ix, sv = NEWSV(0, 0));
1480                 SvPADTMP_on(sv);
1481             }
1482         }
1483         if (has_args) {
1484             AV* av = newAV();
1485             av_extend(av, 0);
1486             av_store(newpad, 0, (SV*)av);
1487             AvFLAGS(av) = AVf_REIFY;
1488         }
1489         av_store(padlist, depth, (SV*)newpad);
1490         AvFILLp(padlist) = depth;
1491     }
1492 }