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