pad.c

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