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