pad.c

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