pad.c

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