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