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