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