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