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 SVs_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, SVs_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; /* XXX not threadsafe */
 136     PERL_UNUSED_ARG(s);
 137
 138     PERL_ARGS_ASSERT_PAD_PEG;
 139
 140     pegcnt++;
 141 }
 142 #endif
 143
 144 /*
 145 =for apidoc pad_new
 146
 147 Create a new compiling padlist, saving and updating the various global
 148 vars at the same time as creating the pad itself. The following flags
 149 can be OR'ed together:
 150
 151     padnew_CLONE        this pad is for a cloned CV
 152     padnew_SAVE         save old globals
 153     padnew_SAVESUB      also save extra stuff for start of sub
 154
 155 =cut
 156 */
 157
 158 PADLIST *
 159 Perl_pad_new(pTHX_ int flags)
 160 {
 161     dVAR;
 162     AV *padlist, *padname, *pad;
 163
 164     ASSERT_CURPAD_LEGAL("pad_new");
 165
 166     /* XXX DAPM really need a new SAVEt_PAD which restores all or most
 167      * vars (based on flags) rather than storing vals + addresses for
 168      * each individually. Also see pad_block_start.
 169      * XXX DAPM Try to see whether all these conditionals are required
 170      */
 171
 172     /* save existing state, ... */
 173
 174     if (flags & padnew_SAVE) {
 175         SAVECOMPPAD();
 176         SAVESPTR(PL_comppad_name);
 177         if (! (flags & padnew_CLONE)) {
 178             SAVEI32(PL_padix);
 179             SAVEI32(PL_comppad_name_fill);
 180             SAVEI32(PL_min_intro_pending);
 181             SAVEI32(PL_max_intro_pending);
 182             SAVEBOOL(PL_cv_has_eval);
 183             if (flags & padnew_SAVESUB) {
 184                 SAVEBOOL(PL_pad_reset_pending);
 185             }
 186         }
 187     }
 188     /* XXX DAPM interestingly, PL_comppad_name_floor never seems to be
 189      * saved - check at some pt that this is okay */
 190
 191     /* ... create new pad ... */
 192
 193     padlist     = newAV();
 194     padname     = newAV();
 195     pad         = newAV();
 196
 197     if (flags & padnew_CLONE) {
 198         /* XXX DAPM  I dont know why cv_clone needs it
 199          * doing differently yet - perhaps this separate branch can be
 200          * dispensed with eventually ???
 201          */
 202
 203         AV * const a0 = newAV();                        /* will be @_ */
 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 static PADOFFSET
 343 S_pad_add_name_sv(pTHX_ SV *namesv, const U32 flags, HV *typestash,
 344                   HV *ourstash)
 345 {
 346     dVAR;
 347     const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
 348
 349     PERL_ARGS_ASSERT_PAD_ADD_NAME_SV;
 350
 351     ASSERT_CURPAD_ACTIVE("pad_add_name");
 352
 353     if (typestash) {
 354         assert(SvTYPE(namesv) == SVt_PVMG);
 355         SvPAD_TYPED_on(namesv);
 356         SvSTASH_set(namesv, MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash))));
 357     }
 358     if (ourstash) {
 359         SvPAD_OUR_on(namesv);
 360         SvOURSTASH_set(namesv, ourstash);
 361         SvREFCNT_inc_simple_void_NN(ourstash);
 362     }
 363     else if (flags & padadd_STATE) {
 364         SvPAD_STATE_on(namesv);
 365     }
 366
 367     av_store(PL_comppad_name, offset, namesv);
 368     return offset;
 369 }
 370
 371 /*
 372 =for apidoc pad_add_name
 373
 374 Create a new name and associated PADMY SV in the current pad; return the
 375 offset.
 376 If C<typestash> is valid, the name is for a typed lexical; set the
 377 name's stash to that value.
 378 If C<ourstash> is valid, it's an our lexical, set the name's
 379 SvOURSTASH to that value
 380
 381 If fake, it means we're cloning an existing entry
 382
 383 =cut
 384 */
 385
 386 PADOFFSET
 387 Perl_pad_add_name(pTHX_ const char *name, const STRLEN len, const U32 flags,
 388                   HV *typestash, HV *ourstash)
 389 {
 390     dVAR;
 391     PADOFFSET offset;
 392     SV *namesv;
 393
 394     PERL_ARGS_ASSERT_PAD_ADD_NAME;
 395
 396     if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK))
 397         Perl_croak(aTHX_ "panic: pad_add_name illegal flag bits 0x%" UVxf,
 398                    (UV)flags);
 399
 400     namesv = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV);
 401
 402     /* Until we're using the length for real, cross check that we're being told
 403        the truth.  */
 404     PERL_UNUSED_ARG(len);
 405     assert(strlen(name) == len);
 406
 407     sv_setpv(namesv, name);
 408
 409     if ((flags & padadd_NO_DUP_CHECK) == 0) {
 410         /* check for duplicate declaration */
 411         pad_check_dup(namesv, flags & padadd_OUR, ourstash);
 412     }
 413
 414     offset = pad_add_name_sv(namesv, flags, typestash, ourstash);
 415
 416     /* not yet introduced */
 417     COP_SEQ_RANGE_LOW_set(namesv, PAD_MAX);     /* min */
 418     COP_SEQ_RANGE_HIGH_set(namesv, 0);          /* max */
 419
 420     if (!PL_min_intro_pending)
 421         PL_min_intro_pending = offset;
 422     PL_max_intro_pending = offset;
 423     /* if it's not a simple scalar, replace with an AV or HV */
 424     assert(SvTYPE(PL_curpad[offset]) == SVt_NULL);
 425     assert(SvREFCNT(PL_curpad[offset]) == 1);
 426     if (*name == '@')
 427         sv_upgrade(PL_curpad[offset], SVt_PVAV);
 428     else if (*name == '%')
 429         sv_upgrade(PL_curpad[offset], SVt_PVHV);
 430     assert(SvPADMY(PL_curpad[offset]));
 431     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 432                            "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
 433                            (long)offset, name, PTR2UV(PL_curpad[offset])));
 434
 435     return offset;
 436 }
 437
 438
 439
 440
 441 /*
 442 =for apidoc pad_alloc
 443
 444 Allocate a new my or tmp pad entry. For a my, simply push a null SV onto
 445 the end of PL_comppad, but for a tmp, scan the pad from PL_padix upwards
 446 for a slot which has no name and no active value.
 447
 448 =cut
 449 */
 450
 451 /* XXX DAPM integrate alloc(), add_name() and add_anon(),
 452  * or at least rationalise ??? */
 453 /* And flag whether the incoming name is UTF8 or 8 bit?
 454    Could do this either with the +ve/-ve hack of the HV code, or expanding
 455    the flag bits. Either way, this makes proper Unicode safe pad support.
 456    NWC
 457 */
 458
 459 PADOFFSET
 460 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
 461 {
 462     dVAR;
 463     SV *sv;
 464     I32 retval;
 465
 466     PERL_UNUSED_ARG(optype);
 467     ASSERT_CURPAD_ACTIVE("pad_alloc");
 468
 469     if (AvARRAY(PL_comppad) != PL_curpad)
 470         Perl_croak(aTHX_ "panic: pad_alloc");
 471     if (PL_pad_reset_pending)
 472         pad_reset();
 473     if (tmptype & SVs_PADMY) {
 474         sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
 475         retval = AvFILLp(PL_comppad);
 476     }
 477     else {
 478         SV * const * const names = AvARRAY(PL_comppad_name);
 479         const SSize_t names_fill = AvFILLp(PL_comppad_name);
 480         for (;;) {
 481             /*
 482              * "foreach" index vars temporarily become aliases to non-"my"
 483              * values.  Thus we must skip, not just pad values that are
 484              * marked as current pad values, but also those with names.
 485              */
 486             /* HVDS why copy to sv here? we don't seem to use it */
 487             if (++PL_padix <= names_fill &&
 488                    (sv = names[PL_padix]) && sv != &PL_sv_undef)
 489                 continue;
 490             sv = *av_fetch(PL_comppad, PL_padix, TRUE);
 491             if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) &&
 492                 !IS_PADGV(sv) && !IS_PADCONST(sv))
 493                 break;
 494         }
 495         retval = PL_padix;
 496     }
 497     SvFLAGS(sv) |= tmptype;
 498     PL_curpad = AvARRAY(PL_comppad);
 499
 500     DEBUG_X(PerlIO_printf(Perl_debug_log,
 501           "Pad 0x%"UVxf"[0x%"UVxf"] alloc:   %ld for %s\n",
 502           PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
 503           PL_op_name[optype]));
 504 #ifdef DEBUG_LEAKING_SCALARS
 505     sv->sv_debug_optype = optype;
 506     sv->sv_debug_inpad = 1;
 507 #endif
 508     return (PADOFFSET)retval;
 509 }
 510
 511 /*
 512 =for apidoc pad_add_anon
 513
 514 Add an anon code entry to the current compiling pad
 515
 516 =cut
 517 */
 518
 519 PADOFFSET
 520 Perl_pad_add_anon(pTHX_ SV* sv, OPCODE op_type)
 521 {
 522     dVAR;
 523     PADOFFSET ix;
 524     SV* const name = newSV_type(SVt_PVNV);
 525
 526     PERL_ARGS_ASSERT_PAD_ADD_ANON;
 527
 528     pad_peg("add_anon");
 529     sv_setpvs(name, "&");
 530     /* Are these two actually ever read? */
 531     COP_SEQ_RANGE_HIGH_set(name, ~0);
 532     COP_SEQ_RANGE_LOW_set(name, 1);
 533     ix = pad_alloc(op_type, SVs_PADMY);
 534     av_store(PL_comppad_name, ix, name);
 535     /* XXX DAPM use PL_curpad[] ? */
 536     av_store(PL_comppad, ix, sv);
 537     SvPADMY_on(sv);
 538
 539     /* to avoid ref loops, we never have parent + child referencing each
 540      * other simultaneously */
 541     if (CvOUTSIDE((const CV *)sv)) {
 542         assert(!CvWEAKOUTSIDE((const CV *)sv));
 543         CvWEAKOUTSIDE_on(MUTABLE_CV(sv));
 544         SvREFCNT_dec(CvOUTSIDE(MUTABLE_CV(sv)));
 545     }
 546     return ix;
 547 }
 548
 549
 550
 551 /*
 552 =for apidoc pad_check_dup
 553
 554 Check for duplicate declarations: report any of:
 555      * a my in the current scope with the same name;
 556      * an our (anywhere in the pad) with the same name and the same stash
 557        as C<ourstash>
 558 C<is_our> indicates that the name to check is an 'our' declaration
 559
 560 =cut
 561 */
 562
 563 STATIC void
 564 S_pad_check_dup(pTHX_ SV *name, const U32 flags, const HV *ourstash)
 565 {
 566     dVAR;
 567     SV          **svp;
 568     PADOFFSET   top, off;
 569     const U32   is_our = flags & padadd_OUR;
 570
 571     PERL_ARGS_ASSERT_PAD_CHECK_DUP;
 572
 573     ASSERT_CURPAD_ACTIVE("pad_check_dup");
 574
 575     assert((flags & ~padadd_OUR) == 0);
 576
 577     if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC))
 578         return; /* nothing to check */
 579
 580     svp = AvARRAY(PL_comppad_name);
 581     top = AvFILLp(PL_comppad_name);
 582     /* check the current scope */
 583     /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
 584      * type ? */
 585     for (off = top; (I32)off > PL_comppad_name_floor; off--) {
 586         SV * const sv = svp[off];
 587         if (sv
 588             && sv != &PL_sv_undef
 589             && !SvFAKE(sv)
 590             && (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX || COP_SEQ_RANGE_HIGH(sv) == 0)
 591             && sv_eq(name, sv))
 592         {
 593             if (is_our && (SvPAD_OUR(sv)))
 594                 break; /* "our" masking "our" */
 595             Perl_warner(aTHX_ packWARN(WARN_MISC),
 596                 "\"%s\" variable %"SVf" masks earlier declaration in same %s",
 597                 (is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"),
 598                 sv,
 599                 (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX ? "scope" : "statement"));
 600             --off;
 601             break;
 602         }
 603     }
 604     /* check the rest of the pad */
 605     if (is_our) {
 606         do {
 607             SV * const sv = svp[off];
 608             if (sv
 609                 && sv != &PL_sv_undef
 610                 && !SvFAKE(sv)
 611                 && (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX || COP_SEQ_RANGE_HIGH(sv) == 0)
 612                 && SvOURSTASH(sv) == ourstash
 613                 && sv_eq(name, sv))
 614             {
 615                 Perl_warner(aTHX_ packWARN(WARN_MISC),
 616                     "\"our\" variable %"SVf" redeclared", sv);
 617                 if ((I32)off <= PL_comppad_name_floor)
 618                     Perl_warner(aTHX_ packWARN(WARN_MISC),
 619                         "\t(Did you mean \"local\" instead of \"our\"?)\n");
 620                 break;
 621             }
 622         } while ( off-- > 0 );
 623     }
 624 }
 625
 626
 627 /*
 628 =for apidoc pad_findmy
 629
 630 Given a lexical name, try to find its offset, first in the current pad,
 631 or failing that, in the pads of any lexically enclosing subs (including
 632 the complications introduced by eval). If the name is found in an outer pad,
 633 then a fake entry is added to the current pad.
 634 Returns the offset in the current pad, or NOT_IN_PAD on failure.
 635
 636 =cut
 637 */
 638
 639 PADOFFSET
 640 Perl_pad_findmy(pTHX_ const char *name, STRLEN len, U32 flags)
 641 {
 642     dVAR;
 643     SV *out_sv;
 644     int out_flags;
 645     I32 offset;
 646     const AV *nameav;
 647     SV **name_svp;
 648
 649     PERL_ARGS_ASSERT_PAD_FINDMY;
 650
 651     pad_peg("pad_findmy");
 652
 653     if (flags)
 654         Perl_croak(aTHX_ "panic: pad_findmy illegal flag bits 0x%" UVxf,
 655                    (UV)flags);
 656
 657     /* Yes, it is a bug (read work in progress) that we're not really using this
 658        length parameter, and instead relying on strlen() later on. But I'm not
 659        comfortable about changing the pad API piecemeal to use and rely on
 660        lengths. This only exists to avoid an "unused parameter" warning.  */
 661     if (len < 2)
 662         return NOT_IN_PAD;
 663
 664     /* But until we're using the length for real, cross check that we're being
 665        told the truth.  */
 666     assert(strlen(name) == len);
 667
 668     offset = pad_findlex(name, PL_compcv, PL_cop_seqmax, 1,
 669                 NULL, &out_sv, &out_flags);
 670     if ((PADOFFSET)offset != NOT_IN_PAD)
 671         return offset;
 672
 673     /* look for an our that's being introduced; this allows
 674      *    our $foo = 0 unless defined $foo;
 675      * to not give a warning. (Yes, this is a hack) */
 676
 677     nameav = MUTABLE_AV(AvARRAY(CvPADLIST(PL_compcv))[0]);
 678     name_svp = AvARRAY(nameav);
 679     for (offset = AvFILLp(nameav); offset > 0; offset--) {
 680         const SV * const namesv = name_svp[offset];
 681         if (namesv && namesv != &PL_sv_undef
 682             && !SvFAKE(namesv)
 683             && (SvPAD_OUR(namesv))
 684             && strEQ(SvPVX_const(namesv), name)
 685             && COP_SEQ_RANGE_LOW(namesv) == PAD_MAX /* min */
 686         )
 687             return offset;
 688     }
 689     return NOT_IN_PAD;
 690 }
 691
 692 /*
 693  * Returns the offset of a lexical $_, if there is one, at run time.
 694  * Used by the UNDERBAR XS macro.
 695  */
 696
 697 PADOFFSET
 698 Perl_find_rundefsvoffset(pTHX)
 699 {
 700     dVAR;
 701     SV *out_sv;
 702     int out_flags;
 703     return pad_findlex("$_", find_runcv(NULL), PL_curcop->cop_seq, 1,
 704             NULL, &out_sv, &out_flags);
 705 }
 706
 707 /*
 708  * Returns a lexical $_, if there is one, at run time ; or the global one
 709  * otherwise.
 710  */
 711
 712 SV *
 713 Perl_find_rundefsv(pTHX)
 714 {
 715     SV *namesv;
 716     int flags;
 717     PADOFFSET po;
 718
 719     po = pad_findlex("$_", find_runcv(NULL), PL_curcop->cop_seq, 1,
 720             NULL, &namesv, &flags);
 721
 722     if (po == NOT_IN_PAD
 723         || (SvFLAGS(namesv) & (SVpad_NAME|SVpad_OUR)) == (SVpad_NAME|SVpad_OUR))
 724         return DEFSV;
 725
 726     return PAD_SVl(po);
 727 }
 728
 729 /*
 730 =for apidoc pad_findlex
 731
 732 Find a named lexical anywhere in a chain of nested pads. Add fake entries
 733 in the inner pads if it's found in an outer one.
 734
 735 Returns the offset in the bottom pad of the lex or the fake lex.
 736 cv is the CV in which to start the search, and seq is the current cop_seq
 737 to match against. If warn is true, print appropriate warnings.  The out_*
 738 vars return values, and so are pointers to where the returned values
 739 should be stored. out_capture, if non-null, requests that the innermost
 740 instance of the lexical is captured; out_name_sv is set to the innermost
 741 matched namesv or fake namesv; out_flags returns the flags normally
 742 associated with the IVX field of a fake namesv.
 743
 744 Note that pad_findlex() is recursive; it recurses up the chain of CVs,
 745 then comes back down, adding fake entries as it goes. It has to be this way
 746 because fake namesvs in anon protoypes have to store in xlow the index into
 747 the parent pad.
 748
 749 =cut
 750 */
 751
 752 /* the CV has finished being compiled. This is not a sufficient test for
 753  * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
 754 #define CvCOMPILED(cv)  CvROOT(cv)
 755
 756 /* the CV does late binding of its lexicals */
 757 #define CvLATE(cv) (CvANON(cv) || SvTYPE(cv) == SVt_PVFM)
 758
 759
 760 STATIC PADOFFSET
 761 S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn,
 762         SV** out_capture, SV** out_name_sv, int *out_flags)
 763 {
 764     dVAR;
 765     I32 offset, new_offset;
 766     SV *new_capture;
 767     SV **new_capturep;
 768     const AV * const padlist = CvPADLIST(cv);
 769
 770     PERL_ARGS_ASSERT_PAD_FINDLEX;
 771
 772     *out_flags = 0;
 773
 774     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 775         "Pad findlex cv=0x%"UVxf" searching \"%s\" seq=%d%s\n",
 776         PTR2UV(cv), name, (int)seq, out_capture ? " capturing" : "" ));
 777
 778     /* first, search this pad */
 779
 780     if (padlist) { /* not an undef CV */
 781         I32 fake_offset = 0;
 782         const AV * const nameav = MUTABLE_AV(AvARRAY(padlist)[0]);
 783         SV * const * const name_svp = AvARRAY(nameav);
 784
 785         for (offset = AvFILLp(nameav); offset > 0; offset--) {
 786             const SV * const namesv = name_svp[offset];
 787             if (namesv && namesv != &PL_sv_undef
 788                     && strEQ(SvPVX_const(namesv), name))
 789             {
 790                 if (SvFAKE(namesv))
 791                     fake_offset = offset; /* in case we don't find a real one */
 792                 else if (  seq >  COP_SEQ_RANGE_LOW(namesv)     /* min */
 793                         && seq <= COP_SEQ_RANGE_HIGH(namesv))   /* max */
 794                     break;
 795             }
 796         }
 797
 798         if (offset > 0 || fake_offset > 0 ) { /* a match! */
 799             if (offset > 0) { /* not fake */
 800                 fake_offset = 0;
 801                 *out_name_sv = name_svp[offset]; /* return the namesv */
 802
 803                 /* set PAD_FAKELEX_MULTI if this lex can have multiple
 804                  * instances. For now, we just test !CvUNIQUE(cv), but
 805                  * ideally, we should detect my's declared within loops
 806                  * etc - this would allow a wider range of 'not stayed
 807                  * shared' warnings. We also treated alreadly-compiled
 808                  * lexes as not multi as viewed from evals. */
 809
 810                 *out_flags = CvANON(cv) ?
 811                         PAD_FAKELEX_ANON :
 812                             (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
 813                                 ? PAD_FAKELEX_MULTI : 0;
 814
 815                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 816                     "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n",
 817                     PTR2UV(cv), (long)offset,
 818                     (unsigned long)COP_SEQ_RANGE_LOW(*out_name_sv),
 819                     (unsigned long)COP_SEQ_RANGE_HIGH(*out_name_sv)));
 820             }
 821             else { /* fake match */
 822                 offset = fake_offset;
 823                 *out_name_sv = name_svp[offset]; /* return the namesv */
 824                 *out_flags = PARENT_FAKELEX_FLAGS(*out_name_sv);
 825                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 826                     "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
 827                     PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
 828                     (unsigned long) PARENT_PAD_INDEX(*out_name_sv)
 829                 ));
 830             }
 831
 832             /* return the lex? */
 833
 834             if (out_capture) {
 835
 836                 /* our ? */
 837                 if (SvPAD_OUR(*out_name_sv)) {
 838                     *out_capture = NULL;
 839                     return offset;
 840                 }
 841
 842                 /* trying to capture from an anon prototype? */
 843                 if (CvCOMPILED(cv)
 844                         ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
 845                         : *out_flags & PAD_FAKELEX_ANON)
 846                 {
 847                     if (warn)
 848                         Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
 849                                        "Variable \"%s\" is not available", name);
 850                     *out_capture = NULL;
 851                 }
 852
 853                 /* real value */
 854                 else {
 855                     int newwarn = warn;
 856                     if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
 857                          && !SvPAD_STATE(name_svp[offset])
 858                          && warn && ckWARN(WARN_CLOSURE)) {
 859                         newwarn = 0;
 860                         Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
 861                             "Variable \"%s\" will not stay shared", name);
 862                     }
 863
 864                     if (fake_offset && CvANON(cv)
 865                             && CvCLONE(cv) &&!CvCLONED(cv))
 866                     {
 867                         SV *n;
 868                         /* not yet caught - look further up */
 869                         DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 870                             "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
 871                             PTR2UV(cv)));
 872                         n = *out_name_sv;
 873                         (void) pad_findlex(name, CvOUTSIDE(cv),
 874                             CvOUTSIDE_SEQ(cv),
 875                             newwarn, out_capture, out_name_sv, out_flags);
 876                         *out_name_sv = n;
 877                         return offset;
 878                     }
 879
 880                     *out_capture = AvARRAY(MUTABLE_AV(AvARRAY(padlist)[
 881                                     CvDEPTH(cv) ? CvDEPTH(cv) : 1]))[offset];
 882                     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 883                         "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
 884                         PTR2UV(cv), PTR2UV(*out_capture)));
 885
 886                     if (SvPADSTALE(*out_capture)
 887                         && !SvPAD_STATE(name_svp[offset]))
 888                     {
 889                         Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
 890                                        "Variable \"%s\" is not available", name);
 891                         *out_capture = NULL;
 892                     }
 893                 }
 894                 if (!*out_capture) {
 895                     if (*name == '@')
 896                         *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
 897                     else if (*name == '%')
 898                         *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
 899                     else
 900                         *out_capture = sv_newmortal();
 901                 }
 902             }
 903
 904             return offset;
 905         }
 906     }
 907
 908     /* it's not in this pad - try above */
 909
 910     if (!CvOUTSIDE(cv))
 911         return NOT_IN_PAD;
 912
 913     /* out_capture non-null means caller wants us to capture lex; in
 914      * addition we capture ourselves unless it's an ANON/format */
 915     new_capturep = out_capture ? out_capture :
 916                 CvLATE(cv) ? NULL : &new_capture;
 917
 918     offset = pad_findlex(name, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
 919                 new_capturep, out_name_sv, out_flags);
 920     if ((PADOFFSET)offset == NOT_IN_PAD)
 921         return NOT_IN_PAD;
 922
 923     /* found in an outer CV. Add appropriate fake entry to this pad */
 924
 925     /* don't add new fake entries (via eval) to CVs that we have already
 926      * finished compiling, or to undef CVs */
 927     if (CvCOMPILED(cv) || !padlist)
 928         return 0; /* this dummy (and invalid) value isnt used by the caller */
 929
 930     {
 931         /* This relies on sv_setsv_flags() upgrading the destination to the same
 932            type as the source, independant of the flags set, and on it being
 933            "good" and only copying flag bits and pointers that it understands.
 934         */
 935         SV *new_namesv = newSVsv(*out_name_sv);
 936         AV *  const ocomppad_name = PL_comppad_name;
 937         PAD * const ocomppad = PL_comppad;
 938         PL_comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
 939         PL_comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
 940         PL_curpad = AvARRAY(PL_comppad);
 941
 942         new_offset
 943             = pad_add_name_sv(new_namesv,
 944                               (SvPAD_STATE(*out_name_sv) ? padadd_STATE : 0),
 945                               SvPAD_TYPED(*out_name_sv)
 946                               ? SvSTASH(*out_name_sv) : NULL,
 947                               SvOURSTASH(*out_name_sv)
 948                               );
 949
 950         SvFAKE_on(new_namesv);
 951         DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 952                                "Pad addname: %ld \"%.*s\" FAKE\n",
 953                                (long)new_offset,
 954                                (int) SvCUR(new_namesv), SvPVX(new_namesv)));
 955         PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags);
 956
 957         PARENT_PAD_INDEX_set(new_namesv, 0);
 958         if (SvPAD_OUR(new_namesv)) {
 959             NOOP;   /* do nothing */
 960         }
 961         else if (CvLATE(cv)) {
 962             /* delayed creation - just note the offset within parent pad */
 963             PARENT_PAD_INDEX_set(new_namesv, offset);
 964             CvCLONE_on(cv);
 965         }
 966         else {
 967             /* immediate creation - capture outer value right now */
 968             av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
 969             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 970                 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
 971                 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
 972         }
 973         *out_name_sv = new_namesv;
 974         *out_flags = PARENT_FAKELEX_FLAGS(new_namesv);
 975
 976         PL_comppad_name = ocomppad_name;
 977         PL_comppad = ocomppad;
 978         PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
 979     }
 980     return new_offset;
 981 }
 982
 983
 984 #ifdef DEBUGGING
 985 /*
 986 =for apidoc pad_sv
 987
 988 Get the value at offset po in the current pad.
 989 Use macro PAD_SV instead of calling this function directly.
 990
 991 =cut
 992 */
 993
 994
 995 SV *
 996 Perl_pad_sv(pTHX_ PADOFFSET po)
 997 {
 998     dVAR;
 999     ASSERT_CURPAD_ACTIVE("pad_sv");
1000
1001     if (!po)
1002         Perl_croak(aTHX_ "panic: pad_sv po");
1003     DEBUG_X(PerlIO_printf(Perl_debug_log,
1004         "Pad 0x%"UVxf"[0x%"UVxf"] sv:      %ld sv=0x%"UVxf"\n",
1005         PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
1006     );
1007     return PL_curpad[po];
1008 }
1009
1010
1011 /*
1012 =for apidoc pad_setsv
1013
1014 Set the entry at offset po in the current pad to sv.
1015 Use the macro PAD_SETSV() rather than calling this function directly.
1016
1017 =cut
1018 */
1019
1020 void
1021 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
1022 {
1023     dVAR;
1024
1025     PERL_ARGS_ASSERT_PAD_SETSV;
1026
1027     ASSERT_CURPAD_ACTIVE("pad_setsv");
1028
1029     DEBUG_X(PerlIO_printf(Perl_debug_log,
1030         "Pad 0x%"UVxf"[0x%"UVxf"] setsv:   %ld sv=0x%"UVxf"\n",
1031         PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
1032     );
1033     PL_curpad[po] = sv;
1034 }
1035 #endif
1036
1037
1038
1039 /*
1040 =for apidoc pad_block_start
1041
1042 Update the pad compilation state variables on entry to a new block
1043
1044 =cut
1045 */
1046
1047 /* XXX DAPM perhaps:
1048  *      - integrate this in general state-saving routine ???
1049  *      - combine with the state-saving going on in pad_new ???
1050  *      - introduce a new SAVE type that does all this in one go ?
1051  */
1052
1053 void
1054 Perl_pad_block_start(pTHX_ int full)
1055 {
1056     dVAR;
1057     ASSERT_CURPAD_ACTIVE("pad_block_start");
1058     SAVEI32(PL_comppad_name_floor);
1059     PL_comppad_name_floor = AvFILLp(PL_comppad_name);
1060     if (full)
1061         PL_comppad_name_fill = PL_comppad_name_floor;
1062     if (PL_comppad_name_floor < 0)
1063         PL_comppad_name_floor = 0;
1064     SAVEI32(PL_min_intro_pending);
1065     SAVEI32(PL_max_intro_pending);
1066     PL_min_intro_pending = 0;
1067     SAVEI32(PL_comppad_name_fill);
1068     SAVEI32(PL_padix_floor);
1069     PL_padix_floor = PL_padix;
1070     PL_pad_reset_pending = FALSE;
1071 }
1072
1073
1074 /*
1075 =for apidoc intro_my
1076
1077 "Introduce" my variables to visible status.
1078
1079 =cut
1080 */
1081
1082 U32
1083 Perl_intro_my(pTHX)
1084 {
1085     dVAR;
1086     SV **svp;
1087     I32 i;
1088
1089     ASSERT_CURPAD_ACTIVE("intro_my");
1090     if (! PL_min_intro_pending)
1091         return PL_cop_seqmax;
1092
1093     svp = AvARRAY(PL_comppad_name);
1094     for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1095         SV * const sv = svp[i];
1096
1097         if (sv && sv != &PL_sv_undef && !SvFAKE(sv) && !COP_SEQ_RANGE_HIGH(sv)) {
1098             COP_SEQ_RANGE_HIGH_set(sv, PAD_MAX);        /* Don't know scope end yet. */
1099             COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
1100             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1101                 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1102                 (long)i, SvPVX_const(sv),
1103                 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1104                 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1105             );
1106         }
1107     }
1108     PL_min_intro_pending = 0;
1109     PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1110     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1111                 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax+1)));
1112
1113     return PL_cop_seqmax++;
1114 }
1115
1116 /*
1117 =for apidoc pad_leavemy
1118
1119 Cleanup at end of scope during compilation: set the max seq number for
1120 lexicals in this scope and warn of any lexicals that never got introduced.
1121
1122 =cut
1123 */
1124
1125 void
1126 Perl_pad_leavemy(pTHX)
1127 {
1128     dVAR;
1129     I32 off;
1130     SV * const * const svp = AvARRAY(PL_comppad_name);
1131
1132     PL_pad_reset_pending = FALSE;
1133
1134     ASSERT_CURPAD_ACTIVE("pad_leavemy");
1135     if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1136         for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1137             const SV * const sv = svp[off];
1138             if (sv && sv != &PL_sv_undef && !SvFAKE(sv))
1139                 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1140                                  "%"SVf" never introduced",
1141                                  SVfARG(sv));
1142         }
1143     }
1144     /* "Deintroduce" my variables that are leaving with this scope. */
1145     for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
1146         const SV * const sv = svp[off];
1147         if (sv && sv != &PL_sv_undef && !SvFAKE(sv) && COP_SEQ_RANGE_HIGH(sv) == PAD_MAX) {
1148             COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
1149             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1150                 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1151                 (long)off, SvPVX_const(sv),
1152                 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1153                 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1154             );
1155         }
1156     }
1157     PL_cop_seqmax++;
1158     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1159             "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1160 }
1161
1162
1163 /*
1164 =for apidoc pad_swipe
1165
1166 Abandon the tmp in the current pad at offset po and replace with a
1167 new one.
1168
1169 =cut
1170 */
1171
1172 void
1173 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1174 {
1175     dVAR;
1176     ASSERT_CURPAD_LEGAL("pad_swipe");
1177     if (!PL_curpad)
1178         return;
1179     if (AvARRAY(PL_comppad) != PL_curpad)
1180         Perl_croak(aTHX_ "panic: pad_swipe curpad");
1181     if (!po)
1182         Perl_croak(aTHX_ "panic: pad_swipe po");
1183
1184     DEBUG_X(PerlIO_printf(Perl_debug_log,
1185                 "Pad 0x%"UVxf"[0x%"UVxf"] swipe:   %ld\n",
1186                 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1187
1188     if (PL_curpad[po])
1189         SvPADTMP_off(PL_curpad[po]);
1190     if (refadjust)
1191         SvREFCNT_dec(PL_curpad[po]);
1192
1193
1194     /* if pad tmps aren't shared between ops, then there's no need to
1195      * create a new tmp when an existing op is freed */
1196 #ifdef USE_BROKEN_PAD_RESET
1197     PL_curpad[po] = newSV(0);
1198     SvPADTMP_on(PL_curpad[po]);
1199 #else
1200     PL_curpad[po] = &PL_sv_undef;
1201 #endif
1202     if ((I32)po < PL_padix)
1203         PL_padix = po - 1;
1204 }
1205
1206
1207 /*
1208 =for apidoc pad_reset
1209
1210 Mark all the current temporaries for reuse
1211
1212 =cut
1213 */
1214
1215 /* XXX pad_reset() is currently disabled because it results in serious bugs.
1216  * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
1217  * on the stack by OPs that use them, there are several ways to get an alias
1218  * to  a shared TARG.  Such an alias will change randomly and unpredictably.
1219  * We avoid doing this until we can think of a Better Way.
1220  * GSAR 97-10-29 */
1221 static void
1222 S_pad_reset(pTHX)
1223 {
1224     dVAR;
1225 #ifdef USE_BROKEN_PAD_RESET
1226     if (AvARRAY(PL_comppad) != PL_curpad)
1227         Perl_croak(aTHX_ "panic: pad_reset curpad");
1228
1229     DEBUG_X(PerlIO_printf(Perl_debug_log,
1230             "Pad 0x%"UVxf"[0x%"UVxf"] reset:     padix %ld -> %ld",
1231             PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1232                 (long)PL_padix, (long)PL_padix_floor
1233             )
1234     );
1235
1236     if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
1237         register I32 po;
1238         for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
1239             if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
1240                 SvPADTMP_off(PL_curpad[po]);
1241         }
1242         PL_padix = PL_padix_floor;
1243     }
1244 #endif
1245     PL_pad_reset_pending = FALSE;
1246 }
1247
1248
1249 /*
1250 =for apidoc pad_tidy
1251
1252 Tidy up a pad after we've finished compiling it:
1253     * remove most stuff from the pads of anonsub prototypes;
1254     * give it a @_;
1255     * mark tmps as such.
1256
1257 =cut
1258 */
1259
1260 /* XXX DAPM surely most of this stuff should be done properly
1261  * at the right time beforehand, rather than going around afterwards
1262  * cleaning up our mistakes ???
1263  */
1264
1265 void
1266 Perl_pad_tidy(pTHX_ padtidy_type type)
1267 {
1268     dVAR;
1269
1270     ASSERT_CURPAD_ACTIVE("pad_tidy");
1271
1272     /* If this CV has had any 'eval-capable' ops planted in it
1273      * (ie it contains eval '...', //ee, /$var/ or /(?{..})/), Then any
1274      * anon prototypes in the chain of CVs should be marked as cloneable,
1275      * so that for example the eval's CV in C<< sub { eval '$x' } >> gets
1276      * the right CvOUTSIDE.
1277      * If running with -d, *any* sub may potentially have an eval
1278      * excuted within it.
1279      */
1280
1281     if (PL_cv_has_eval || PL_perldb) {
1282         const CV *cv;
1283         for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1284             if (cv != PL_compcv && CvCOMPILED(cv))
1285                 break; /* no need to mark already-compiled code */
1286             if (CvANON(cv)) {
1287                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1288                     "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1289                 CvCLONE_on(cv);
1290             }
1291         }
1292     }
1293
1294     /* extend curpad to match namepad */
1295     if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1296         av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1297
1298     if (type == padtidy_SUBCLONE) {
1299         SV * const * const namep = AvARRAY(PL_comppad_name);
1300         PADOFFSET ix;
1301
1302         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1303             SV *namesv;
1304
1305             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1306                 continue;
1307             /*
1308              * The only things that a clonable function needs in its
1309              * pad are anonymous subs.
1310              * The rest are created anew during cloning.
1311              */
1312             if (!((namesv = namep[ix]) != NULL &&
1313                   namesv != &PL_sv_undef &&
1314                    *SvPVX_const(namesv) == '&'))
1315             {
1316                 SvREFCNT_dec(PL_curpad[ix]);
1317                 PL_curpad[ix] = NULL;
1318             }
1319         }
1320     }
1321     else if (type == padtidy_SUB) {
1322         /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1323         AV * const av = newAV();                        /* Will be @_ */
1324         av_store(PL_comppad, 0, MUTABLE_SV(av));
1325         AvREIFY_only(av);
1326     }
1327
1328     if (type == padtidy_SUB || type == padtidy_FORMAT) {
1329         SV * const * const namep = AvARRAY(PL_comppad_name);
1330         PADOFFSET ix;
1331         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1332             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1333                 continue;
1334             if (!SvPADMY(PL_curpad[ix])) {
1335                 SvPADTMP_on(PL_curpad[ix]);
1336             } else if (!SvFAKE(namep[ix])) {
1337                 /* This is a work around for how the current implementation of
1338                    ?{ } blocks in regexps interacts with lexicals.
1339
1340                    One of our lexicals.
1341                    Can't do this on all lexicals, otherwise sub baz() won't
1342                    compile in
1343
1344                    my $foo;
1345
1346                    sub bar { ++$foo; }
1347
1348                    sub baz { ++$foo; }
1349
1350                    because completion of compiling &bar calling pad_tidy()
1351                    would cause (top level) $foo to be marked as stale, and
1352                    "no longer available".  */
1353                 SvPADSTALE_on(PL_curpad[ix]);
1354             }
1355         }
1356     }
1357     PL_curpad = AvARRAY(PL_comppad);
1358 }
1359
1360
1361 /*
1362 =for apidoc pad_free
1363
1364 Free the SV at offset po in the current pad.
1365
1366 =cut
1367 */
1368
1369 /* XXX DAPM integrate with pad_swipe ???? */
1370 void
1371 Perl_pad_free(pTHX_ PADOFFSET po)
1372 {
1373     dVAR;
1374     ASSERT_CURPAD_LEGAL("pad_free");
1375     if (!PL_curpad)
1376         return;
1377     if (AvARRAY(PL_comppad) != PL_curpad)
1378         Perl_croak(aTHX_ "panic: pad_free curpad");
1379     if (!po)
1380         Perl_croak(aTHX_ "panic: pad_free po");
1381
1382     DEBUG_X(PerlIO_printf(Perl_debug_log,
1383             "Pad 0x%"UVxf"[0x%"UVxf"] free:    %ld\n",
1384             PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1385     );
1386
1387     if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
1388         SvPADTMP_off(PL_curpad[po]);
1389 #ifdef USE_ITHREADS
1390         /* SV could be a shared hash key (eg bugid #19022) */
1391         if (!SvIsCOW(PL_curpad[po]))
1392             SvREADONLY_off(PL_curpad[po]);      /* could be a freed constant */
1393 #endif
1394     }
1395     if ((I32)po < PL_padix)
1396         PL_padix = po - 1;
1397 }
1398
1399
1400
1401 /*
1402 =for apidoc do_dump_pad
1403
1404 Dump the contents of a padlist
1405
1406 =cut
1407 */
1408
1409 void
1410 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1411 {
1412     dVAR;
1413     const AV *pad_name;
1414     const AV *pad;
1415     SV **pname;
1416     SV **ppad;
1417     I32 ix;
1418
1419     PERL_ARGS_ASSERT_DO_DUMP_PAD;
1420
1421     if (!padlist) {
1422         return;
1423     }
1424     pad_name = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 0, FALSE));
1425     pad = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 1, FALSE));
1426     pname = AvARRAY(pad_name);
1427     ppad = AvARRAY(pad);
1428     Perl_dump_indent(aTHX_ level, file,
1429             "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1430             PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1431     );
1432
1433     for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1434         const SV *namesv = pname[ix];
1435         if (namesv && namesv == &PL_sv_undef) {
1436             namesv = NULL;
1437         }
1438         if (namesv) {
1439             if (SvFAKE(namesv))
1440                 Perl_dump_indent(aTHX_ level+1, file,
1441                     "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1442                     (int) ix,
1443                     PTR2UV(ppad[ix]),
1444                     (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1445                     SvPVX_const(namesv),
1446                     (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1447                     (unsigned long)PARENT_PAD_INDEX(namesv)
1448
1449                 );
1450             else
1451                 Perl_dump_indent(aTHX_ level+1, file,
1452                     "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
1453                     (int) ix,
1454                     PTR2UV(ppad[ix]),
1455                     (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1456                     (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1457                     (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1458                     SvPVX_const(namesv)
1459                 );
1460         }
1461         else if (full) {
1462             Perl_dump_indent(aTHX_ level+1, file,
1463                 "%2d. 0x%"UVxf"<%lu>\n",
1464                 (int) ix,
1465                 PTR2UV(ppad[ix]),
1466                 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1467             );
1468         }
1469     }
1470 }
1471
1472
1473
1474 /*
1475 =for apidoc cv_dump
1476
1477 dump the contents of a CV
1478
1479 =cut
1480 */
1481
1482 #ifdef DEBUGGING
1483 STATIC void
1484 S_cv_dump(pTHX_ const CV *cv, const char *title)
1485 {
1486     dVAR;
1487     const CV * const outside = CvOUTSIDE(cv);
1488     AV* const padlist = CvPADLIST(cv);
1489
1490     PERL_ARGS_ASSERT_CV_DUMP;
1491
1492     PerlIO_printf(Perl_debug_log,
1493                   "  %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1494                   title,
1495                   PTR2UV(cv),
1496                   (CvANON(cv) ? "ANON"
1497                    : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1498                    : (cv == PL_main_cv) ? "MAIN"
1499                    : CvUNIQUE(cv) ? "UNIQUE"
1500                    : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1501                   PTR2UV(outside),
1502                   (!outside ? "null"
1503                    : CvANON(outside) ? "ANON"
1504                    : (outside == PL_main_cv) ? "MAIN"
1505                    : CvUNIQUE(outside) ? "UNIQUE"
1506                    : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1507
1508     PerlIO_printf(Perl_debug_log,
1509                     "    PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1510     do_dump_pad(1, Perl_debug_log, padlist, 1);
1511 }
1512 #endif /* DEBUGGING */
1513
1514
1515
1516
1517
1518 /*
1519 =for apidoc cv_clone
1520
1521 Clone a CV: make a new CV which points to the same code etc, but which
1522 has a newly-created pad built by copying the prototype pad and capturing
1523 any outer lexicals.
1524
1525 =cut
1526 */
1527
1528 CV *
1529 Perl_cv_clone(pTHX_ CV *proto)
1530 {
1531     dVAR;
1532     I32 ix;
1533     AV* const protopadlist = CvPADLIST(proto);
1534     const AV *const protopad_name = (const AV *)*av_fetch(protopadlist, 0, FALSE);
1535     const AV *const protopad = (const AV *)*av_fetch(protopadlist, 1, FALSE);
1536     SV** const pname = AvARRAY(protopad_name);
1537     SV** const ppad = AvARRAY(protopad);
1538     const I32 fname = AvFILLp(protopad_name);
1539     const I32 fpad = AvFILLp(protopad);
1540     CV* cv;
1541     SV** outpad;
1542     CV* outside;
1543     long depth;
1544
1545     PERL_ARGS_ASSERT_CV_CLONE;
1546
1547     assert(!CvUNIQUE(proto));
1548
1549     /* Since cloneable anon subs can be nested, CvOUTSIDE may point
1550      * to a prototype; we instead want the cloned parent who called us.
1551      * Note that in general for formats, CvOUTSIDE != find_runcv */
1552
1553     outside = CvOUTSIDE(proto);
1554     if (outside && CvCLONE(outside) && ! CvCLONED(outside))
1555         outside = find_runcv(NULL);
1556     depth = CvDEPTH(outside);
1557     assert(depth || SvTYPE(proto) == SVt_PVFM);
1558     if (!depth)
1559         depth = 1;
1560     assert(CvPADLIST(outside));
1561
1562     ENTER;
1563     SAVESPTR(PL_compcv);
1564
1565     cv = PL_compcv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
1566     CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC);
1567     CvCLONED_on(cv);
1568
1569 #ifdef USE_ITHREADS
1570     CvFILE(cv)          = CvISXSUB(proto) ? CvFILE(proto)
1571                                           : savepv(CvFILE(proto));
1572 #else
1573     CvFILE(cv)          = CvFILE(proto);
1574 #endif
1575     CvGV_set(cv,CvGV(proto));
1576     CvSTASH_set(cv, CvSTASH(proto));
1577     OP_REFCNT_LOCK;
1578     CvROOT(cv)          = OpREFCNT_inc(CvROOT(proto));
1579     OP_REFCNT_UNLOCK;
1580     CvSTART(cv)         = CvSTART(proto);
1581     CvOUTSIDE(cv)       = MUTABLE_CV(SvREFCNT_inc_simple(outside));
1582     CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
1583
1584     if (SvPOK(proto))
1585         sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
1586
1587     CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
1588
1589     av_fill(PL_comppad, fpad);
1590     for (ix = fname; ix >= 0; ix--)
1591         av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
1592
1593     PL_curpad = AvARRAY(PL_comppad);
1594
1595     outpad = AvARRAY(AvARRAY(CvPADLIST(outside))[depth]);
1596
1597     for (ix = fpad; ix > 0; ix--) {
1598         SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
1599         SV *sv = NULL;
1600         if (namesv && namesv != &PL_sv_undef) { /* lexical */
1601             if (SvFAKE(namesv)) {   /* lexical from outside? */
1602                 sv = outpad[PARENT_PAD_INDEX(namesv)];
1603                 assert(sv);
1604                 /* formats may have an inactive parent,
1605                    while my $x if $false can leave an active var marked as
1606                    stale. And state vars are always available */
1607                 if (SvPADSTALE(sv) && !SvPAD_STATE(namesv)) {
1608                     Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1609                                    "Variable \"%s\" is not available", SvPVX_const(namesv));
1610                     sv = NULL;
1611                 }
1612                 else
1613                     SvREFCNT_inc_simple_void_NN(sv);
1614             }
1615             if (!sv) {
1616                 const char sigil = SvPVX_const(namesv)[0];
1617                 if (sigil == '&')
1618                     sv = SvREFCNT_inc(ppad[ix]);
1619                 else if (sigil == '@')
1620                     sv = MUTABLE_SV(newAV());
1621                 else if (sigil == '%')
1622                     sv = MUTABLE_SV(newHV());
1623                 else
1624                     sv = newSV(0);
1625                 SvPADMY_on(sv);
1626                 /* reset the 'assign only once' flag on each state var */
1627                 if (SvPAD_STATE(namesv))
1628                     SvPADSTALE_on(sv);
1629             }
1630         }
1631         else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
1632             sv = SvREFCNT_inc_NN(ppad[ix]);
1633         }
1634         else {
1635             sv = newSV(0);
1636             SvPADTMP_on(sv);
1637         }
1638         PL_curpad[ix] = sv;
1639     }
1640
1641     DEBUG_Xv(
1642         PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
1643         cv_dump(outside, "Outside");
1644         cv_dump(proto,   "Proto");
1645         cv_dump(cv,      "To");
1646     );
1647
1648     LEAVE;
1649
1650     if (CvCONST(cv)) {
1651         /* Constant sub () { $x } closing over $x - see lib/constant.pm:
1652          * The prototype was marked as a candiate for const-ization,
1653          * so try to grab the current const value, and if successful,
1654          * turn into a const sub:
1655          */
1656         SV* const const_sv = op_const_sv(CvSTART(cv), cv);
1657         if (const_sv) {
1658             SvREFCNT_dec(cv);
1659             cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
1660         }
1661         else {
1662             CvCONST_off(cv);
1663         }
1664     }
1665
1666     return cv;
1667 }
1668
1669
1670 /*
1671 =for apidoc pad_fixup_inner_anons
1672
1673 For any anon CVs in the pad, change CvOUTSIDE of that CV from
1674 old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
1675 moved to a pre-existing CV struct.
1676
1677 =cut
1678 */
1679
1680 void
1681 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
1682 {
1683     dVAR;
1684     I32 ix;
1685     AV * const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
1686     AV * const comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
1687     SV ** const namepad = AvARRAY(comppad_name);
1688     SV ** const curpad = AvARRAY(comppad);
1689
1690     PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
1691     PERL_UNUSED_ARG(old_cv);
1692
1693     for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
1694         const SV * const namesv = namepad[ix];
1695         if (namesv && namesv != &PL_sv_undef
1696             && *SvPVX_const(namesv) == '&')
1697         {
1698             CV * const innercv = MUTABLE_CV(curpad[ix]);
1699             assert(CvWEAKOUTSIDE(innercv));
1700             assert(CvOUTSIDE(innercv) == old_cv);
1701             CvOUTSIDE(innercv) = new_cv;
1702         }
1703     }
1704 }
1705
1706
1707 /*
1708 =for apidoc pad_push
1709
1710 Push a new pad frame onto the padlist, unless there's already a pad at
1711 this depth, in which case don't bother creating a new one.  Then give
1712 the new pad an @_ in slot zero.
1713
1714 =cut
1715 */
1716
1717 void
1718 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
1719 {
1720     dVAR;
1721
1722     PERL_ARGS_ASSERT_PAD_PUSH;
1723
1724     if (depth > AvFILLp(padlist)) {
1725         SV** const svp = AvARRAY(padlist);
1726         AV* const newpad = newAV();
1727         SV** const oldpad = AvARRAY(svp[depth-1]);
1728         I32 ix = AvFILLp((const AV *)svp[1]);
1729         const I32 names_fill = AvFILLp((const AV *)svp[0]);
1730         SV** const names = AvARRAY(svp[0]);
1731         AV *av;
1732
1733         for ( ;ix > 0; ix--) {
1734             if (names_fill >= ix && names[ix] != &PL_sv_undef) {
1735                 const char sigil = SvPVX_const(names[ix])[0];
1736                 if ((SvFLAGS(names[ix]) & SVf_FAKE)
1737                         || (SvFLAGS(names[ix]) & SVpad_STATE)
1738                         || sigil == '&')
1739                 {
1740                     /* outer lexical or anon code */
1741                     av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
1742                 }
1743                 else {          /* our own lexical */
1744                     SV *sv;
1745                     if (sigil == '@')
1746                         sv = MUTABLE_SV(newAV());
1747                     else if (sigil == '%')
1748                         sv = MUTABLE_SV(newHV());
1749                     else
1750                         sv = newSV(0);
1751                     av_store(newpad, ix, sv);
1752                     SvPADMY_on(sv);
1753                 }
1754             }
1755             else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
1756                 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
1757             }
1758             else {
1759                 /* save temporaries on recursion? */
1760                 SV * const sv = newSV(0);
1761                 av_store(newpad, ix, sv);
1762                 SvPADTMP_on(sv);
1763             }
1764         }
1765         av = newAV();
1766         av_store(newpad, 0, MUTABLE_SV(av));
1767         AvREIFY_only(av);
1768
1769         av_store(padlist, depth, MUTABLE_SV(newpad));
1770         AvFILLp(padlist) = depth;
1771     }
1772 }
1773
1774
1775 HV *
1776 Perl_pad_compname_type(pTHX_ const PADOFFSET po)
1777 {
1778     dVAR;
1779     SV* const * const av = av_fetch(PL_comppad_name, po, FALSE);
1780     if ( SvPAD_TYPED(*av) ) {
1781         return SvSTASH(*av);
1782     }
1783     return NULL;
1784 }
1785
1786 #if defined(USE_ITHREADS)
1787
1788 #  define av_dup_inc(s,t)       MUTABLE_AV(sv_dup_inc((const SV *)s,t))
1789
1790 AV *
1791 Perl_padlist_dup(pTHX_ AV *const srcpad, CLONE_PARAMS *const param)
1792 {
1793     AV *dstpad;
1794     PERL_ARGS_ASSERT_PADLIST_DUP;
1795
1796     if (!srcpad)
1797         return NULL;
1798
1799     assert(!AvREAL(srcpad));
1800
1801     if (param->flags & CLONEf_COPY_STACKS
1802         || SvREFCNT(AvARRAY(srcpad)[1]) > 1) {
1803         /* XXX padlists are real, but pretend to be not */
1804         AvREAL_on(srcpad);
1805         dstpad = av_dup_inc(srcpad, param);
1806         AvREAL_off(srcpad);
1807         AvREAL_off(dstpad);
1808         assert (SvREFCNT(AvARRAY(srcpad)[1]) == 1);
1809     } else {
1810         /* CvDEPTH() on our subroutine will be set to 0, so there's no need
1811            to build anything other than the first level of pads.  */
1812
1813         I32 ix = AvFILLp((const AV *)AvARRAY(srcpad)[1]);
1814         AV *pad1;
1815         const I32 names_fill = AvFILLp((const AV *)(AvARRAY(srcpad)[0]));
1816         const AV *const srcpad1 = (const AV *) AvARRAY(srcpad)[1];
1817         SV **oldpad = AvARRAY(srcpad1);
1818         SV **names;
1819         SV **pad1a;
1820         AV *args;
1821         /* look for it in the table first.
1822            I *think* that it shouldn't be possible to find it there.
1823            Well, except for how Perl_sv_compile_2op() "works" :-(   */
1824         dstpad = (AV*)ptr_table_fetch(PL_ptr_table, srcpad);
1825
1826         if (dstpad)
1827             return dstpad;
1828
1829         dstpad = newAV();
1830         ptr_table_store(PL_ptr_table, srcpad, dstpad);
1831         AvREAL_off(dstpad);
1832         av_extend(dstpad, 1);
1833         AvARRAY(dstpad)[0] = MUTABLE_SV(av_dup_inc(AvARRAY(srcpad)[0], param));
1834         names = AvARRAY(AvARRAY(dstpad)[0]);
1835
1836         pad1 = newAV();
1837
1838         av_extend(pad1, ix);
1839         AvARRAY(dstpad)[1] = MUTABLE_SV(pad1);
1840         pad1a = AvARRAY(pad1);
1841         AvFILLp(dstpad) = 1;
1842
1843         if (ix > -1) {
1844             AvFILLp(pad1) = ix;
1845
1846             for ( ;ix > 0; ix--) {
1847                 if (!oldpad[ix]) {
1848                     pad1a[ix] = NULL;
1849                 } else if (names_fill >= ix && names[ix] != &PL_sv_undef) {
1850                     const char sigil = SvPVX_const(names[ix])[0];
1851                     if ((SvFLAGS(names[ix]) & SVf_FAKE)
1852                         || (SvFLAGS(names[ix]) & SVpad_STATE)
1853                         || sigil == '&')
1854                         {
1855                             /* outer lexical or anon code */
1856                             pad1a[ix] = sv_dup_inc(oldpad[ix], param);
1857                         }
1858                     else {              /* our own lexical */
1859                         if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
1860                             /* This is a work around for how the current
1861                                implementation of ?{ } blocks in regexps
1862                                interacts with lexicals.  */
1863                             pad1a[ix] = sv_dup_inc(oldpad[ix], param);
1864                         } else {
1865                             SV *sv;
1866
1867                             if (sigil == '@')
1868                                 sv = MUTABLE_SV(newAV());
1869                             else if (sigil == '%')
1870                                 sv = MUTABLE_SV(newHV());
1871                             else
1872                                 sv = newSV(0);
1873                             pad1a[ix] = sv;
1874                             SvPADMY_on(sv);
1875                         }
1876                     }
1877                 }
1878                 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
1879                     pad1a[ix] = sv_dup_inc(oldpad[ix], param);
1880                 }
1881                 else {
1882                     /* save temporaries on recursion? */
1883                     SV * const sv = newSV(0);
1884                     pad1a[ix] = sv;
1885
1886                     /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
1887                        FIXTHAT before merging this branch.
1888                        (And I know how to) */
1889                     if (SvPADMY(oldpad[ix]))
1890                         SvPADMY_on(sv);
1891                     else
1892                         SvPADTMP_on(sv);
1893                 }
1894             }
1895
1896             if (oldpad[0]) {
1897                 args = newAV();                 /* Will be @_ */
1898                 AvREIFY_only(args);
1899                 pad1a[0] = (SV *)args;
1900             }
1901         }
1902     }
1903
1904     return dstpad;
1905 }
1906
1907 #endif
1908
1909 /*
1910  * Local variables:
1911  * c-indentation-style: bsd
1912  * c-basic-offset: 4
1913  * indent-tabs-mode: t
1914  * End:
1915  *
1916  * ex: set ts=8 sts=4 sw=4 noet:
1917  */