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