pad.c

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