pad.c

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