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