pad.c

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