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