pad.c

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