This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Only allocate entries for @_ when the subroutine is first called.
[perl5.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     /* XXX DAPM since slot has been allocated, replace
424      * av_store with PL_curpad[offset] ? */
425     if (*name == '@')
426         av_store(PL_comppad, offset, MUTABLE_SV(newAV()));
427     else if (*name == '%')
428         av_store(PL_comppad, offset, MUTABLE_SV(newHV()));
429     SvPADMY_on(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 =for apidoc pad_findlex
708
709 Find a named lexical anywhere in a chain of nested pads. Add fake entries
710 in the inner pads if it's found in an outer one.
711
712 Returns the offset in the bottom pad of the lex or the fake lex.
713 cv is the CV in which to start the search, and seq is the current cop_seq
714 to match against. If warn is true, print appropriate warnings.  The out_*
715 vars return values, and so are pointers to where the returned values
716 should be stored. out_capture, if non-null, requests that the innermost
717 instance of the lexical is captured; out_name_sv is set to the innermost
718 matched namesv or fake namesv; out_flags returns the flags normally
719 associated with the IVX field of a fake namesv.
720
721 Note that pad_findlex() is recursive; it recurses up the chain of CVs,
722 then comes back down, adding fake entries as it goes. It has to be this way
723 because fake namesvs in anon protoypes have to store in xlow the index into
724 the parent pad.
725
726 =cut
727 */
728
729 /* the CV has finished being compiled. This is not a sufficient test for
730  * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
731 #define CvCOMPILED(cv)  CvROOT(cv)
732
733 /* the CV does late binding of its lexicals */
734 #define CvLATE(cv) (CvANON(cv) || SvTYPE(cv) == SVt_PVFM)
735
736
737 STATIC PADOFFSET
738 S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn,
739         SV** out_capture, SV** out_name_sv, int *out_flags)
740 {
741     dVAR;
742     I32 offset, new_offset;
743     SV *new_capture;
744     SV **new_capturep;
745     const AV * const padlist = CvPADLIST(cv);
746
747     PERL_ARGS_ASSERT_PAD_FINDLEX;
748
749     *out_flags = 0;
750
751     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
752         "Pad findlex cv=0x%"UVxf" searching \"%s\" seq=%d%s\n",
753         PTR2UV(cv), name, (int)seq, out_capture ? " capturing" : "" ));
754
755     /* first, search this pad */
756
757     if (padlist) { /* not an undef CV */
758         I32 fake_offset = 0;
759         const AV * const nameav = MUTABLE_AV(AvARRAY(padlist)[0]);
760         SV * const * const name_svp = AvARRAY(nameav);
761
762         for (offset = AvFILLp(nameav); offset > 0; offset--) {
763             const SV * const namesv = name_svp[offset];
764             if (namesv && namesv != &PL_sv_undef
765                     && strEQ(SvPVX_const(namesv), name))
766             {
767                 if (SvFAKE(namesv))
768                     fake_offset = offset; /* in case we don't find a real one */
769                 else if (  seq >  COP_SEQ_RANGE_LOW(namesv)     /* min */
770                         && seq <= COP_SEQ_RANGE_HIGH(namesv))   /* max */
771                     break;
772             }
773         }
774
775         if (offset > 0 || fake_offset > 0 ) { /* a match! */
776             if (offset > 0) { /* not fake */
777                 fake_offset = 0;
778                 *out_name_sv = name_svp[offset]; /* return the namesv */
779
780                 /* set PAD_FAKELEX_MULTI if this lex can have multiple
781                  * instances. For now, we just test !CvUNIQUE(cv), but
782                  * ideally, we should detect my's declared within loops
783                  * etc - this would allow a wider range of 'not stayed
784                  * shared' warnings. We also treated alreadly-compiled
785                  * lexes as not multi as viewed from evals. */
786
787                 *out_flags = CvANON(cv) ?
788                         PAD_FAKELEX_ANON :
789                             (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
790                                 ? PAD_FAKELEX_MULTI : 0;
791
792                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
793                     "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n",
794                     PTR2UV(cv), (long)offset,
795                     (unsigned long)COP_SEQ_RANGE_LOW(*out_name_sv),
796                     (unsigned long)COP_SEQ_RANGE_HIGH(*out_name_sv)));
797             }
798             else { /* fake match */
799                 offset = fake_offset;
800                 *out_name_sv = name_svp[offset]; /* return the namesv */
801                 *out_flags = PARENT_FAKELEX_FLAGS(*out_name_sv);
802                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
803                     "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
804                     PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
805                     (unsigned long) PARENT_PAD_INDEX(*out_name_sv) 
806                 ));
807             }
808
809             /* return the lex? */
810
811             if (out_capture) {
812
813                 /* our ? */
814                 if (SvPAD_OUR(*out_name_sv)) {
815                     *out_capture = NULL;
816                     return offset;
817                 }
818
819                 /* trying to capture from an anon prototype? */
820                 if (CvCOMPILED(cv)
821                         ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
822                         : *out_flags & PAD_FAKELEX_ANON)
823                 {
824                     if (warn)
825                         Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
826                                        "Variable \"%s\" is not available", name);
827                     *out_capture = NULL;
828                 }
829
830                 /* real value */
831                 else {
832                     int newwarn = warn;
833                     if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
834                          && !SvPAD_STATE(name_svp[offset])
835                          && warn && ckWARN(WARN_CLOSURE)) {
836                         newwarn = 0;
837                         Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
838                             "Variable \"%s\" will not stay shared", name);
839                     }
840
841                     if (fake_offset && CvANON(cv)
842                             && CvCLONE(cv) &&!CvCLONED(cv))
843                     {
844                         SV *n;
845                         /* not yet caught - look further up */
846                         DEBUG_Xv(PerlIO_printf(Perl_debug_log,
847                             "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
848                             PTR2UV(cv)));
849                         n = *out_name_sv;
850                         (void) pad_findlex(name, CvOUTSIDE(cv),
851                             CvOUTSIDE_SEQ(cv),
852                             newwarn, out_capture, out_name_sv, out_flags);
853                         *out_name_sv = n;
854                         return offset;
855                     }
856
857                     *out_capture = AvARRAY(MUTABLE_AV(AvARRAY(padlist)[
858                                     CvDEPTH(cv) ? CvDEPTH(cv) : 1]))[offset];
859                     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
860                         "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
861                         PTR2UV(cv), PTR2UV(*out_capture)));
862
863                     if (SvPADSTALE(*out_capture)
864                         && !SvPAD_STATE(name_svp[offset]))
865                     {
866                         Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
867                                        "Variable \"%s\" is not available", name);
868                         *out_capture = NULL;
869                     }
870                 }
871                 if (!*out_capture) {
872                     if (*name == '@')
873                         *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
874                     else if (*name == '%')
875                         *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
876                     else
877                         *out_capture = sv_newmortal();
878                 }
879             }
880
881             return offset;
882         }
883     }
884
885     /* it's not in this pad - try above */
886
887     if (!CvOUTSIDE(cv))
888         return NOT_IN_PAD;
889
890     /* out_capture non-null means caller wants us to capture lex; in
891      * addition we capture ourselves unless it's an ANON/format */
892     new_capturep = out_capture ? out_capture :
893                 CvLATE(cv) ? NULL : &new_capture;
894
895     offset = pad_findlex(name, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
896                 new_capturep, out_name_sv, out_flags);
897     if ((PADOFFSET)offset == NOT_IN_PAD)
898         return NOT_IN_PAD;
899
900     /* found in an outer CV. Add appropriate fake entry to this pad */
901
902     /* don't add new fake entries (via eval) to CVs that we have already
903      * finished compiling, or to undef CVs */
904     if (CvCOMPILED(cv) || !padlist)
905         return 0; /* this dummy (and invalid) value isnt used by the caller */
906
907     {
908         /* This relies on sv_setsv_flags() upgrading the destination to the same
909            type as the source, independant of the flags set, and on it being
910            "good" and only copying flag bits and pointers that it understands.
911         */
912         SV *new_namesv = newSVsv(*out_name_sv);
913         AV *  const ocomppad_name = PL_comppad_name;
914         PAD * const ocomppad = PL_comppad;
915         PL_comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
916         PL_comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
917         PL_curpad = AvARRAY(PL_comppad);
918
919         new_offset
920             = pad_add_name_sv(new_namesv,
921                               (SvPAD_STATE(*out_name_sv) ? padadd_STATE : 0),
922                               SvPAD_TYPED(*out_name_sv)
923                               ? SvSTASH(*out_name_sv) : NULL,
924                               SvOURSTASH(*out_name_sv)
925                               );
926
927         SvFAKE_on(new_namesv);
928         DEBUG_Xv(PerlIO_printf(Perl_debug_log,
929                                "Pad addname: %ld \"%.*s\" FAKE\n",
930                                (long)new_offset,
931                                (int) SvCUR(new_namesv), SvPVX(new_namesv)));
932         PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags);
933
934         PARENT_PAD_INDEX_set(new_namesv, 0);
935         if (SvPAD_OUR(new_namesv)) {
936             NOOP;   /* do nothing */
937         }
938         else if (CvLATE(cv)) {
939             /* delayed creation - just note the offset within parent pad */
940             PARENT_PAD_INDEX_set(new_namesv, offset);
941             CvCLONE_on(cv);
942         }
943         else {
944             /* immediate creation - capture outer value right now */
945             av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
946             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
947                 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
948                 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
949         }
950         *out_name_sv = new_namesv;
951         *out_flags = PARENT_FAKELEX_FLAGS(new_namesv);
952
953         PL_comppad_name = ocomppad_name;
954         PL_comppad = ocomppad;
955         PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
956     }
957     return new_offset;
958 }
959
960
961 #ifdef DEBUGGING
962 /*
963 =for apidoc pad_sv
964
965 Get the value at offset po in the current pad.
966 Use macro PAD_SV instead of calling this function directly.
967
968 =cut
969 */
970
971
972 SV *
973 Perl_pad_sv(pTHX_ PADOFFSET po)
974 {
975     dVAR;
976     ASSERT_CURPAD_ACTIVE("pad_sv");
977
978     if (!po)
979         Perl_croak(aTHX_ "panic: pad_sv po");
980     DEBUG_X(PerlIO_printf(Perl_debug_log,
981         "Pad 0x%"UVxf"[0x%"UVxf"] sv:      %ld sv=0x%"UVxf"\n",
982         PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
983     );
984     return PL_curpad[po];
985 }
986
987
988 /*
989 =for apidoc pad_setsv
990
991 Set the entry at offset po in the current pad to sv.
992 Use the macro PAD_SETSV() rather than calling this function directly.
993
994 =cut
995 */
996
997 void
998 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
999 {
1000     dVAR;
1001
1002     PERL_ARGS_ASSERT_PAD_SETSV;
1003
1004     ASSERT_CURPAD_ACTIVE("pad_setsv");
1005
1006     DEBUG_X(PerlIO_printf(Perl_debug_log,
1007         "Pad 0x%"UVxf"[0x%"UVxf"] setsv:   %ld sv=0x%"UVxf"\n",
1008         PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
1009     );
1010     PL_curpad[po] = sv;
1011 }
1012 #endif
1013
1014
1015
1016 /*
1017 =for apidoc pad_block_start
1018
1019 Update the pad compilation state variables on entry to a new block
1020
1021 =cut
1022 */
1023
1024 /* XXX DAPM perhaps:
1025  *      - integrate this in general state-saving routine ???
1026  *      - combine with the state-saving going on in pad_new ???
1027  *      - introduce a new SAVE type that does all this in one go ?
1028  */
1029
1030 void
1031 Perl_pad_block_start(pTHX_ int full)
1032 {
1033     dVAR;
1034     ASSERT_CURPAD_ACTIVE("pad_block_start");
1035     SAVEI32(PL_comppad_name_floor);
1036     PL_comppad_name_floor = AvFILLp(PL_comppad_name);
1037     if (full)
1038         PL_comppad_name_fill = PL_comppad_name_floor;
1039     if (PL_comppad_name_floor < 0)
1040         PL_comppad_name_floor = 0;
1041     SAVEI32(PL_min_intro_pending);
1042     SAVEI32(PL_max_intro_pending);
1043     PL_min_intro_pending = 0;
1044     SAVEI32(PL_comppad_name_fill);
1045     SAVEI32(PL_padix_floor);
1046     PL_padix_floor = PL_padix;
1047     PL_pad_reset_pending = FALSE;
1048 }
1049
1050
1051 /*
1052 =for apidoc intro_my
1053
1054 "Introduce" my variables to visible status.
1055
1056 =cut
1057 */
1058
1059 U32
1060 Perl_intro_my(pTHX)
1061 {
1062     dVAR;
1063     SV **svp;
1064     I32 i;
1065
1066     ASSERT_CURPAD_ACTIVE("intro_my");
1067     if (! PL_min_intro_pending)
1068         return PL_cop_seqmax;
1069
1070     svp = AvARRAY(PL_comppad_name);
1071     for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1072         SV * const sv = svp[i];
1073
1074         if (sv && sv != &PL_sv_undef && !SvFAKE(sv) && !COP_SEQ_RANGE_HIGH(sv)) {
1075             COP_SEQ_RANGE_HIGH_set(sv, PAD_MAX);        /* Don't know scope end yet. */
1076             COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
1077             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1078                 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1079                 (long)i, SvPVX_const(sv),
1080                 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1081                 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1082             );
1083         }
1084     }
1085     PL_min_intro_pending = 0;
1086     PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1087     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1088                 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax+1)));
1089
1090     return PL_cop_seqmax++;
1091 }
1092
1093 /*
1094 =for apidoc pad_leavemy
1095
1096 Cleanup at end of scope during compilation: set the max seq number for
1097 lexicals in this scope and warn of any lexicals that never got introduced.
1098
1099 =cut
1100 */
1101
1102 void
1103 Perl_pad_leavemy(pTHX)
1104 {
1105     dVAR;
1106     I32 off;
1107     SV * const * const svp = AvARRAY(PL_comppad_name);
1108
1109     PL_pad_reset_pending = FALSE;
1110
1111     ASSERT_CURPAD_ACTIVE("pad_leavemy");
1112     if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1113         for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1114             const SV * const sv = svp[off];
1115             if (sv && sv != &PL_sv_undef && !SvFAKE(sv))
1116                 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1117                                  "%"SVf" never introduced",
1118                                  SVfARG(sv));
1119         }
1120     }
1121     /* "Deintroduce" my variables that are leaving with this scope. */
1122     for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
1123         const SV * const sv = svp[off];
1124         if (sv && sv != &PL_sv_undef && !SvFAKE(sv) && COP_SEQ_RANGE_HIGH(sv) == PAD_MAX) {
1125             COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
1126             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1127                 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1128                 (long)off, SvPVX_const(sv),
1129                 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1130                 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1131             );
1132         }
1133     }
1134     PL_cop_seqmax++;
1135     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1136             "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1137 }
1138
1139
1140 /*
1141 =for apidoc pad_swipe
1142
1143 Abandon the tmp in the current pad at offset po and replace with a
1144 new one.
1145
1146 =cut
1147 */
1148
1149 void
1150 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1151 {
1152     dVAR;
1153     ASSERT_CURPAD_LEGAL("pad_swipe");
1154     if (!PL_curpad)
1155         return;
1156     if (AvARRAY(PL_comppad) != PL_curpad)
1157         Perl_croak(aTHX_ "panic: pad_swipe curpad");
1158     if (!po)
1159         Perl_croak(aTHX_ "panic: pad_swipe po");
1160
1161     DEBUG_X(PerlIO_printf(Perl_debug_log,
1162                 "Pad 0x%"UVxf"[0x%"UVxf"] swipe:   %ld\n",
1163                 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1164
1165     if (PL_curpad[po])
1166         SvPADTMP_off(PL_curpad[po]);
1167     if (refadjust)
1168         SvREFCNT_dec(PL_curpad[po]);
1169
1170
1171     /* if pad tmps aren't shared between ops, then there's no need to
1172      * create a new tmp when an existing op is freed */
1173 #ifdef USE_BROKEN_PAD_RESET
1174     PL_curpad[po] = newSV(0);
1175     SvPADTMP_on(PL_curpad[po]);
1176 #else
1177     PL_curpad[po] = &PL_sv_undef;
1178 #endif
1179     if ((I32)po < PL_padix)
1180         PL_padix = po - 1;
1181 }
1182
1183
1184 /*
1185 =for apidoc pad_reset
1186
1187 Mark all the current temporaries for reuse
1188
1189 =cut
1190 */
1191
1192 /* XXX pad_reset() is currently disabled because it results in serious bugs.
1193  * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
1194  * on the stack by OPs that use them, there are several ways to get an alias
1195  * to  a shared TARG.  Such an alias will change randomly and unpredictably.
1196  * We avoid doing this until we can think of a Better Way.
1197  * GSAR 97-10-29 */
1198 static void
1199 S_pad_reset(pTHX)
1200 {
1201     dVAR;
1202 #ifdef USE_BROKEN_PAD_RESET
1203     if (AvARRAY(PL_comppad) != PL_curpad)
1204         Perl_croak(aTHX_ "panic: pad_reset curpad");
1205
1206     DEBUG_X(PerlIO_printf(Perl_debug_log,
1207             "Pad 0x%"UVxf"[0x%"UVxf"] reset:     padix %ld -> %ld",
1208             PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1209                 (long)PL_padix, (long)PL_padix_floor
1210             )
1211     );
1212
1213     if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
1214         register I32 po;
1215         for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
1216             if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
1217                 SvPADTMP_off(PL_curpad[po]);
1218         }
1219         PL_padix = PL_padix_floor;
1220     }
1221 #endif
1222     PL_pad_reset_pending = FALSE;
1223 }
1224
1225
1226 /*
1227 =for apidoc pad_tidy
1228
1229 Tidy up a pad after we've finished compiling it:
1230     * remove most stuff from the pads of anonsub prototypes;
1231     * give it a @_;
1232     * mark tmps as such.
1233
1234 =cut
1235 */
1236
1237 /* XXX DAPM surely most of this stuff should be done properly
1238  * at the right time beforehand, rather than going around afterwards
1239  * cleaning up our mistakes ???
1240  */
1241
1242 void
1243 Perl_pad_tidy(pTHX_ padtidy_type type)
1244 {
1245     dVAR;
1246
1247     ASSERT_CURPAD_ACTIVE("pad_tidy");
1248
1249     /* If this CV has had any 'eval-capable' ops planted in it
1250      * (ie it contains eval '...', //ee, /$var/ or /(?{..})/), Then any
1251      * anon prototypes in the chain of CVs should be marked as cloneable,
1252      * so that for example the eval's CV in C<< sub { eval '$x' } >> gets
1253      * the right CvOUTSIDE.
1254      * If running with -d, *any* sub may potentially have an eval
1255      * excuted within it.
1256      */
1257
1258     if (PL_cv_has_eval || PL_perldb) {
1259         const CV *cv;
1260         for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1261             if (cv != PL_compcv && CvCOMPILED(cv))
1262                 break; /* no need to mark already-compiled code */
1263             if (CvANON(cv)) {
1264                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1265                     "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1266                 CvCLONE_on(cv);
1267             }
1268         }
1269     }
1270
1271     /* extend curpad to match namepad */
1272     if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1273         av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1274
1275     if (type == padtidy_SUBCLONE) {
1276         SV * const * const namep = AvARRAY(PL_comppad_name);
1277         PADOFFSET ix;
1278
1279         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1280             SV *namesv;
1281
1282             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1283                 continue;
1284             /*
1285              * The only things that a clonable function needs in its
1286              * pad are anonymous subs.
1287              * The rest are created anew during cloning.
1288              */
1289             if (!((namesv = namep[ix]) != NULL &&
1290                   namesv != &PL_sv_undef &&
1291                    *SvPVX_const(namesv) == '&'))
1292             {
1293                 SvREFCNT_dec(PL_curpad[ix]);
1294                 PL_curpad[ix] = NULL;
1295             }
1296         }
1297     }
1298     else if (type == padtidy_SUB) {
1299         /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1300         AV * const av = newAV();                        /* Will be @_ */
1301         av_store(PL_comppad, 0, MUTABLE_SV(av));
1302         AvREIFY_only(av);
1303     }
1304
1305     if (type == padtidy_SUB || type == padtidy_FORMAT) {
1306         SV * const * const namep = AvARRAY(PL_comppad_name);
1307         PADOFFSET ix;
1308         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1309             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1310                 continue;
1311             if (!SvPADMY(PL_curpad[ix])) {
1312                 SvPADTMP_on(PL_curpad[ix]);
1313             } else if (!SvFAKE(namep[ix])) {
1314                 /* This is a work around for how the current implementation of
1315                    ?{ } blocks in regexps interacts with lexicals.
1316
1317                    One of our lexicals.
1318                    Can't do this on all lexicals, otherwise sub baz() won't
1319                    compile in
1320
1321                    my $foo;
1322
1323                    sub bar { ++$foo; }
1324
1325                    sub baz { ++$foo; }
1326
1327                    because completion of compiling &bar calling pad_tidy()
1328                    would cause (top level) $foo to be marked as stale, and
1329                    "no longer available".  */
1330                 SvPADSTALE_on(PL_curpad[ix]);
1331             }
1332         }
1333     }
1334     PL_curpad = AvARRAY(PL_comppad);
1335 }
1336
1337
1338 /*
1339 =for apidoc pad_free
1340
1341 Free the SV at offset po in the current pad.
1342
1343 =cut
1344 */
1345
1346 /* XXX DAPM integrate with pad_swipe ???? */
1347 void
1348 Perl_pad_free(pTHX_ PADOFFSET po)
1349 {
1350     dVAR;
1351     ASSERT_CURPAD_LEGAL("pad_free");
1352     if (!PL_curpad)
1353         return;
1354     if (AvARRAY(PL_comppad) != PL_curpad)
1355         Perl_croak(aTHX_ "panic: pad_free curpad");
1356     if (!po)
1357         Perl_croak(aTHX_ "panic: pad_free po");
1358
1359     DEBUG_X(PerlIO_printf(Perl_debug_log,
1360             "Pad 0x%"UVxf"[0x%"UVxf"] free:    %ld\n",
1361             PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1362     );
1363
1364     if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
1365         SvPADTMP_off(PL_curpad[po]);
1366 #ifdef USE_ITHREADS
1367         /* SV could be a shared hash key (eg bugid #19022) */
1368         if (!SvIsCOW(PL_curpad[po]))
1369             SvREADONLY_off(PL_curpad[po]);      /* could be a freed constant */
1370 #endif
1371     }
1372     if ((I32)po < PL_padix)
1373         PL_padix = po - 1;
1374 }
1375
1376
1377
1378 /*
1379 =for apidoc do_dump_pad
1380
1381 Dump the contents of a padlist
1382
1383 =cut
1384 */
1385
1386 void
1387 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1388 {
1389     dVAR;
1390     const AV *pad_name;
1391     const AV *pad;
1392     SV **pname;
1393     SV **ppad;
1394     I32 ix;
1395
1396     PERL_ARGS_ASSERT_DO_DUMP_PAD;
1397
1398     if (!padlist) {
1399         return;
1400     }
1401     pad_name = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 0, FALSE));
1402     pad = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 1, FALSE));
1403     pname = AvARRAY(pad_name);
1404     ppad = AvARRAY(pad);
1405     Perl_dump_indent(aTHX_ level, file,
1406             "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1407             PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1408     );
1409
1410     for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1411         const SV *namesv = pname[ix];
1412         if (namesv && namesv == &PL_sv_undef) {
1413             namesv = NULL;
1414         }
1415         if (namesv) {
1416             if (SvFAKE(namesv))
1417                 Perl_dump_indent(aTHX_ level+1, file,
1418                     "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1419                     (int) ix,
1420                     PTR2UV(ppad[ix]),
1421                     (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1422                     SvPVX_const(namesv),
1423                     (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1424                     (unsigned long)PARENT_PAD_INDEX(namesv)
1425
1426                 );
1427             else
1428                 Perl_dump_indent(aTHX_ level+1, file,
1429                     "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
1430                     (int) ix,
1431                     PTR2UV(ppad[ix]),
1432                     (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1433                     (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1434                     (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1435                     SvPVX_const(namesv)
1436                 );
1437         }
1438         else if (full) {
1439             Perl_dump_indent(aTHX_ level+1, file,
1440                 "%2d. 0x%"UVxf"<%lu>\n",
1441                 (int) ix,
1442                 PTR2UV(ppad[ix]),
1443                 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1444             );
1445         }
1446     }
1447 }
1448
1449
1450
1451 /*
1452 =for apidoc cv_dump
1453
1454 dump the contents of a CV
1455
1456 =cut
1457 */
1458
1459 #ifdef DEBUGGING
1460 STATIC void
1461 S_cv_dump(pTHX_ const CV *cv, const char *title)
1462 {
1463     dVAR;
1464     const CV * const outside = CvOUTSIDE(cv);
1465     AV* const padlist = CvPADLIST(cv);
1466
1467     PERL_ARGS_ASSERT_CV_DUMP;
1468
1469     PerlIO_printf(Perl_debug_log,
1470                   "  %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1471                   title,
1472                   PTR2UV(cv),
1473                   (CvANON(cv) ? "ANON"
1474                    : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1475                    : (cv == PL_main_cv) ? "MAIN"
1476                    : CvUNIQUE(cv) ? "UNIQUE"
1477                    : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1478                   PTR2UV(outside),
1479                   (!outside ? "null"
1480                    : CvANON(outside) ? "ANON"
1481                    : (outside == PL_main_cv) ? "MAIN"
1482                    : CvUNIQUE(outside) ? "UNIQUE"
1483                    : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1484
1485     PerlIO_printf(Perl_debug_log,
1486                     "    PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1487     do_dump_pad(1, Perl_debug_log, padlist, 1);
1488 }
1489 #endif /* DEBUGGING */
1490
1491
1492
1493
1494
1495 /*
1496 =for apidoc cv_clone
1497
1498 Clone a CV: make a new CV which points to the same code etc, but which
1499 has a newly-created pad built by copying the prototype pad and capturing
1500 any outer lexicals.
1501
1502 =cut
1503 */
1504
1505 CV *
1506 Perl_cv_clone(pTHX_ CV *proto)
1507 {
1508     dVAR;
1509     I32 ix;
1510     AV* const protopadlist = CvPADLIST(proto);
1511     const AV *const protopad_name = (const AV *)*av_fetch(protopadlist, 0, FALSE);
1512     const AV *const protopad = (const AV *)*av_fetch(protopadlist, 1, FALSE);
1513     SV** const pname = AvARRAY(protopad_name);
1514     SV** const ppad = AvARRAY(protopad);
1515     const I32 fname = AvFILLp(protopad_name);
1516     const I32 fpad = AvFILLp(protopad);
1517     CV* cv;
1518     SV** outpad;
1519     CV* outside;
1520     long depth;
1521
1522     PERL_ARGS_ASSERT_CV_CLONE;
1523
1524     assert(!CvUNIQUE(proto));
1525
1526     /* Since cloneable anon subs can be nested, CvOUTSIDE may point
1527      * to a prototype; we instead want the cloned parent who called us.
1528      * Note that in general for formats, CvOUTSIDE != find_runcv */
1529
1530     outside = CvOUTSIDE(proto);
1531     if (outside && CvCLONE(outside) && ! CvCLONED(outside))
1532         outside = find_runcv(NULL);
1533     depth = CvDEPTH(outside);
1534     assert(depth || SvTYPE(proto) == SVt_PVFM);
1535     if (!depth)
1536         depth = 1;
1537     assert(CvPADLIST(outside));
1538
1539     ENTER;
1540     SAVESPTR(PL_compcv);
1541
1542     cv = PL_compcv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
1543     CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE);
1544     CvCLONED_on(cv);
1545
1546 #ifdef USE_ITHREADS
1547     CvFILE(cv)          = CvISXSUB(proto) ? CvFILE(proto)
1548                                           : savepv(CvFILE(proto));
1549 #else
1550     CvFILE(cv)          = CvFILE(proto);
1551 #endif
1552     CvGV(cv)            = CvGV(proto);
1553     CvSTASH(cv)         = CvSTASH(proto);
1554     OP_REFCNT_LOCK;
1555     CvROOT(cv)          = OpREFCNT_inc(CvROOT(proto));
1556     OP_REFCNT_UNLOCK;
1557     CvSTART(cv)         = CvSTART(proto);
1558     CvOUTSIDE(cv)       = MUTABLE_CV(SvREFCNT_inc_simple(outside));
1559     CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
1560
1561     if (SvPOK(proto))
1562         sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
1563
1564     CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
1565
1566     av_fill(PL_comppad, fpad);
1567     for (ix = fname; ix >= 0; ix--)
1568         av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
1569
1570     PL_curpad = AvARRAY(PL_comppad);
1571
1572     outpad = AvARRAY(AvARRAY(CvPADLIST(outside))[depth]);
1573
1574     for (ix = fpad; ix > 0; ix--) {
1575         SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
1576         SV *sv = NULL;
1577         if (namesv && namesv != &PL_sv_undef) { /* lexical */
1578             if (SvFAKE(namesv)) {   /* lexical from outside? */
1579                 sv = outpad[PARENT_PAD_INDEX(namesv)];
1580                 assert(sv);
1581                 /* formats may have an inactive parent,
1582                    while my $x if $false can leave an active var marked as
1583                    stale. And state vars are always available */
1584                 if (SvPADSTALE(sv) && !SvPAD_STATE(namesv)) {
1585                     Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1586                                    "Variable \"%s\" is not available", SvPVX_const(namesv));
1587                     sv = NULL;
1588                 }
1589                 else 
1590                     SvREFCNT_inc_simple_void_NN(sv);
1591             }
1592             if (!sv) {
1593                 const char sigil = SvPVX_const(namesv)[0];
1594                 if (sigil == '&')
1595                     sv = SvREFCNT_inc(ppad[ix]);
1596                 else if (sigil == '@')
1597                     sv = MUTABLE_SV(newAV());
1598                 else if (sigil == '%')
1599                     sv = MUTABLE_SV(newHV());
1600                 else
1601                     sv = newSV(0);
1602                 SvPADMY_on(sv);
1603                 /* reset the 'assign only once' flag on each state var */
1604                 if (SvPAD_STATE(namesv))
1605                     SvPADSTALE_on(sv);
1606             }
1607         }
1608         else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
1609             sv = SvREFCNT_inc_NN(ppad[ix]);
1610         }
1611         else {
1612             sv = newSV(0);
1613             SvPADTMP_on(sv);
1614         }
1615         PL_curpad[ix] = sv;
1616     }
1617
1618     DEBUG_Xv(
1619         PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
1620         cv_dump(outside, "Outside");
1621         cv_dump(proto,   "Proto");
1622         cv_dump(cv,      "To");
1623     );
1624
1625     LEAVE;
1626
1627     if (CvCONST(cv)) {
1628         /* Constant sub () { $x } closing over $x - see lib/constant.pm:
1629          * The prototype was marked as a candiate for const-ization,
1630          * so try to grab the current const value, and if successful,
1631          * turn into a const sub:
1632          */
1633         SV* const const_sv = op_const_sv(CvSTART(cv), cv);
1634         if (const_sv) {
1635             SvREFCNT_dec(cv);
1636             cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
1637         }
1638         else {
1639             CvCONST_off(cv);
1640         }
1641     }
1642
1643     return cv;
1644 }
1645
1646
1647 /*
1648 =for apidoc pad_fixup_inner_anons
1649
1650 For any anon CVs in the pad, change CvOUTSIDE of that CV from
1651 old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
1652 moved to a pre-existing CV struct.
1653
1654 =cut
1655 */
1656
1657 void
1658 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
1659 {
1660     dVAR;
1661     I32 ix;
1662     AV * const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
1663     AV * const comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
1664     SV ** const namepad = AvARRAY(comppad_name);
1665     SV ** const curpad = AvARRAY(comppad);
1666
1667     PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
1668     PERL_UNUSED_ARG(old_cv);
1669
1670     for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
1671         const SV * const namesv = namepad[ix];
1672         if (namesv && namesv != &PL_sv_undef
1673             && *SvPVX_const(namesv) == '&')
1674         {
1675             CV * const innercv = MUTABLE_CV(curpad[ix]);
1676             assert(CvWEAKOUTSIDE(innercv));
1677             assert(CvOUTSIDE(innercv) == old_cv);
1678             CvOUTSIDE(innercv) = new_cv;
1679         }
1680     }
1681 }
1682
1683
1684 /*
1685 =for apidoc pad_push
1686
1687 Push a new pad frame onto the padlist, unless there's already a pad at
1688 this depth, in which case don't bother creating a new one.  Then give
1689 the new pad an @_ in slot zero.
1690
1691 =cut
1692 */
1693
1694 void
1695 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
1696 {
1697     dVAR;
1698
1699     PERL_ARGS_ASSERT_PAD_PUSH;
1700
1701     if (depth > AvFILLp(padlist)) {
1702         SV** const svp = AvARRAY(padlist);
1703         AV* const newpad = newAV();
1704         SV** const oldpad = AvARRAY(svp[depth-1]);
1705         I32 ix = AvFILLp((const AV *)svp[1]);
1706         const I32 names_fill = AvFILLp((const AV *)svp[0]);
1707         SV** const names = AvARRAY(svp[0]);
1708         AV *av;
1709
1710         for ( ;ix > 0; ix--) {
1711             if (names_fill >= ix && names[ix] != &PL_sv_undef) {
1712                 const char sigil = SvPVX_const(names[ix])[0];
1713                 if ((SvFLAGS(names[ix]) & SVf_FAKE)
1714                         || (SvFLAGS(names[ix]) & SVpad_STATE)
1715                         || sigil == '&')
1716                 {
1717                     /* outer lexical or anon code */
1718                     av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
1719                 }
1720                 else {          /* our own lexical */
1721                     SV *sv; 
1722                     if (sigil == '@')
1723                         sv = MUTABLE_SV(newAV());
1724                     else if (sigil == '%')
1725                         sv = MUTABLE_SV(newHV());
1726                     else
1727                         sv = newSV(0);
1728                     av_store(newpad, ix, sv);
1729                     SvPADMY_on(sv);
1730                 }
1731             }
1732             else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
1733                 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
1734             }
1735             else {
1736                 /* save temporaries on recursion? */
1737                 SV * const sv = newSV(0);
1738                 av_store(newpad, ix, sv);
1739                 SvPADTMP_on(sv);
1740             }
1741         }
1742         av = newAV();
1743         av_store(newpad, 0, MUTABLE_SV(av));
1744         AvREIFY_only(av);
1745
1746         av_store(padlist, depth, MUTABLE_SV(newpad));
1747         AvFILLp(padlist) = depth;
1748     }
1749 }
1750
1751
1752 HV *
1753 Perl_pad_compname_type(pTHX_ const PADOFFSET po)
1754 {
1755     dVAR;
1756     SV* const * const av = av_fetch(PL_comppad_name, po, FALSE);
1757     if ( SvPAD_TYPED(*av) ) {
1758         return SvSTASH(*av);
1759     }
1760     return NULL;
1761 }
1762
1763 #if defined(USE_ITHREADS)
1764
1765 #  define av_dup_inc(s,t)       MUTABLE_AV(sv_dup_inc((const SV *)s,t))
1766
1767 AV *
1768 Perl_padlist_dup(pTHX_ AV *const srcpad, CLONE_PARAMS *const param)
1769 {
1770     AV *dstpad;
1771     PERL_ARGS_ASSERT_PADLIST_DUP;
1772
1773     if (!srcpad)
1774         return NULL;
1775
1776     assert(!AvREAL(srcpad));
1777
1778     if (param->flags & CLONEf_COPY_STACKS
1779         || SvREFCNT(AvARRAY(srcpad)[1]) > 1) {
1780         /* XXX padlists are real, but pretend to be not */
1781         AvREAL_on(srcpad);
1782         dstpad = av_dup_inc(srcpad, param);
1783         AvREAL_off(srcpad);
1784         AvREAL_off(dstpad);
1785         assert (SvREFCNT(AvARRAY(srcpad)[1]) == 1);
1786     } else {
1787         /* CvDEPTH() on our subroutine will be set to 0, so there's no need
1788            to build anything other than the first level of pads.  */
1789
1790         I32 ix = AvFILLp((const AV *)AvARRAY(srcpad)[1]);
1791         AV *pad1;
1792         const I32 names_fill = AvFILLp((const AV *)(AvARRAY(srcpad)[0]));
1793         const AV *const srcpad1 = (const AV *) AvARRAY(srcpad)[1];
1794         SV **oldpad = AvARRAY(srcpad1);
1795         SV **names;
1796         SV **pad1a;
1797         AV *args;
1798         /* look for it in the table first.
1799            I *think* that it shouldn't be possible to find it there.
1800            Well, except for how Perl_sv_compile_2op() "works" :-(   */
1801         dstpad = (AV*)ptr_table_fetch(PL_ptr_table, srcpad);
1802
1803         if (dstpad)
1804             return dstpad;
1805
1806         dstpad = newAV();
1807         ptr_table_store(PL_ptr_table, srcpad, dstpad);
1808         AvREAL_off(dstpad);
1809         av_extend(dstpad, 1);
1810         AvARRAY(dstpad)[0] = MUTABLE_SV(av_dup_inc(AvARRAY(srcpad)[0], param));
1811         names = AvARRAY(AvARRAY(dstpad)[0]);
1812
1813         pad1 = newAV();
1814
1815         av_extend(pad1, ix);
1816         AvARRAY(dstpad)[1] = MUTABLE_SV(pad1);
1817         pad1a = AvARRAY(pad1);
1818         AvFILLp(dstpad) = 1;
1819
1820         if (ix > -1) {
1821             AvFILLp(pad1) = ix;
1822
1823             for ( ;ix > 0; ix--) {
1824                 if (!oldpad[ix]) {
1825                     pad1a[ix] = NULL;
1826                 } else if (names_fill >= ix && names[ix] != &PL_sv_undef) {
1827                     const char sigil = SvPVX_const(names[ix])[0];
1828                     if ((SvFLAGS(names[ix]) & SVf_FAKE)
1829                         || (SvFLAGS(names[ix]) & SVpad_STATE)
1830                         || sigil == '&')
1831                         {
1832                             /* outer lexical or anon code */
1833                             pad1a[ix] = sv_dup_inc(oldpad[ix], param);
1834                         }
1835                     else {              /* our own lexical */
1836                         if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
1837                             /* This is a work around for how the current
1838                                implementation of ?{ } blocks in regexps
1839                                interacts with lexicals.  */
1840                             pad1a[ix] = sv_dup_inc(oldpad[ix], param);
1841                         } else {
1842                             SV *sv; 
1843                             
1844                             if (sigil == '@')
1845                                 sv = MUTABLE_SV(newAV());
1846                             else if (sigil == '%')
1847                                 sv = MUTABLE_SV(newHV());
1848                             else
1849                                 sv = newSV(0);
1850                             pad1a[ix] = sv;
1851                             SvPADMY_on(sv);
1852                         }
1853                     }
1854                 }
1855                 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
1856                     pad1a[ix] = sv_dup_inc(oldpad[ix], param);
1857                 }
1858                 else {
1859                     /* save temporaries on recursion? */
1860                     SV * const sv = newSV(0);
1861                     pad1a[ix] = sv;
1862
1863                     /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
1864                        FIXTHAT before merging this branch.
1865                        (And I know how to) */
1866                     if (SvPADMY(oldpad[ix]))
1867                         SvPADMY_on(sv);
1868                     else
1869                         SvPADTMP_on(sv);
1870                 }
1871             }
1872
1873             if (oldpad[0]) {
1874                 args = newAV();                 /* Will be @_ */
1875                 AvREIFY_only(args);
1876                 pad1a[0] = (SV *)args;
1877             }
1878         }
1879     }
1880
1881     return dstpad;
1882 }
1883
1884 #endif
1885
1886 /*
1887  * Local variables:
1888  * c-indentation-style: bsd
1889  * c-basic-offset: 4
1890  * indent-tabs-mode: t
1891  * End:
1892  *
1893  * ex: set ts=8 sts=4 sw=4 noet:
1894  */