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