pad.c

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