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