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