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