Update podlators to CPAN version 2.4.0
[perl.git] / 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(cv)         = CvSTASH(proto);
1577     if (CvSTASH(cv))
1578         Perl_sv_add_backref(aTHX_ MUTABLE_SV(CvSTASH(cv)), MUTABLE_SV(cv));
1579     OP_REFCNT_LOCK;
1580     CvROOT(cv)          = OpREFCNT_inc(CvROOT(proto));
1581     OP_REFCNT_UNLOCK;
1582     CvSTART(cv)         = CvSTART(proto);
1583     CvOUTSIDE(cv)       = MUTABLE_CV(SvREFCNT_inc_simple(outside));
1584     CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
1585
1586     if (SvPOK(proto))
1587         sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
1588
1589     CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
1590
1591     av_fill(PL_comppad, fpad);
1592     for (ix = fname; ix >= 0; ix--)
1593         av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
1594
1595     PL_curpad = AvARRAY(PL_comppad);
1596
1597     outpad = AvARRAY(AvARRAY(CvPADLIST(outside))[depth]);
1598
1599     for (ix = fpad; ix > 0; ix--) {
1600         SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
1601         SV *sv = NULL;
1602         if (namesv && namesv != &PL_sv_undef) { /* lexical */
1603             if (SvFAKE(namesv)) {   /* lexical from outside? */
1604                 sv = outpad[PARENT_PAD_INDEX(namesv)];
1605                 assert(sv);
1606                 /* formats may have an inactive parent,
1607                    while my $x if $false can leave an active var marked as
1608                    stale. And state vars are always available */
1609                 if (SvPADSTALE(sv) && !SvPAD_STATE(namesv)) {
1610                     Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1611                                    "Variable \"%s\" is not available", SvPVX_const(namesv));
1612                     sv = NULL;
1613                 }
1614                 else 
1615                     SvREFCNT_inc_simple_void_NN(sv);
1616             }
1617             if (!sv) {
1618                 const char sigil = SvPVX_const(namesv)[0];
1619                 if (sigil == '&')
1620                     sv = SvREFCNT_inc(ppad[ix]);
1621                 else if (sigil == '@')
1622                     sv = MUTABLE_SV(newAV());
1623                 else if (sigil == '%')
1624                     sv = MUTABLE_SV(newHV());
1625                 else
1626                     sv = newSV(0);
1627                 SvPADMY_on(sv);
1628                 /* reset the 'assign only once' flag on each state var */
1629                 if (SvPAD_STATE(namesv))
1630                     SvPADSTALE_on(sv);
1631             }
1632         }
1633         else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
1634             sv = SvREFCNT_inc_NN(ppad[ix]);
1635         }
1636         else {
1637             sv = newSV(0);
1638             SvPADTMP_on(sv);
1639         }
1640         PL_curpad[ix] = sv;
1641     }
1642
1643     DEBUG_Xv(
1644         PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
1645         cv_dump(outside, "Outside");
1646         cv_dump(proto,   "Proto");
1647         cv_dump(cv,      "To");
1648     );
1649
1650     LEAVE;
1651
1652     if (CvCONST(cv)) {
1653         /* Constant sub () { $x } closing over $x - see lib/constant.pm:
1654          * The prototype was marked as a candiate for const-ization,
1655          * so try to grab the current const value, and if successful,
1656          * turn into a const sub:
1657          */
1658         SV* const const_sv = op_const_sv(CvSTART(cv), cv);
1659         if (const_sv) {
1660             SvREFCNT_dec(cv);
1661             cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
1662         }
1663         else {
1664             CvCONST_off(cv);
1665         }
1666     }
1667
1668     return cv;
1669 }
1670
1671
1672 /*
1673 =for apidoc pad_fixup_inner_anons
1674
1675 For any anon CVs in the pad, change CvOUTSIDE of that CV from
1676 old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
1677 moved to a pre-existing CV struct.
1678
1679 =cut
1680 */
1681
1682 void
1683 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
1684 {
1685     dVAR;
1686     I32 ix;
1687     AV * const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
1688     AV * const comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
1689     SV ** const namepad = AvARRAY(comppad_name);
1690     SV ** const curpad = AvARRAY(comppad);
1691
1692     PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
1693     PERL_UNUSED_ARG(old_cv);
1694
1695     for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
1696         const SV * const namesv = namepad[ix];
1697         if (namesv && namesv != &PL_sv_undef
1698             && *SvPVX_const(namesv) == '&')
1699         {
1700             CV * const innercv = MUTABLE_CV(curpad[ix]);
1701             assert(CvWEAKOUTSIDE(innercv));
1702             assert(CvOUTSIDE(innercv) == old_cv);
1703             CvOUTSIDE(innercv) = new_cv;
1704         }
1705     }
1706 }
1707
1708
1709 /*
1710 =for apidoc pad_push
1711
1712 Push a new pad frame onto the padlist, unless there's already a pad at
1713 this depth, in which case don't bother creating a new one.  Then give
1714 the new pad an @_ in slot zero.
1715
1716 =cut
1717 */
1718
1719 void
1720 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
1721 {
1722     dVAR;
1723
1724     PERL_ARGS_ASSERT_PAD_PUSH;
1725
1726     if (depth > AvFILLp(padlist)) {
1727         SV** const svp = AvARRAY(padlist);
1728         AV* const newpad = newAV();
1729         SV** const oldpad = AvARRAY(svp[depth-1]);
1730         I32 ix = AvFILLp((const AV *)svp[1]);
1731         const I32 names_fill = AvFILLp((const AV *)svp[0]);
1732         SV** const names = AvARRAY(svp[0]);
1733         AV *av;
1734
1735         for ( ;ix > 0; ix--) {
1736             if (names_fill >= ix && names[ix] != &PL_sv_undef) {
1737                 const char sigil = SvPVX_const(names[ix])[0];
1738                 if ((SvFLAGS(names[ix]) & SVf_FAKE)
1739                         || (SvFLAGS(names[ix]) & SVpad_STATE)
1740                         || sigil == '&')
1741                 {
1742                     /* outer lexical or anon code */
1743                     av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
1744                 }
1745                 else {          /* our own lexical */
1746                     SV *sv; 
1747                     if (sigil == '@')
1748                         sv = MUTABLE_SV(newAV());
1749                     else if (sigil == '%')
1750                         sv = MUTABLE_SV(newHV());
1751                     else
1752                         sv = newSV(0);
1753                     av_store(newpad, ix, sv);
1754                     SvPADMY_on(sv);
1755                 }
1756             }
1757             else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
1758                 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
1759             }
1760             else {
1761                 /* save temporaries on recursion? */
1762                 SV * const sv = newSV(0);
1763                 av_store(newpad, ix, sv);
1764                 SvPADTMP_on(sv);
1765             }
1766         }
1767         av = newAV();
1768         av_store(newpad, 0, MUTABLE_SV(av));
1769         AvREIFY_only(av);
1770
1771         av_store(padlist, depth, MUTABLE_SV(newpad));
1772         AvFILLp(padlist) = depth;
1773     }
1774 }
1775
1776
1777 HV *
1778 Perl_pad_compname_type(pTHX_ const PADOFFSET po)
1779 {
1780     dVAR;
1781     SV* const * const av = av_fetch(PL_comppad_name, po, FALSE);
1782     if ( SvPAD_TYPED(*av) ) {
1783         return SvSTASH(*av);
1784     }
1785     return NULL;
1786 }
1787
1788 #if defined(USE_ITHREADS)
1789
1790 #  define av_dup_inc(s,t)       MUTABLE_AV(sv_dup_inc((const SV *)s,t))
1791
1792 AV *
1793 Perl_padlist_dup(pTHX_ AV *const srcpad, CLONE_PARAMS *const param)
1794 {
1795     AV *dstpad;
1796     PERL_ARGS_ASSERT_PADLIST_DUP;
1797
1798     if (!srcpad)
1799         return NULL;
1800
1801     assert(!AvREAL(srcpad));
1802
1803     if (param->flags & CLONEf_COPY_STACKS
1804         || SvREFCNT(AvARRAY(srcpad)[1]) > 1) {
1805         /* XXX padlists are real, but pretend to be not */
1806         AvREAL_on(srcpad);
1807         dstpad = av_dup_inc(srcpad, param);
1808         AvREAL_off(srcpad);
1809         AvREAL_off(dstpad);
1810         assert (SvREFCNT(AvARRAY(srcpad)[1]) == 1);
1811     } else {
1812         /* CvDEPTH() on our subroutine will be set to 0, so there's no need
1813            to build anything other than the first level of pads.  */
1814
1815         I32 ix = AvFILLp((const AV *)AvARRAY(srcpad)[1]);
1816         AV *pad1;
1817         const I32 names_fill = AvFILLp((const AV *)(AvARRAY(srcpad)[0]));
1818         const AV *const srcpad1 = (const AV *) AvARRAY(srcpad)[1];
1819         SV **oldpad = AvARRAY(srcpad1);
1820         SV **names;
1821         SV **pad1a;
1822         AV *args;
1823         /* look for it in the table first.
1824            I *think* that it shouldn't be possible to find it there.
1825            Well, except for how Perl_sv_compile_2op() "works" :-(   */
1826         dstpad = (AV*)ptr_table_fetch(PL_ptr_table, srcpad);
1827
1828         if (dstpad)
1829             return dstpad;
1830
1831         dstpad = newAV();
1832         ptr_table_store(PL_ptr_table, srcpad, dstpad);
1833         AvREAL_off(dstpad);
1834         av_extend(dstpad, 1);
1835         AvARRAY(dstpad)[0] = MUTABLE_SV(av_dup_inc(AvARRAY(srcpad)[0], param));
1836         names = AvARRAY(AvARRAY(dstpad)[0]);
1837
1838         pad1 = newAV();
1839
1840         av_extend(pad1, ix);
1841         AvARRAY(dstpad)[1] = MUTABLE_SV(pad1);
1842         pad1a = AvARRAY(pad1);
1843         AvFILLp(dstpad) = 1;
1844
1845         if (ix > -1) {
1846             AvFILLp(pad1) = ix;
1847
1848             for ( ;ix > 0; ix--) {
1849                 if (!oldpad[ix]) {
1850                     pad1a[ix] = NULL;
1851                 } else if (names_fill >= ix && names[ix] != &PL_sv_undef) {
1852                     const char sigil = SvPVX_const(names[ix])[0];
1853                     if ((SvFLAGS(names[ix]) & SVf_FAKE)
1854                         || (SvFLAGS(names[ix]) & SVpad_STATE)
1855                         || sigil == '&')
1856                         {
1857                             /* outer lexical or anon code */
1858                             pad1a[ix] = sv_dup_inc(oldpad[ix], param);
1859                         }
1860                     else {              /* our own lexical */
1861                         if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
1862                             /* This is a work around for how the current
1863                                implementation of ?{ } blocks in regexps
1864                                interacts with lexicals.  */
1865                             pad1a[ix] = sv_dup_inc(oldpad[ix], param);
1866                         } else {
1867                             SV *sv; 
1868                             
1869                             if (sigil == '@')
1870                                 sv = MUTABLE_SV(newAV());
1871                             else if (sigil == '%')
1872                                 sv = MUTABLE_SV(newHV());
1873                             else
1874                                 sv = newSV(0);
1875                             pad1a[ix] = sv;
1876                             SvPADMY_on(sv);
1877                         }
1878                     }
1879                 }
1880                 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
1881                     pad1a[ix] = sv_dup_inc(oldpad[ix], param);
1882                 }
1883                 else {
1884                     /* save temporaries on recursion? */
1885                     SV * const sv = newSV(0);
1886                     pad1a[ix] = sv;
1887
1888                     /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
1889                        FIXTHAT before merging this branch.
1890                        (And I know how to) */
1891                     if (SvPADMY(oldpad[ix]))
1892                         SvPADMY_on(sv);
1893                     else
1894                         SvPADTMP_on(sv);
1895                 }
1896             }
1897
1898             if (oldpad[0]) {
1899                 args = newAV();                 /* Will be @_ */
1900                 AvREIFY_only(args);
1901                 pad1a[0] = (SV *)args;
1902             }
1903         }
1904     }
1905
1906     return dstpad;
1907 }
1908
1909 #endif
1910
1911 /*
1912  * Local variables:
1913  * c-indentation-style: bsd
1914  * c-basic-offset: 4
1915  * indent-tabs-mode: t
1916  * End:
1917  *
1918  * ex: set ts=8 sts=4 sw=4 noet:
1919  */