pad.c

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