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_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_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 (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 (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             /*EMPTY*/;   /* 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", sv);
1035         }
1036     }
1037     /* "Deintroduce" my variables that are leaving with this scope. */
1038     for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
1039         const SV * const sv = svp[off];
1040         if (sv && sv != &PL_sv_undef && !SvFAKE(sv) && SvIVX(sv) == PAD_MAX) {
1041             SvIV_set(sv, PL_cop_seqmax);
1042             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1043                 "Pad leavemy: %ld \"%s\", (%ld,%ld)\n",
1044                 (long)off, SvPVX_const(sv),
1045                 (long)U_32(SvNVX(sv)), (long)SvIVX(sv))
1046             );
1047         }
1048     }
1049     PL_cop_seqmax++;
1050     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1051             "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1052 }
1053
1054
1055 /*
1056 =for apidoc pad_swipe
1057
1058 Abandon the tmp in the current pad at offset po and replace with a
1059 new one.
1060
1061 =cut
1062 */
1063
1064 void
1065 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1066 {
1067     dVAR;
1068     ASSERT_CURPAD_LEGAL("pad_swipe");
1069     if (!PL_curpad)
1070         return;
1071     if (AvARRAY(PL_comppad) != PL_curpad)
1072         Perl_croak(aTHX_ "panic: pad_swipe curpad");
1073     if (!po)
1074         Perl_croak(aTHX_ "panic: pad_swipe po");
1075
1076     DEBUG_X(PerlIO_printf(Perl_debug_log,
1077                 "Pad 0x%"UVxf"[0x%"UVxf"] swipe:   %ld\n",
1078                 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1079
1080     if (PL_curpad[po])
1081         SvPADTMP_off(PL_curpad[po]);
1082     if (refadjust)
1083         SvREFCNT_dec(PL_curpad[po]);
1084
1085
1086     /* if pad tmps aren't shared between ops, then there's no need to
1087      * create a new tmp when an existing op is freed */
1088 #ifdef USE_BROKEN_PAD_RESET
1089     PL_curpad[po] = newSV(0);
1090     SvPADTMP_on(PL_curpad[po]);
1091 #else
1092     PL_curpad[po] = &PL_sv_undef;
1093 #endif
1094     if ((I32)po < PL_padix)
1095         PL_padix = po - 1;
1096 }
1097
1098
1099 /*
1100 =for apidoc pad_reset
1101
1102 Mark all the current temporaries for reuse
1103
1104 =cut
1105 */
1106
1107 /* XXX pad_reset() is currently disabled because it results in serious bugs.
1108  * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
1109  * on the stack by OPs that use them, there are several ways to get an alias
1110  * to  a shared TARG.  Such an alias will change randomly and unpredictably.
1111  * We avoid doing this until we can think of a Better Way.
1112  * GSAR 97-10-29 */
1113 void
1114 Perl_pad_reset(pTHX)
1115 {
1116     dVAR;
1117 #ifdef USE_BROKEN_PAD_RESET
1118     if (AvARRAY(PL_comppad) != PL_curpad)
1119         Perl_croak(aTHX_ "panic: pad_reset curpad");
1120
1121     DEBUG_X(PerlIO_printf(Perl_debug_log,
1122             "Pad 0x%"UVxf"[0x%"UVxf"] reset:     padix %ld -> %ld",
1123             PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1124                 (long)PL_padix, (long)PL_padix_floor
1125             )
1126     );
1127
1128     if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
1129         register I32 po;
1130         for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
1131             if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
1132                 SvPADTMP_off(PL_curpad[po]);
1133         }
1134         PL_padix = PL_padix_floor;
1135     }
1136 #endif
1137     PL_pad_reset_pending = FALSE;
1138 }
1139
1140
1141 /*
1142 =for apidoc pad_tidy
1143
1144 Tidy up a pad after we've finished compiling it:
1145     * remove most stuff from the pads of anonsub prototypes;
1146     * give it a @_;
1147     * mark tmps as such.
1148
1149 =cut
1150 */
1151
1152 /* XXX DAPM surely most of this stuff should be done properly
1153  * at the right time beforehand, rather than going around afterwards
1154  * cleaning up our mistakes ???
1155  */
1156
1157 void
1158 Perl_pad_tidy(pTHX_ padtidy_type type)
1159 {
1160     dVAR;
1161
1162     ASSERT_CURPAD_ACTIVE("pad_tidy");
1163
1164     /* If this CV has had any 'eval-capable' ops planted in it
1165      * (ie it contains eval '...', //ee, /$var/ or /(?{..})/), Then any
1166      * anon prototypes in the chain of CVs should be marked as cloneable,
1167      * so that for example the eval's CV in C<< sub { eval '$x' } >> gets
1168      * the right CvOUTSIDE.
1169      * If running with -d, *any* sub may potentially have an eval
1170      * excuted within it.
1171      */
1172
1173     if (PL_cv_has_eval || PL_perldb) {
1174         const CV *cv;
1175         for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1176             if (cv != PL_compcv && CvCOMPILED(cv))
1177                 break; /* no need to mark already-compiled code */
1178             if (CvANON(cv)) {
1179                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1180                     "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1181                 CvCLONE_on(cv);
1182             }
1183         }
1184     }
1185
1186     /* extend curpad to match namepad */
1187     if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1188         av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1189
1190     if (type == padtidy_SUBCLONE) {
1191         SV * const * const namep = AvARRAY(PL_comppad_name);
1192         PADOFFSET ix;
1193
1194         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1195             SV *namesv;
1196
1197             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1198                 continue;
1199             /*
1200              * The only things that a clonable function needs in its
1201              * pad are anonymous subs.
1202              * The rest are created anew during cloning.
1203              */
1204             if (!((namesv = namep[ix]) != NULL &&
1205                   namesv != &PL_sv_undef &&
1206                    *SvPVX_const(namesv) == '&'))
1207             {
1208                 SvREFCNT_dec(PL_curpad[ix]);
1209                 PL_curpad[ix] = NULL;
1210             }
1211         }
1212     }
1213     else if (type == padtidy_SUB) {
1214         /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1215         AV * const av = newAV();                        /* Will be @_ */
1216         av_extend(av, 0);
1217         av_store(PL_comppad, 0, (SV*)av);
1218         AvREIFY_only(av);
1219     }
1220
1221     /* XXX DAPM rationalise these two similar branches */
1222
1223     if (type == padtidy_SUB) {
1224         PADOFFSET ix;
1225         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1226             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1227                 continue;
1228             if (!SvPADMY(PL_curpad[ix]))
1229                 SvPADTMP_on(PL_curpad[ix]);
1230         }
1231     }
1232     else if (type == padtidy_FORMAT) {
1233         PADOFFSET ix;
1234         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1235             if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
1236                 SvPADTMP_on(PL_curpad[ix]);
1237         }
1238     }
1239     PL_curpad = AvARRAY(PL_comppad);
1240 }
1241
1242
1243 /*
1244 =for apidoc pad_free
1245
1246 Free the SV at offset po in the current pad.
1247
1248 =cut
1249 */
1250
1251 /* XXX DAPM integrate with pad_swipe ???? */
1252 void
1253 Perl_pad_free(pTHX_ PADOFFSET po)
1254 {
1255     dVAR;
1256     ASSERT_CURPAD_LEGAL("pad_free");
1257     if (!PL_curpad)
1258         return;
1259     if (AvARRAY(PL_comppad) != PL_curpad)
1260         Perl_croak(aTHX_ "panic: pad_free curpad");
1261     if (!po)
1262         Perl_croak(aTHX_ "panic: pad_free po");
1263
1264     DEBUG_X(PerlIO_printf(Perl_debug_log,
1265             "Pad 0x%"UVxf"[0x%"UVxf"] free:    %ld\n",
1266             PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1267     );
1268
1269     if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
1270         SvPADTMP_off(PL_curpad[po]);
1271 #ifdef USE_ITHREADS
1272         /* SV could be a shared hash key (eg bugid #19022) */
1273         if (
1274 #ifdef PERL_OLD_COPY_ON_WRITE
1275             !SvIsCOW(PL_curpad[po])
1276 #else
1277             !SvFAKE(PL_curpad[po])
1278 #endif
1279             )
1280             SvREADONLY_off(PL_curpad[po]);      /* could be a freed constant */
1281 #endif
1282     }
1283     if ((I32)po < PL_padix)
1284         PL_padix = po - 1;
1285 }
1286
1287
1288
1289 /*
1290 =for apidoc do_dump_pad
1291
1292 Dump the contents of a padlist
1293
1294 =cut
1295 */
1296
1297 void
1298 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1299 {
1300     dVAR;
1301     const AV *pad_name;
1302     const AV *pad;
1303     SV **pname;
1304     SV **ppad;
1305     I32 ix;
1306
1307     if (!padlist) {
1308         return;
1309     }
1310     pad_name = (AV*)*av_fetch((AV*)padlist, 0, FALSE);
1311     pad = (AV*)*av_fetch((AV*)padlist, 1, FALSE);
1312     pname = AvARRAY(pad_name);
1313     ppad = AvARRAY(pad);
1314     Perl_dump_indent(aTHX_ level, file,
1315             "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1316             PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1317     );
1318
1319     for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1320         const SV *namesv = pname[ix];
1321         if (namesv && namesv == &PL_sv_undef) {
1322             namesv = NULL;
1323         }
1324         if (namesv) {
1325             if (SvFAKE(namesv))
1326                 Perl_dump_indent(aTHX_ level+1, file,
1327                     "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1328                     (int) ix,
1329                     PTR2UV(ppad[ix]),
1330                     (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1331                     SvPVX_const(namesv),
1332                     (unsigned long)SvIVX(namesv),
1333                     (unsigned long)SvNVX(namesv)
1334
1335                 );
1336             else
1337                 Perl_dump_indent(aTHX_ level+1, file,
1338                     "%2d. 0x%"UVxf"<%lu> (%ld,%ld) \"%s\"\n",
1339                     (int) ix,
1340                     PTR2UV(ppad[ix]),
1341                     (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1342                     (long)U_32(SvNVX(namesv)),
1343                     (long)SvIVX(namesv),
1344                     SvPVX_const(namesv)
1345                 );
1346         }
1347         else if (full) {
1348             Perl_dump_indent(aTHX_ level+1, file,
1349                 "%2d. 0x%"UVxf"<%lu>\n",
1350                 (int) ix,
1351                 PTR2UV(ppad[ix]),
1352                 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1353             );
1354         }
1355     }
1356 }
1357
1358
1359
1360 /*
1361 =for apidoc cv_dump
1362
1363 dump the contents of a CV
1364
1365 =cut
1366 */
1367
1368 #ifdef DEBUGGING
1369 STATIC void
1370 S_cv_dump(pTHX_ const CV *cv, const char *title)
1371 {
1372     dVAR;
1373     const CV * const outside = CvOUTSIDE(cv);
1374     AV* const padlist = CvPADLIST(cv);
1375
1376     PerlIO_printf(Perl_debug_log,
1377                   "  %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1378                   title,
1379                   PTR2UV(cv),
1380                   (CvANON(cv) ? "ANON"
1381                    : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1382                    : (cv == PL_main_cv) ? "MAIN"
1383                    : CvUNIQUE(cv) ? "UNIQUE"
1384                    : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1385                   PTR2UV(outside),
1386                   (!outside ? "null"
1387                    : CvANON(outside) ? "ANON"
1388                    : (outside == PL_main_cv) ? "MAIN"
1389                    : CvUNIQUE(outside) ? "UNIQUE"
1390                    : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1391
1392     PerlIO_printf(Perl_debug_log,
1393                     "    PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1394     do_dump_pad(1, Perl_debug_log, padlist, 1);
1395 }
1396 #endif /* DEBUGGING */
1397
1398
1399
1400
1401
1402 /*
1403 =for apidoc cv_clone
1404
1405 Clone a CV: make a new CV which points to the same code etc, but which
1406 has a newly-created pad built by copying the prototype pad and capturing
1407 any outer lexicals.
1408
1409 =cut
1410 */
1411
1412 CV *
1413 Perl_cv_clone(pTHX_ CV *proto)
1414 {
1415     dVAR;
1416     I32 ix;
1417     AV* const protopadlist = CvPADLIST(proto);
1418     const AV* const protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
1419     const AV* const protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
1420     SV** const pname = AvARRAY(protopad_name);
1421     SV** const ppad = AvARRAY(protopad);
1422     const I32 fname = AvFILLp(protopad_name);
1423     const I32 fpad = AvFILLp(protopad);
1424     CV* cv;
1425     SV** outpad;
1426     CV* outside;
1427     long depth;
1428
1429     assert(!CvUNIQUE(proto));
1430
1431     /* Since cloneable anon subs can be nested, CvOUTSIDE may point
1432      * to a prototype; we instead want the cloned parent who called us.
1433      * Note that in general for formats, CvOUTSIDE != find_runcv */
1434
1435     outside = CvOUTSIDE(proto);
1436     if (outside && CvCLONE(outside) && ! CvCLONED(outside))
1437         outside = find_runcv(NULL);
1438     depth = CvDEPTH(outside);
1439     assert(depth || SvTYPE(proto) == SVt_PVFM);
1440     if (!depth)
1441         depth = 1;
1442     assert(CvPADLIST(outside));
1443
1444     ENTER;
1445     SAVESPTR(PL_compcv);
1446
1447     cv = PL_compcv = (CV*)newSV(0);
1448     sv_upgrade((SV *)cv, SvTYPE(proto));
1449     CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE);
1450     CvCLONED_on(cv);
1451
1452 #ifdef USE_ITHREADS
1453     CvFILE(cv)          = CvISXSUB(proto) ? CvFILE(proto)
1454                                           : savepv(CvFILE(proto));
1455 #else
1456     CvFILE(cv)          = CvFILE(proto);
1457 #endif
1458     CvGV(cv)            = CvGV(proto);
1459     CvSTASH(cv)         = CvSTASH(proto);
1460     OP_REFCNT_LOCK;
1461     CvROOT(cv)          = OpREFCNT_inc(CvROOT(proto));
1462     OP_REFCNT_UNLOCK;
1463     CvSTART(cv)         = CvSTART(proto);
1464     CvOUTSIDE(cv)       = (CV*)SvREFCNT_inc_simple(outside);
1465     CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
1466
1467     if (SvPOK(proto))
1468         sv_setpvn((SV*)cv, SvPVX_const(proto), SvCUR(proto));
1469
1470     CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
1471
1472     av_fill(PL_comppad, fpad);
1473     for (ix = fname; ix >= 0; ix--)
1474         av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
1475
1476     PL_curpad = AvARRAY(PL_comppad);
1477
1478     outpad = AvARRAY(AvARRAY(CvPADLIST(outside))[depth]);
1479
1480     for (ix = fpad; ix > 0; ix--) {
1481         SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
1482         SV *sv = NULL;
1483         if (namesv && namesv != &PL_sv_undef) { /* lexical */
1484             if (SvFAKE(namesv)) {   /* lexical from outside? */
1485                 sv = outpad[(I32)SvNVX(namesv)];
1486                 assert(sv);
1487                 /* formats may have an inactive parent */
1488                 if (SvTYPE(proto) == SVt_PVFM && SvPADSTALE(sv)) {
1489                     if (ckWARN(WARN_CLOSURE))
1490                         Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
1491                             "Variable \"%s\" is not available", SvPVX_const(namesv));
1492                     sv = NULL;
1493                 }
1494                 else {
1495                     assert(!SvPADSTALE(sv));
1496                     SvREFCNT_inc_simple_void(sv);
1497                 }
1498             }
1499             if (!sv) {
1500                 const char sigil = SvPVX_const(namesv)[0];
1501                 if (sigil == '&')
1502                     sv = SvREFCNT_inc(ppad[ix]);
1503                 else if (sigil == '@')
1504                     sv = (SV*)newAV();
1505                 else if (sigil == '%')
1506                     sv = (SV*)newHV();
1507                 else
1508                     sv = newSV(0);
1509                 SvPADMY_on(sv);
1510             }
1511         }
1512         else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
1513             sv = SvREFCNT_inc(ppad[ix]);
1514         }
1515         else {
1516             sv = newSV(0);
1517             SvPADTMP_on(sv);
1518         }
1519         PL_curpad[ix] = sv;
1520     }
1521
1522     DEBUG_Xv(
1523         PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
1524         cv_dump(outside, "Outside");
1525         cv_dump(proto,   "Proto");
1526         cv_dump(cv,      "To");
1527     );
1528
1529     LEAVE;
1530
1531     if (CvCONST(cv)) {
1532         /* Constant sub () { $x } closing over $x - see lib/constant.pm:
1533          * The prototype was marked as a candiate for const-ization,
1534          * so try to grab the current const value, and if successful,
1535          * turn into a const sub:
1536          */
1537         SV* const const_sv = op_const_sv(CvSTART(cv), cv);
1538         if (const_sv) {
1539             SvREFCNT_dec(cv);
1540             cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
1541         }
1542         else {
1543             CvCONST_off(cv);
1544         }
1545     }
1546
1547     return cv;
1548 }
1549
1550
1551 /*
1552 =for apidoc pad_fixup_inner_anons
1553
1554 For any anon CVs in the pad, change CvOUTSIDE of that CV from
1555 old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
1556 moved to a pre-existing CV struct.
1557
1558 =cut
1559 */
1560
1561 void
1562 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
1563 {
1564     dVAR;
1565     I32 ix;
1566     AV * const comppad_name = (AV*)AvARRAY(padlist)[0];
1567     AV * const comppad = (AV*)AvARRAY(padlist)[1];
1568     SV ** const namepad = AvARRAY(comppad_name);
1569     SV ** const curpad = AvARRAY(comppad);
1570     PERL_UNUSED_ARG(old_cv);
1571
1572     for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
1573         const SV * const namesv = namepad[ix];
1574         if (namesv && namesv != &PL_sv_undef
1575             && *SvPVX_const(namesv) == '&')
1576         {
1577             CV * const innercv = (CV*)curpad[ix];
1578             assert(CvWEAKOUTSIDE(innercv));
1579             assert(CvOUTSIDE(innercv) == old_cv);
1580             CvOUTSIDE(innercv) = new_cv;
1581         }
1582     }
1583 }
1584
1585
1586 /*
1587 =for apidoc pad_push
1588
1589 Push a new pad frame onto the padlist, unless there's already a pad at
1590 this depth, in which case don't bother creating a new one.  Then give
1591 the new pad an @_ in slot zero.
1592
1593 =cut
1594 */
1595
1596 void
1597 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
1598 {
1599     dVAR;
1600     if (depth > AvFILLp(padlist)) {
1601         SV** const svp = AvARRAY(padlist);
1602         AV* const newpad = newAV();
1603         SV** const oldpad = AvARRAY(svp[depth-1]);
1604         I32 ix = AvFILLp((AV*)svp[1]);
1605         const I32 names_fill = AvFILLp((AV*)svp[0]);
1606         SV** const names = AvARRAY(svp[0]);
1607         AV *av;
1608
1609         for ( ;ix > 0; ix--) {
1610             if (names_fill >= ix && names[ix] != &PL_sv_undef) {
1611                 const char sigil = SvPVX_const(names[ix])[0];
1612                 if ((SvFLAGS(names[ix]) & SVf_FAKE) || sigil == '&') {
1613                     /* outer lexical or anon code */
1614                     av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
1615                 }
1616                 else {          /* our own lexical */
1617                     SV *sv;
1618                     if (sigil == '@')
1619                         sv = (SV*)newAV();
1620                     else if (sigil == '%')
1621                         sv = (SV*)newHV();
1622                     else
1623                         sv = newSV(0);
1624                     av_store(newpad, ix, sv);
1625                     SvPADMY_on(sv);
1626                 }
1627             }
1628             else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
1629                 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
1630             }
1631             else {
1632                 /* save temporaries on recursion? */
1633                 SV * const sv = newSV(0);
1634                 av_store(newpad, ix, sv);
1635                 SvPADTMP_on(sv);
1636             }
1637         }
1638         av = newAV();
1639         av_extend(av, 0);
1640         av_store(newpad, 0, (SV*)av);
1641         AvREIFY_only(av);
1642
1643         av_store(padlist, depth, (SV*)newpad);
1644         AvFILLp(padlist) = depth;
1645     }
1646 }
1647
1648
1649 HV *
1650 Perl_pad_compname_type(pTHX_ const PADOFFSET po)
1651 {
1652     dVAR;
1653     SV* const * const av = av_fetch(PL_comppad_name, po, FALSE);
1654     if ( SvPAD_TYPED(*av) ) {
1655         return SvSTASH(*av);
1656     }
1657     return NULL;
1658 }
1659
1660 /*
1661  * Local variables:
1662  * c-indentation-style: bsd
1663  * c-basic-offset: 4
1664  * indent-tabs-mode: t
1665  * End:
1666  *
1667  * ex: set ts=8 sts=4 sw=4 noet:
1668  */