pad.c

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