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