expand comment in Perl_pad_tidy
[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 =for apidoc Amx|PADLIST *|CvPADLIST|CV *cv
31
32 CV's can have CvPADLIST(cv) set to point to a PADLIST.  This is the CV's
33 scratchpad, which stores lexical variables and opcode temporary and
34 per-thread values.
35
36 For these purposes "formats" are a kind-of CV; eval""s are too (except they're
37 not callable at will and are always thrown away after the eval"" is done
38 executing).  Require'd files are simply evals without any outer lexical
39 scope.
40
41 XSUBs don't have CvPADLIST set - dXSTARG fetches values from PL_curpad,
42 but that is really the callers pad (a slot of which is allocated by
43 every entersub).
44
45 The PADLIST has a C array where pads are stored.
46
47 The 0th entry of the PADLIST is a PADNAMELIST (which is actually just an
48 AV, but that may change) which represents the "names" or rather
49 the "static type information" for lexicals.  The individual elements of a
50 PADNAMELIST are PADNAMEs (just SVs; but, again, that may change).  Future
51 refactorings might stop the PADNAMELIST from being stored in the PADLIST's
52 array, so don't rely on it.  See L</PadlistNAMES>.
53
54 The CvDEPTH'th entry of a PADLIST is a PAD (an AV) which is the stack frame
55 at that depth of recursion into the CV.  The 0th slot of a frame AV is an
56 AV which is @_.  Other entries are storage for variables and op targets.
57
58 Iterating over the PADNAMELIST iterates over all possible pad
59 items.  Pad slots that are SVs_PADTMP (targets/GVs/constants) end up having
60 &PL_sv_undef "names" (see pad_alloc()).
61
62 Only my/our variable (SvPADMY/PADNAME_isOUR) slots get valid names.
63 The rest are op targets/GVs/constants which are statically allocated
64 or resolved at compile time.  These don't have names by which they
65 can be looked up from Perl code at run time through eval"" the way
66 my/our variables can be.  Since they can't be looked up by "name"
67 but only by their index allocated at compile time (which is usually
68 in PL_op->op_targ), wasting a name SV for them doesn't make sense.
69
70 The SVs in the names AV have their PV being the name of the variable.
71 xlow+1..xhigh inclusive in the NV union is a range of cop_seq numbers for
72 which the name is valid (accessed through the macros COP_SEQ_RANGE_LOW and
73 _HIGH).  During compilation, these fields may hold the special value
74 PERL_PADSEQ_INTRO to indicate various stages:
75
76    COP_SEQ_RANGE_LOW        _HIGH
77    -----------------        -----
78    PERL_PADSEQ_INTRO            0   variable not yet introduced:   { my ($x
79    valid-seq#   PERL_PADSEQ_INTRO   variable in scope:             { my ($x)
80    valid-seq#          valid-seq#   compilation of scope complete: { my ($x) }
81
82 For typed lexicals name SV is SVt_PVMG and SvSTASH
83 points at the type.  For C<our> lexicals, the type is also SVt_PVMG, with the
84 SvOURSTASH slot pointing at the stash of the associated global (so that
85 duplicate C<our> declarations in the same package can be detected).  SvUVX is
86 sometimes hijacked to store the generation number during compilation.
87
88 If PADNAME_OUTER (SvFAKE) is set on the
89 name SV, then that slot in the frame AV is
90 a REFCNT'ed reference to a lexical from "outside". In this case,
91 the name SV does not use xlow and xhigh to store a cop_seq range, since it is
92 in scope throughout. Instead xhigh stores some flags containing info about
93 the real lexical (is it declared in an anon, and is it capable of being
94 instantiated multiple times?), and for fake ANONs, xlow contains the index
95 within the parent's pad where the lexical's value is stored, to make
96 cloning quicker.
97
98 If the 'name' is '&' the corresponding entry in the PAD
99 is a CV representing a possible closure.
100 (PADNAME_OUTER and name of '&' is not a
101 meaningful combination currently but could
102 become so if C<my sub foo {}> is implemented.)
103
104 Note that formats are treated as anon subs, and are cloned each time
105 write is called (if necessary).
106
107 The flag SVs_PADSTALE is cleared on lexicals each time the my() is executed,
108 and set on scope exit.  This allows the
109 'Variable $x is not available' warning
110 to be generated in evals, such as 
111
112     { my $x = 1; sub f { eval '$x'} } f();
113
114 For state vars, SVs_PADSTALE is overloaded to mean 'not yet initialised'.
115
116 =for apidoc AmxU|PADNAMELIST *|PL_comppad_name
117
118 During compilation, this points to the array containing the names part
119 of the pad for the currently-compiling code.
120
121 =for apidoc AmxU|PAD *|PL_comppad
122
123 During compilation, this points to the array containing the values
124 part of the pad for the currently-compiling code.  (At runtime a CV may
125 have many such value arrays; at compile time just one is constructed.)
126 At runtime, this points to the array containing the currently-relevant
127 values for the pad for the currently-executing code.
128
129 =for apidoc AmxU|SV **|PL_curpad
130
131 Points directly to the body of the L</PL_comppad> array.
132 (I.e., this is C<PAD_ARRAY(PL_comppad)>.)
133
134 =cut
135 */
136
137
138 #include "EXTERN.h"
139 #define PERL_IN_PAD_C
140 #include "perl.h"
141 #include "keywords.h"
142
143 #define COP_SEQ_RANGE_LOW_set(sv,val)           \
144   STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END
145 #define COP_SEQ_RANGE_HIGH_set(sv,val)          \
146   STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
147
148 #define PARENT_PAD_INDEX_set(sv,val)            \
149   STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END
150 #define PARENT_FAKELEX_FLAGS_set(sv,val)        \
151   STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
152
153 /*
154 =for apidoc mx|void|pad_peg|const char *s
155
156 When PERL_MAD is enabled, this is a small no-op function that gets called
157 at the start of each pad-related function.  It can be breakpointed to
158 track all pad operations.  The parameter is a string indicating the type
159 of pad operation being performed.
160
161 =cut
162 */
163
164 #ifdef PERL_MAD
165 void pad_peg(const char* s) {
166     static int pegcnt; /* XXX not threadsafe */
167     PERL_UNUSED_ARG(s);
168
169     PERL_ARGS_ASSERT_PAD_PEG;
170
171     pegcnt++;
172 }
173 #endif
174
175 /*
176 This is basically sv_eq_flags() in sv.c, but we avoid the magic
177 and bytes checking.
178 */
179
180 static bool
181 sv_eq_pvn_flags(pTHX_ const SV *sv, const char* pv, const STRLEN pvlen, const U32 flags) {
182     if ( (SvUTF8(sv) & SVf_UTF8 ) != (flags & SVf_UTF8) ) {
183         const char *pv1 = SvPVX_const(sv);
184         STRLEN cur1     = SvCUR(sv);
185         const char *pv2 = pv;
186         STRLEN cur2     = pvlen;
187         if (PL_encoding) {
188               SV* svrecode = NULL;
189               if (SvUTF8(sv)) {
190                    svrecode = newSVpvn(pv2, cur2);
191                    sv_recode_to_utf8(svrecode, PL_encoding);
192                    pv2      = SvPV_const(svrecode, cur2);
193               }
194               else {
195                    svrecode = newSVpvn(pv1, cur1);
196                    sv_recode_to_utf8(svrecode, PL_encoding);
197                    pv1      = SvPV_const(svrecode, cur1);
198               }
199               SvREFCNT_dec_NN(svrecode);
200         }
201         if (flags & SVf_UTF8)
202             return (bytes_cmp_utf8(
203                         (const U8*)pv1, cur1,
204                         (const U8*)pv2, cur2) == 0);
205         else
206             return (bytes_cmp_utf8(
207                         (const U8*)pv2, cur2,
208                         (const U8*)pv1, cur1) == 0);
209     }
210     else
211         return ((SvPVX_const(sv) == pv)
212                     || memEQ(SvPVX_const(sv), pv, pvlen));
213 }
214
215
216 /*
217 =for apidoc Am|PADLIST *|pad_new|int flags
218
219 Create a new padlist, updating the global variables for the
220 currently-compiling padlist to point to the new padlist.  The following
221 flags can be OR'ed together:
222
223     padnew_CLONE        this pad is for a cloned CV
224     padnew_SAVE         save old globals on the save stack
225     padnew_SAVESUB      also save extra stuff for start of sub
226
227 =cut
228 */
229
230 PADLIST *
231 Perl_pad_new(pTHX_ int flags)
232 {
233     dVAR;
234     PADLIST *padlist;
235     PAD *padname, *pad;
236     PAD **ary;
237
238     ASSERT_CURPAD_LEGAL("pad_new");
239
240     /* XXX DAPM really need a new SAVEt_PAD which restores all or most
241      * vars (based on flags) rather than storing vals + addresses for
242      * each individually. Also see pad_block_start.
243      * XXX DAPM Try to see whether all these conditionals are required
244      */
245
246     /* save existing state, ... */
247
248     if (flags & padnew_SAVE) {
249         SAVECOMPPAD();
250         if (! (flags & padnew_CLONE)) {
251             SAVESPTR(PL_comppad_name);
252             SAVEI32(PL_padix);
253             SAVEI32(PL_comppad_name_fill);
254             SAVEI32(PL_min_intro_pending);
255             SAVEI32(PL_max_intro_pending);
256             SAVEBOOL(PL_cv_has_eval);
257             if (flags & padnew_SAVESUB) {
258                 SAVEBOOL(PL_pad_reset_pending);
259             }
260         }
261     }
262     /* XXX DAPM interestingly, PL_comppad_name_floor never seems to be
263      * saved - check at some pt that this is okay */
264
265     /* ... create new pad ... */
266
267     Newxz(padlist, 1, PADLIST);
268     pad         = newAV();
269
270     if (flags & padnew_CLONE) {
271         /* XXX DAPM  I dont know why cv_clone needs it
272          * doing differently yet - perhaps this separate branch can be
273          * dispensed with eventually ???
274          */
275
276         AV * const a0 = newAV();                        /* will be @_ */
277         av_store(pad, 0, MUTABLE_SV(a0));
278         AvREIFY_only(a0);
279
280         padname = (PAD *)SvREFCNT_inc_simple_NN(PL_comppad_name);
281     }
282     else {
283         av_store(pad, 0, NULL);
284         padname = newAV();
285     }
286
287     /* Most subroutines never recurse, hence only need 2 entries in the padlist
288        array - names, and depth=1.  The default for av_store() is to allocate
289        0..3, and even an explicit call to av_extend() with <3 will be rounded
290        up, so we inline the allocation of the array here.  */
291     Newx(ary, 2, PAD *);
292     PadlistMAX(padlist) = 1;
293     PadlistARRAY(padlist) = ary;
294     ary[0] = padname;
295     ary[1] = pad;
296
297     /* ... then update state variables */
298
299     PL_comppad          = pad;
300     PL_curpad           = AvARRAY(pad);
301
302     if (! (flags & padnew_CLONE)) {
303         PL_comppad_name      = padname;
304         PL_comppad_name_fill = 0;
305         PL_min_intro_pending = 0;
306         PL_padix             = 0;
307         PL_cv_has_eval       = 0;
308     }
309
310     DEBUG_X(PerlIO_printf(Perl_debug_log,
311           "Pad 0x%"UVxf"[0x%"UVxf"] new:       compcv=0x%"UVxf
312               " name=0x%"UVxf" flags=0x%"UVxf"\n",
313           PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(PL_compcv),
314               PTR2UV(padname), (UV)flags
315         )
316     );
317
318     return (PADLIST*)padlist;
319 }
320
321
322 /*
323 =head1 Embedding Functions
324
325 =for apidoc cv_undef
326
327 Clear out all the active components of a CV. This can happen either
328 by an explicit C<undef &foo>, or by the reference count going to zero.
329 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
330 children can still follow the full lexical scope chain.
331
332 =cut
333 */
334
335 void
336 Perl_cv_undef(pTHX_ CV *cv)
337 {
338     dVAR;
339     const PADLIST *padlist = CvPADLIST(cv);
340     bool const slabbed = !!CvSLABBED(cv);
341
342     PERL_ARGS_ASSERT_CV_UNDEF;
343
344     DEBUG_X(PerlIO_printf(Perl_debug_log,
345           "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
346             PTR2UV(cv), PTR2UV(PL_comppad))
347     );
348
349     if (CvFILE(cv) && CvDYNFILE(cv)) {
350         Safefree(CvFILE(cv));
351     }
352     CvFILE(cv) = NULL;
353
354     CvSLABBED_off(cv);
355     if (!CvISXSUB(cv) && CvROOT(cv)) {
356         if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
357             Perl_croak(aTHX_ "Can't undef active subroutine");
358         ENTER;
359
360         PAD_SAVE_SETNULLPAD();
361
362         if (slabbed) OpslabREFCNT_dec_padok(OpSLAB(CvROOT(cv)));
363         op_free(CvROOT(cv));
364         CvROOT(cv) = NULL;
365         CvSTART(cv) = NULL;
366         LEAVE;
367     }
368     else if (slabbed && CvSTART(cv)) {
369         ENTER;
370         PAD_SAVE_SETNULLPAD();
371
372         /* discard any leaked ops */
373         if (PL_parser)
374             parser_free_nexttoke_ops(PL_parser, (OPSLAB *)CvSTART(cv));
375         opslab_force_free((OPSLAB *)CvSTART(cv));
376         CvSTART(cv) = NULL;
377
378         LEAVE;
379     }
380 #ifdef DEBUGGING
381     else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", cv);
382 #endif
383     SvPOK_off(MUTABLE_SV(cv));          /* forget prototype */
384     sv_unmagic((SV *)cv, PERL_MAGIC_checkcall);
385     if (CvNAMED(cv)) CvNAME_HEK_set(cv, NULL);
386     else             CvGV_set(cv, NULL);
387
388     /* This statement and the subsequence if block was pad_undef().  */
389     pad_peg("pad_undef");
390
391     if (padlist) {
392         I32 ix;
393
394         /* Free the padlist associated with a CV.
395            If parts of it happen to be current, we null the relevant PL_*pad*
396            global vars so that we don't have any dangling references left.
397            We also repoint the CvOUTSIDE of any about-to-be-orphaned inner
398            subs to the outer of this cv.  */
399
400         DEBUG_X(PerlIO_printf(Perl_debug_log,
401                               "Pad undef: cv=0x%"UVxf" padlist=0x%"UVxf" comppad=0x%"UVxf"\n",
402                               PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad))
403                 );
404
405         /* detach any '&' anon children in the pad; if afterwards they
406          * are still live, fix up their CvOUTSIDEs to point to our outside,
407          * bypassing us. */
408         /* XXX DAPM for efficiency, we should only do this if we know we have
409          * children, or integrate this loop with general cleanup */
410
411         if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */
412             CV * const outercv = CvOUTSIDE(cv);
413             const U32 seq = CvOUTSIDE_SEQ(cv);
414             PAD * const comppad_name = PadlistARRAY(padlist)[0];
415             SV ** const namepad = AvARRAY(comppad_name);
416             PAD * const comppad = PadlistARRAY(padlist)[1];
417             SV ** const curpad = AvARRAY(comppad);
418             for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
419                 SV * const namesv = namepad[ix];
420                 if (namesv && namesv != &PL_sv_undef
421                     && *SvPVX_const(namesv) == '&')
422                     {
423                         CV * const innercv = MUTABLE_CV(curpad[ix]);
424                         U32 inner_rc = SvREFCNT(innercv);
425                         assert(inner_rc);
426                         assert(SvTYPE(innercv) != SVt_PVFM);
427
428                         if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/  */
429                             curpad[ix] = NULL;
430                             SvREFCNT_dec_NN(innercv);
431                             inner_rc--;
432                         }
433
434                         /* in use, not just a prototype */
435                         if (inner_rc && (CvOUTSIDE(innercv) == cv)) {
436                             assert(CvWEAKOUTSIDE(innercv));
437                             /* don't relink to grandfather if he's being freed */
438                             if (outercv && SvREFCNT(outercv)) {
439                                 CvWEAKOUTSIDE_off(innercv);
440                                 CvOUTSIDE(innercv) = outercv;
441                                 CvOUTSIDE_SEQ(innercv) = seq;
442                                 SvREFCNT_inc_simple_void_NN(outercv);
443                             }
444                             else {
445                                 CvOUTSIDE(innercv) = NULL;
446                             }
447                         }
448                     }
449             }
450         }
451
452         ix = PadlistMAX(padlist);
453         while (ix > 0) {
454             PAD * const sv = PadlistARRAY(padlist)[ix--];
455             if (sv) {
456                 if (sv == PL_comppad) {
457                     PL_comppad = NULL;
458                     PL_curpad = NULL;
459                 }
460                 SvREFCNT_dec_NN(sv);
461             }
462         }
463         {
464             PAD * const sv = PadlistARRAY(padlist)[0];
465             if (sv == PL_comppad_name && SvREFCNT(sv) == 1)
466                 PL_comppad_name = NULL;
467             SvREFCNT_dec(sv);
468         }
469         if (PadlistARRAY(padlist)) Safefree(PadlistARRAY(padlist));
470         Safefree(padlist);
471         CvPADLIST(cv) = NULL;
472     }
473
474
475     /* remove CvOUTSIDE unless this is an undef rather than a free */
476     if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
477         if (!CvWEAKOUTSIDE(cv))
478             SvREFCNT_dec(CvOUTSIDE(cv));
479         CvOUTSIDE(cv) = NULL;
480     }
481     if (CvCONST(cv)) {
482         SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
483         CvCONST_off(cv);
484     }
485     if (CvISXSUB(cv) && CvXSUB(cv)) {
486         CvXSUB(cv) = NULL;
487     }
488     /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
489      * ref status of CvOUTSIDE and CvGV, and ANON, which pp_entersub uses
490      * to choose an error message */
491     CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON);
492 }
493
494 /*
495 =for apidoc cv_forget_slab
496
497 When a CV has a reference count on its slab (CvSLABBED), it is responsible
498 for making sure it is freed.  (Hence, no two CVs should ever have a
499 reference count on the same slab.)  The CV only needs to reference the slab
500 during compilation.  Once it is compiled and CvROOT attached, it has
501 finished its job, so it can forget the slab.
502
503 =cut
504 */
505
506 void
507 Perl_cv_forget_slab(pTHX_ CV *cv)
508 {
509     const bool slabbed = !!CvSLABBED(cv);
510     OPSLAB *slab = NULL;
511
512     PERL_ARGS_ASSERT_CV_FORGET_SLAB;
513
514     if (!slabbed) return;
515
516     CvSLABBED_off(cv);
517
518     if      (CvROOT(cv))  slab = OpSLAB(CvROOT(cv));
519     else if (CvSTART(cv)) slab = (OPSLAB *)CvSTART(cv);
520 #ifdef DEBUGGING
521     else if (slabbed)     Perl_warn(aTHX_ "Slab leaked from cv %p", cv);
522 #endif
523
524     if (slab) {
525 #ifdef PERL_DEBUG_READONLY_OPS
526         const size_t refcnt = slab->opslab_refcnt;
527 #endif
528         OpslabREFCNT_dec(slab);
529 #ifdef PERL_DEBUG_READONLY_OPS
530         if (refcnt > 1) Slab_to_ro(slab);
531 #endif
532     }
533 }
534
535 /*
536 =for apidoc m|PADOFFSET|pad_alloc_name|SV *namesv|U32 flags|HV *typestash|HV *ourstash
537
538 Allocates a place in the currently-compiling
539 pad (via L<perlapi/pad_alloc>) and
540 then stores a name for that entry.  I<namesv> is adopted and becomes the
541 name entry; it must already contain the name string and be sufficiently
542 upgraded.  I<typestash> and I<ourstash> and the C<padadd_STATE> flag get
543 added to I<namesv>.  None of the other
544 processing of L<perlapi/pad_add_name_pvn>
545 is done.  Returns the offset of the allocated pad slot.
546
547 =cut
548 */
549
550 static PADOFFSET
551 S_pad_alloc_name(pTHX_ SV *namesv, U32 flags, HV *typestash, HV *ourstash)
552 {
553     dVAR;
554     const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
555
556     PERL_ARGS_ASSERT_PAD_ALLOC_NAME;
557
558     ASSERT_CURPAD_ACTIVE("pad_alloc_name");
559
560     if (typestash) {
561         assert(SvTYPE(namesv) == SVt_PVMG);
562         SvPAD_TYPED_on(namesv);
563         SvSTASH_set(namesv, MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash))));
564     }
565     if (ourstash) {
566         SvPAD_OUR_on(namesv);
567         SvOURSTASH_set(namesv, ourstash);
568         SvREFCNT_inc_simple_void_NN(ourstash);
569     }
570     else if (flags & padadd_STATE) {
571         SvPAD_STATE_on(namesv);
572     }
573
574     av_store(PL_comppad_name, offset, namesv);
575     return offset;
576 }
577
578 /*
579 =for apidoc Am|PADOFFSET|pad_add_name_pvn|const char *namepv|STRLEN namelen|U32 flags|HV *typestash|HV *ourstash
580
581 Allocates a place in the currently-compiling pad for a named lexical
582 variable.  Stores the name and other metadata in the name part of the
583 pad, and makes preparations to manage the variable's lexical scoping.
584 Returns the offset of the allocated pad slot.
585
586 I<namepv>/I<namelen> specify the variable's name, including leading sigil.
587 If I<typestash> is non-null, the name is for a typed lexical, and this
588 identifies the type.  If I<ourstash> is non-null, it's a lexical reference
589 to a package variable, and this identifies the package.  The following
590 flags can be OR'ed together:
591
592     padadd_OUR          redundantly specifies if it's a package var
593     padadd_STATE        variable will retain value persistently
594     padadd_NO_DUP_CHECK skip check for lexical shadowing
595
596 =cut
597 */
598
599 PADOFFSET
600 Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen,
601                 U32 flags, HV *typestash, HV *ourstash)
602 {
603     dVAR;
604     PADOFFSET offset;
605     SV *namesv;
606     bool is_utf8;
607
608     PERL_ARGS_ASSERT_PAD_ADD_NAME_PVN;
609
610     if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK|padadd_UTF8_NAME))
611         Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf,
612                    (UV)flags);
613
614     namesv = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV);
615     
616     if ((is_utf8 = ((flags & padadd_UTF8_NAME) != 0))) {
617         namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
618     }
619
620     sv_setpvn(namesv, namepv, namelen);
621
622     if (is_utf8) {
623         flags |= padadd_UTF8_NAME;
624         SvUTF8_on(namesv);
625     }
626     else
627         flags &= ~padadd_UTF8_NAME;
628
629     if ((flags & padadd_NO_DUP_CHECK) == 0) {
630         ENTER;
631         SAVEFREESV(namesv); /* in case of fatal warnings */
632         /* check for duplicate declaration */
633         pad_check_dup(namesv, flags & padadd_OUR, ourstash);
634         SvREFCNT_inc_simple_void_NN(namesv);
635         LEAVE;
636     }
637
638     offset = pad_alloc_name(namesv, flags & ~padadd_UTF8_NAME, typestash, ourstash);
639
640     /* not yet introduced */
641     COP_SEQ_RANGE_LOW_set(namesv, PERL_PADSEQ_INTRO);
642     COP_SEQ_RANGE_HIGH_set(namesv, 0);
643
644     if (!PL_min_intro_pending)
645         PL_min_intro_pending = offset;
646     PL_max_intro_pending = offset;
647     /* if it's not a simple scalar, replace with an AV or HV */
648     assert(SvTYPE(PL_curpad[offset]) == SVt_NULL);
649     assert(SvREFCNT(PL_curpad[offset]) == 1);
650     if (namelen != 0 && *namepv == '@')
651         sv_upgrade(PL_curpad[offset], SVt_PVAV);
652     else if (namelen != 0 && *namepv == '%')
653         sv_upgrade(PL_curpad[offset], SVt_PVHV);
654     else if (namelen != 0 && *namepv == '&')
655         sv_upgrade(PL_curpad[offset], SVt_PVCV);
656     assert(SvPADMY(PL_curpad[offset]));
657     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
658                            "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
659                            (long)offset, SvPVX(namesv),
660                            PTR2UV(PL_curpad[offset])));
661
662     return offset;
663 }
664
665 /*
666 =for apidoc Am|PADOFFSET|pad_add_name_pv|const char *name|U32 flags|HV *typestash|HV *ourstash
667
668 Exactly like L</pad_add_name_pvn>, but takes a nul-terminated string
669 instead of a string/length pair.
670
671 =cut
672 */
673
674 PADOFFSET
675 Perl_pad_add_name_pv(pTHX_ const char *name,
676                      const U32 flags, HV *typestash, HV *ourstash)
677 {
678     PERL_ARGS_ASSERT_PAD_ADD_NAME_PV;
679     return pad_add_name_pvn(name, strlen(name), flags, typestash, ourstash);
680 }
681
682 /*
683 =for apidoc Am|PADOFFSET|pad_add_name_sv|SV *name|U32 flags|HV *typestash|HV *ourstash
684
685 Exactly like L</pad_add_name_pvn>, but takes the name string in the form
686 of an SV instead of a string/length pair.
687
688 =cut
689 */
690
691 PADOFFSET
692 Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash)
693 {
694     char *namepv;
695     STRLEN namelen;
696     PERL_ARGS_ASSERT_PAD_ADD_NAME_SV;
697     namepv = SvPV(name, namelen);
698     if (SvUTF8(name))
699         flags |= padadd_UTF8_NAME;
700     return pad_add_name_pvn(namepv, namelen, flags, typestash, ourstash);
701 }
702
703 /*
704 =for apidoc Amx|PADOFFSET|pad_alloc|I32 optype|U32 tmptype
705
706 Allocates a place in the currently-compiling pad,
707 returning the offset of the allocated pad slot.
708 No name is initially attached to the pad slot.
709 I<tmptype> is a set of flags indicating the kind of pad entry required,
710 which will be set in the value SV for the allocated pad entry:
711
712     SVs_PADMY    named lexical variable ("my", "our", "state")
713     SVs_PADTMP   unnamed temporary store
714
715 I<optype> should be an opcode indicating the type of operation that the
716 pad entry is to support.  This doesn't affect operational semantics,
717 but is used for debugging.
718
719 =cut
720 */
721
722 /* XXX DAPM integrate alloc(), add_name() and add_anon(),
723  * or at least rationalise ??? */
724
725 PADOFFSET
726 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
727 {
728     dVAR;
729     SV *sv;
730     I32 retval;
731
732     PERL_UNUSED_ARG(optype);
733     ASSERT_CURPAD_ACTIVE("pad_alloc");
734
735     if (AvARRAY(PL_comppad) != PL_curpad)
736         Perl_croak(aTHX_ "panic: pad_alloc, %p!=%p",
737                    AvARRAY(PL_comppad), PL_curpad);
738     if (PL_pad_reset_pending)
739         pad_reset();
740     if (tmptype & SVs_PADMY) {
741         /* For a my, simply push a null SV onto the end of PL_comppad. */
742         sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
743         retval = AvFILLp(PL_comppad);
744     }
745     else {
746         /* For a tmp, scan the pad from PL_padix upwards
747          * for a slot which has no name and no active value.
748          */
749         SV * const * const names = AvARRAY(PL_comppad_name);
750         const SSize_t names_fill = AvFILLp(PL_comppad_name);
751         for (;;) {
752             /*
753              * "foreach" index vars temporarily become aliases to non-"my"
754              * values.  Thus we must skip, not just pad values that are
755              * marked as current pad values, but also those with names.
756              */
757             /* HVDS why copy to sv here? we don't seem to use it */
758             if (++PL_padix <= names_fill &&
759                    (sv = names[PL_padix]) && sv != &PL_sv_undef)
760                 continue;
761             sv = *av_fetch(PL_comppad, PL_padix, TRUE);
762             if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) &&
763                 !IS_PADGV(sv) && !IS_PADCONST(sv))
764                 break;
765         }
766         retval = PL_padix;
767     }
768     SvFLAGS(sv) |= tmptype;
769     PL_curpad = AvARRAY(PL_comppad);
770
771     DEBUG_X(PerlIO_printf(Perl_debug_log,
772           "Pad 0x%"UVxf"[0x%"UVxf"] alloc:   %ld for %s\n",
773           PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
774           PL_op_name[optype]));
775 #ifdef DEBUG_LEAKING_SCALARS
776     sv->sv_debug_optype = optype;
777     sv->sv_debug_inpad = 1;
778 #endif
779     return (PADOFFSET)retval;
780 }
781
782 /*
783 =for apidoc Am|PADOFFSET|pad_add_anon|CV *func|I32 optype
784
785 Allocates a place in the currently-compiling pad (via L</pad_alloc>)
786 for an anonymous function that is lexically scoped inside the
787 currently-compiling function.
788 The function I<func> is linked into the pad, and its C<CvOUTSIDE> link
789 to the outer scope is weakened to avoid a reference loop.
790
791 One reference count is stolen, so you may need to do C<SvREFCNT_inc(func)>.
792
793 I<optype> should be an opcode indicating the type of operation that the
794 pad entry is to support.  This doesn't affect operational semantics,
795 but is used for debugging.
796
797 =cut
798 */
799
800 PADOFFSET
801 Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
802 {
803     dVAR;
804     PADOFFSET ix;
805     SV* const name = newSV_type(SVt_PVNV);
806
807     PERL_ARGS_ASSERT_PAD_ADD_ANON;
808
809     pad_peg("add_anon");
810     sv_setpvs(name, "&");
811     /* These two aren't used; just make sure they're not equal to
812      * PERL_PADSEQ_INTRO */
813     COP_SEQ_RANGE_LOW_set(name, 0);
814     COP_SEQ_RANGE_HIGH_set(name, 0);
815     ix = pad_alloc(optype, SVs_PADMY);
816     av_store(PL_comppad_name, ix, name);
817     /* XXX DAPM use PL_curpad[] ? */
818     if (SvTYPE(func) == SVt_PVCV || !CvOUTSIDE(func))
819         av_store(PL_comppad, ix, (SV*)func);
820     else {
821         SV *rv = newRV_noinc((SV *)func);
822         sv_rvweaken(rv);
823         assert (SvTYPE(func) == SVt_PVFM);
824         av_store(PL_comppad, ix, rv);
825     }
826     SvPADMY_on((SV*)func);
827
828     /* to avoid ref loops, we never have parent + child referencing each
829      * other simultaneously */
830     if (CvOUTSIDE(func) && SvTYPE(func) == SVt_PVCV) {
831         assert(!CvWEAKOUTSIDE(func));
832         CvWEAKOUTSIDE_on(func);
833         SvREFCNT_dec_NN(CvOUTSIDE(func));
834     }
835     return ix;
836 }
837
838 /*
839 =for apidoc pad_check_dup
840
841 Check for duplicate declarations: report any of:
842
843      * a my in the current scope with the same name;
844      * an our (anywhere in the pad) with the same name and the
845        same stash as C<ourstash>
846
847 C<is_our> indicates that the name to check is an 'our' declaration.
848
849 =cut
850 */
851
852 STATIC void
853 S_pad_check_dup(pTHX_ SV *name, U32 flags, const HV *ourstash)
854 {
855     dVAR;
856     SV          **svp;
857     PADOFFSET   top, off;
858     const U32   is_our = flags & padadd_OUR;
859
860     PERL_ARGS_ASSERT_PAD_CHECK_DUP;
861
862     ASSERT_CURPAD_ACTIVE("pad_check_dup");
863
864     assert((flags & ~padadd_OUR) == 0);
865
866     if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC))
867         return; /* nothing to check */
868
869     svp = AvARRAY(PL_comppad_name);
870     top = AvFILLp(PL_comppad_name);
871     /* check the current scope */
872     /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
873      * type ? */
874     for (off = top; (I32)off > PL_comppad_name_floor; off--) {
875         SV * const sv = svp[off];
876         if (sv
877             && sv != &PL_sv_undef
878             && !SvFAKE(sv)
879             && (   COP_SEQ_RANGE_LOW(sv)  == PERL_PADSEQ_INTRO
880                 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
881             && sv_eq(name, sv))
882         {
883             if (is_our && (SvPAD_OUR(sv)))
884                 break; /* "our" masking "our" */
885             /* diag_listed_as: "%s" variable %s masks earlier declaration in same %s */
886             Perl_warner(aTHX_ packWARN(WARN_MISC),
887                 "\"%s\" %s %"SVf" masks earlier declaration in same %s",
888                 (is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"),
889                 *SvPVX(sv) == '&' ? "subroutine" : "variable",
890                 sv,
891                 (COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO
892                     ? "scope" : "statement"));
893             --off;
894             break;
895         }
896     }
897     /* check the rest of the pad */
898     if (is_our) {
899         while (off > 0) {
900             SV * const sv = svp[off];
901             if (sv
902                 && sv != &PL_sv_undef
903                 && !SvFAKE(sv)
904                 && (   COP_SEQ_RANGE_LOW(sv)  == PERL_PADSEQ_INTRO
905                     || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
906                 && SvOURSTASH(sv) == ourstash
907                 && sv_eq(name, sv))
908             {
909                 Perl_warner(aTHX_ packWARN(WARN_MISC),
910                     "\"our\" variable %"SVf" redeclared", sv);
911                 if ((I32)off <= PL_comppad_name_floor)
912                     Perl_warner(aTHX_ packWARN(WARN_MISC),
913                         "\t(Did you mean \"local\" instead of \"our\"?)\n");
914                 break;
915             }
916             --off;
917         }
918     }
919 }
920
921
922 /*
923 =for apidoc Am|PADOFFSET|pad_findmy_pvn|const char *namepv|STRLEN namelen|U32 flags
924
925 Given the name of a lexical variable, find its position in the
926 currently-compiling pad.
927 I<namepv>/I<namelen> specify the variable's name, including leading sigil.
928 I<flags> is reserved and must be zero.
929 If it is not in the current pad but appears in the pad of any lexically
930 enclosing scope, then a pseudo-entry for it is added in the current pad.
931 Returns the offset in the current pad,
932 or C<NOT_IN_PAD> if no such lexical is in scope.
933
934 =cut
935 */
936
937 PADOFFSET
938 Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags)
939 {
940     dVAR;
941     SV *out_sv;
942     int out_flags;
943     I32 offset;
944     const AV *nameav;
945     SV **name_svp;
946
947     PERL_ARGS_ASSERT_PAD_FINDMY_PVN;
948
949     pad_peg("pad_findmy_pvn");
950
951     if (flags & ~padadd_UTF8_NAME)
952         Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf,
953                    (UV)flags);
954
955     if (flags & padadd_UTF8_NAME) {
956         bool is_utf8 = TRUE;
957         namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
958
959         if (is_utf8)
960             flags |= padadd_UTF8_NAME;
961         else
962             flags &= ~padadd_UTF8_NAME;
963     }
964
965     offset = pad_findlex(namepv, namelen, flags,
966                 PL_compcv, PL_cop_seqmax, 1, NULL, &out_sv, &out_flags);
967     if ((PADOFFSET)offset != NOT_IN_PAD) 
968         return offset;
969
970     /* look for an our that's being introduced; this allows
971      *    our $foo = 0 unless defined $foo;
972      * to not give a warning. (Yes, this is a hack) */
973
974     nameav = PadlistARRAY(CvPADLIST(PL_compcv))[0];
975     name_svp = AvARRAY(nameav);
976     for (offset = AvFILLp(nameav); offset > 0; offset--) {
977         const SV * const namesv = name_svp[offset];
978         if (namesv && namesv != &PL_sv_undef
979             && !SvFAKE(namesv)
980             && (SvPAD_OUR(namesv))
981             && SvCUR(namesv) == namelen
982             && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
983                                 flags & padadd_UTF8_NAME ? SVf_UTF8 : 0 )
984             && COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO
985         )
986             return offset;
987     }
988     return NOT_IN_PAD;
989 }
990
991 /*
992 =for apidoc Am|PADOFFSET|pad_findmy_pv|const char *name|U32 flags
993
994 Exactly like L</pad_findmy_pvn>, but takes a nul-terminated string
995 instead of a string/length pair.
996
997 =cut
998 */
999
1000 PADOFFSET
1001 Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags)
1002 {
1003     PERL_ARGS_ASSERT_PAD_FINDMY_PV;
1004     return pad_findmy_pvn(name, strlen(name), flags);
1005 }
1006
1007 /*
1008 =for apidoc Am|PADOFFSET|pad_findmy_sv|SV *name|U32 flags
1009
1010 Exactly like L</pad_findmy_pvn>, but takes the name string in the form
1011 of an SV instead of a string/length pair.
1012
1013 =cut
1014 */
1015
1016 PADOFFSET
1017 Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags)
1018 {
1019     char *namepv;
1020     STRLEN namelen;
1021     PERL_ARGS_ASSERT_PAD_FINDMY_SV;
1022     namepv = SvPV(name, namelen);
1023     if (SvUTF8(name))
1024         flags |= padadd_UTF8_NAME;
1025     return pad_findmy_pvn(namepv, namelen, flags);
1026 }
1027
1028 /*
1029 =for apidoc Amp|PADOFFSET|find_rundefsvoffset
1030
1031 Find the position of the lexical C<$_> in the pad of the
1032 currently-executing function.  Returns the offset in the current pad,
1033 or C<NOT_IN_PAD> if there is no lexical C<$_> in scope (in which case
1034 the global one should be used instead).
1035 L</find_rundefsv> is likely to be more convenient.
1036
1037 =cut
1038 */
1039
1040 PADOFFSET
1041 Perl_find_rundefsvoffset(pTHX)
1042 {
1043     dVAR;
1044     SV *out_sv;
1045     int out_flags;
1046     return pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
1047             NULL, &out_sv, &out_flags);
1048 }
1049
1050 /*
1051 =for apidoc Am|SV *|find_rundefsv
1052
1053 Find and return the variable that is named C<$_> in the lexical scope
1054 of the currently-executing function.  This may be a lexical C<$_>,
1055 or will otherwise be the global one.
1056
1057 =cut
1058 */
1059
1060 SV *
1061 Perl_find_rundefsv(pTHX)
1062 {
1063     SV *namesv;
1064     int flags;
1065     PADOFFSET po;
1066
1067     po = pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
1068             NULL, &namesv, &flags);
1069
1070     if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
1071         return DEFSV;
1072
1073     return PAD_SVl(po);
1074 }
1075
1076 SV *
1077 Perl_find_rundefsv2(pTHX_ CV *cv, U32 seq)
1078 {
1079     SV *namesv;
1080     int flags;
1081     PADOFFSET po;
1082
1083     PERL_ARGS_ASSERT_FIND_RUNDEFSV2;
1084
1085     po = pad_findlex("$_", 2, 0, cv, seq, 1,
1086             NULL, &namesv, &flags);
1087
1088     if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
1089         return DEFSV;
1090
1091     return AvARRAY(PadlistARRAY(CvPADLIST(cv))[CvDEPTH(cv)])[po];
1092 }
1093
1094 /*
1095 =for apidoc m|PADOFFSET|pad_findlex|const char *namepv|STRLEN namelen|U32 flags|const CV* cv|U32 seq|int warn|SV** out_capture|SV** out_name_sv|int *out_flags
1096
1097 Find a named lexical anywhere in a chain of nested pads. Add fake entries
1098 in the inner pads if it's found in an outer one.
1099
1100 Returns the offset in the bottom pad of the lex or the fake lex.
1101 cv is the CV in which to start the search, and seq is the current cop_seq
1102 to match against. If warn is true, print appropriate warnings.  The out_*
1103 vars return values, and so are pointers to where the returned values
1104 should be stored. out_capture, if non-null, requests that the innermost
1105 instance of the lexical is captured; out_name_sv is set to the innermost
1106 matched namesv or fake namesv; out_flags returns the flags normally
1107 associated with the IVX field of a fake namesv.
1108
1109 Note that pad_findlex() is recursive; it recurses up the chain of CVs,
1110 then comes back down, adding fake entries as it goes. It has to be this way
1111 because fake namesvs in anon protoypes have to store in xlow the index into
1112 the parent pad.
1113
1114 =cut
1115 */
1116
1117 /* the CV has finished being compiled. This is not a sufficient test for
1118  * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
1119 #define CvCOMPILED(cv)  CvROOT(cv)
1120
1121 /* the CV does late binding of its lexicals */
1122 #define CvLATE(cv) (CvANON(cv) || CvCLONE(cv) || SvTYPE(cv) == SVt_PVFM)
1123
1124 static void
1125 S_unavailable(pTHX_ SV *namesv)
1126 {
1127     /* diag_listed_as: Variable "%s" is not available */
1128     Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1129                         "%se \"%"SVf"\" is not available",
1130                          *SvPVX_const(namesv) == '&'
1131                                          ? "Subroutin"
1132                                          : "Variabl",
1133                          namesv);
1134 }
1135
1136 STATIC PADOFFSET
1137 S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq,
1138         int warn, SV** out_capture, SV** out_name_sv, int *out_flags)
1139 {
1140     dVAR;
1141     I32 offset, new_offset;
1142     SV *new_capture;
1143     SV **new_capturep;
1144     const PADLIST * const padlist = CvPADLIST(cv);
1145     const bool staleok = !!(flags & padadd_STALEOK);
1146
1147     PERL_ARGS_ASSERT_PAD_FINDLEX;
1148
1149     if (flags & ~(padadd_UTF8_NAME|padadd_STALEOK))
1150         Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf,
1151                    (UV)flags);
1152     flags &= ~ padadd_STALEOK; /* one-shot flag */
1153
1154     *out_flags = 0;
1155
1156     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1157         "Pad findlex cv=0x%"UVxf" searching \"%.*s\" seq=%d%s\n",
1158                            PTR2UV(cv), (int)namelen, namepv, (int)seq,
1159         out_capture ? " capturing" : "" ));
1160
1161     /* first, search this pad */
1162
1163     if (padlist) { /* not an undef CV */
1164         I32 fake_offset = 0;
1165         const AV * const nameav = PadlistARRAY(padlist)[0];
1166         SV * const * const name_svp = AvARRAY(nameav);
1167
1168         for (offset = AvFILLp(nameav); offset > 0; offset--) {
1169             const SV * const namesv = name_svp[offset];
1170             if (namesv && namesv != &PL_sv_undef
1171                     && SvCUR(namesv) == namelen
1172                     && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
1173                                     flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))
1174             {
1175                 if (SvFAKE(namesv)) {
1176                     fake_offset = offset; /* in case we don't find a real one */
1177                     continue;
1178                 }
1179                 /* is seq within the range _LOW to _HIGH ?
1180                  * This is complicated by the fact that PL_cop_seqmax
1181                  * may have wrapped around at some point */
1182                 if (COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO)
1183                     continue; /* not yet introduced */
1184
1185                 if (COP_SEQ_RANGE_HIGH(namesv) == PERL_PADSEQ_INTRO) {
1186                     /* in compiling scope */
1187                     if (
1188                         (seq >  COP_SEQ_RANGE_LOW(namesv))
1189                         ? (seq - COP_SEQ_RANGE_LOW(namesv) < (U32_MAX >> 1))
1190                         : (COP_SEQ_RANGE_LOW(namesv) - seq > (U32_MAX >> 1))
1191                     )
1192                        break;
1193                 }
1194                 else if (
1195                     (COP_SEQ_RANGE_LOW(namesv) > COP_SEQ_RANGE_HIGH(namesv))
1196                     ?
1197                         (  seq >  COP_SEQ_RANGE_LOW(namesv)
1198                         || seq <= COP_SEQ_RANGE_HIGH(namesv))
1199
1200                     :    (  seq >  COP_SEQ_RANGE_LOW(namesv)
1201                          && seq <= COP_SEQ_RANGE_HIGH(namesv))
1202                 )
1203                 break;
1204             }
1205         }
1206
1207         if (offset > 0 || fake_offset > 0 ) { /* a match! */
1208             if (offset > 0) { /* not fake */
1209                 fake_offset = 0;
1210                 *out_name_sv = name_svp[offset]; /* return the namesv */
1211
1212                 /* set PAD_FAKELEX_MULTI if this lex can have multiple
1213                  * instances. For now, we just test !CvUNIQUE(cv), but
1214                  * ideally, we should detect my's declared within loops
1215                  * etc - this would allow a wider range of 'not stayed
1216                  * shared' warnings. We also treated already-compiled
1217                  * lexes as not multi as viewed from evals. */
1218
1219                 *out_flags = CvANON(cv) ?
1220                         PAD_FAKELEX_ANON :
1221                             (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
1222                                 ? PAD_FAKELEX_MULTI : 0;
1223
1224                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1225                     "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n",
1226                     PTR2UV(cv), (long)offset,
1227                     (unsigned long)COP_SEQ_RANGE_LOW(*out_name_sv),
1228                     (unsigned long)COP_SEQ_RANGE_HIGH(*out_name_sv)));
1229             }
1230             else { /* fake match */
1231                 offset = fake_offset;
1232                 *out_name_sv = name_svp[offset]; /* return the namesv */
1233                 *out_flags = PARENT_FAKELEX_FLAGS(*out_name_sv);
1234                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1235                     "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
1236                     PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
1237                     (unsigned long) PARENT_PAD_INDEX(*out_name_sv) 
1238                 ));
1239             }
1240
1241             /* return the lex? */
1242
1243             if (out_capture) {
1244
1245                 /* our ? */
1246                 if (SvPAD_OUR(*out_name_sv)) {
1247                     *out_capture = NULL;
1248                     return offset;
1249                 }
1250
1251                 /* trying to capture from an anon prototype? */
1252                 if (CvCOMPILED(cv)
1253                         ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
1254                         : *out_flags & PAD_FAKELEX_ANON)
1255                 {
1256                     if (warn)
1257                         S_unavailable(aTHX_
1258                                        newSVpvn_flags(namepv, namelen,
1259                                            SVs_TEMP |
1260                                            (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1261
1262                     *out_capture = NULL;
1263                 }
1264
1265                 /* real value */
1266                 else {
1267                     int newwarn = warn;
1268                     if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
1269                          && !SvPAD_STATE(name_svp[offset])
1270                          && warn && ckWARN(WARN_CLOSURE)) {
1271                         newwarn = 0;
1272                         Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
1273                             "Variable \"%"SVf"\" will not stay shared",
1274                             newSVpvn_flags(namepv, namelen,
1275                                 SVs_TEMP |
1276                                 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1277                     }
1278
1279                     if (fake_offset && CvANON(cv)
1280                             && CvCLONE(cv) &&!CvCLONED(cv))
1281                     {
1282                         SV *n;
1283                         /* not yet caught - look further up */
1284                         DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1285                             "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
1286                             PTR2UV(cv)));
1287                         n = *out_name_sv;
1288                         (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv),
1289                             CvOUTSIDE_SEQ(cv),
1290                             newwarn, out_capture, out_name_sv, out_flags);
1291                         *out_name_sv = n;
1292                         return offset;
1293                     }
1294
1295                     *out_capture = AvARRAY(PadlistARRAY(padlist)[
1296                                     CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset];
1297                     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1298                         "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
1299                         PTR2UV(cv), PTR2UV(*out_capture)));
1300
1301                     if (SvPADSTALE(*out_capture)
1302                         && (!CvDEPTH(cv) || !staleok)
1303                         && !SvPAD_STATE(name_svp[offset]))
1304                     {
1305                         S_unavailable(aTHX_
1306                                        newSVpvn_flags(namepv, namelen,
1307                                            SVs_TEMP |
1308                                            (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1309                         *out_capture = NULL;
1310                     }
1311                 }
1312                 if (!*out_capture) {
1313                     if (namelen != 0 && *namepv == '@')
1314                         *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
1315                     else if (namelen != 0 && *namepv == '%')
1316                         *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
1317                     else if (namelen != 0 && *namepv == '&')
1318                         *out_capture = sv_2mortal(newSV_type(SVt_PVCV));
1319                     else
1320                         *out_capture = sv_newmortal();
1321                 }
1322             }
1323
1324             return offset;
1325         }
1326     }
1327
1328     /* it's not in this pad - try above */
1329
1330     if (!CvOUTSIDE(cv))
1331         return NOT_IN_PAD;
1332
1333     /* out_capture non-null means caller wants us to capture lex; in
1334      * addition we capture ourselves unless it's an ANON/format */
1335     new_capturep = out_capture ? out_capture :
1336                 CvLATE(cv) ? NULL : &new_capture;
1337
1338     offset = pad_findlex(namepv, namelen,
1339                 flags | padadd_STALEOK*(new_capturep == &new_capture),
1340                 CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
1341                 new_capturep, out_name_sv, out_flags);
1342     if ((PADOFFSET)offset == NOT_IN_PAD)
1343         return NOT_IN_PAD;
1344
1345     /* found in an outer CV. Add appropriate fake entry to this pad */
1346
1347     /* don't add new fake entries (via eval) to CVs that we have already
1348      * finished compiling, or to undef CVs */
1349     if (CvCOMPILED(cv) || !padlist)
1350         return 0; /* this dummy (and invalid) value isnt used by the caller */
1351
1352     {
1353         /* This relies on sv_setsv_flags() upgrading the destination to the same
1354            type as the source, independent of the flags set, and on it being
1355            "good" and only copying flag bits and pointers that it understands.
1356         */
1357         SV *new_namesv = newSVsv(*out_name_sv);
1358         AV *  const ocomppad_name = PL_comppad_name;
1359         PAD * const ocomppad = PL_comppad;
1360         PL_comppad_name = PadlistARRAY(padlist)[0];
1361         PL_comppad = PadlistARRAY(padlist)[1];
1362         PL_curpad = AvARRAY(PL_comppad);
1363
1364         new_offset
1365             = pad_alloc_name(new_namesv,
1366                               (SvPAD_STATE(*out_name_sv) ? padadd_STATE : 0),
1367                               SvPAD_TYPED(*out_name_sv)
1368                               ? SvSTASH(*out_name_sv) : NULL,
1369                               SvOURSTASH(*out_name_sv)
1370                               );
1371
1372         SvFAKE_on(new_namesv);
1373         DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1374                                "Pad addname: %ld \"%.*s\" FAKE\n",
1375                                (long)new_offset,
1376                                (int) SvCUR(new_namesv), SvPVX(new_namesv)));
1377         PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags);
1378
1379         PARENT_PAD_INDEX_set(new_namesv, 0);
1380         if (SvPAD_OUR(new_namesv)) {
1381             NOOP;   /* do nothing */
1382         }
1383         else if (CvLATE(cv)) {
1384             /* delayed creation - just note the offset within parent pad */
1385             PARENT_PAD_INDEX_set(new_namesv, offset);
1386             CvCLONE_on(cv);
1387         }
1388         else {
1389             /* immediate creation - capture outer value right now */
1390             av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
1391             /* But also note the offset, as newMYSUB needs it */
1392             PARENT_PAD_INDEX_set(new_namesv, offset);
1393             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1394                 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
1395                 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
1396         }
1397         *out_name_sv = new_namesv;
1398         *out_flags = PARENT_FAKELEX_FLAGS(new_namesv);
1399
1400         PL_comppad_name = ocomppad_name;
1401         PL_comppad = ocomppad;
1402         PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
1403     }
1404     return new_offset;
1405 }
1406
1407 #ifdef DEBUGGING
1408
1409 /*
1410 =for apidoc Am|SV *|pad_sv|PADOFFSET po
1411
1412 Get the value at offset I<po> in the current (compiling or executing) pad.
1413 Use macro PAD_SV instead of calling this function directly.
1414
1415 =cut
1416 */
1417
1418 SV *
1419 Perl_pad_sv(pTHX_ PADOFFSET po)
1420 {
1421     dVAR;
1422     ASSERT_CURPAD_ACTIVE("pad_sv");
1423
1424     if (!po)
1425         Perl_croak(aTHX_ "panic: pad_sv po");
1426     DEBUG_X(PerlIO_printf(Perl_debug_log,
1427         "Pad 0x%"UVxf"[0x%"UVxf"] sv:      %ld sv=0x%"UVxf"\n",
1428         PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
1429     );
1430     return PL_curpad[po];
1431 }
1432
1433 /*
1434 =for apidoc Am|void|pad_setsv|PADOFFSET po|SV *sv
1435
1436 Set the value at offset I<po> in the current (compiling or executing) pad.
1437 Use the macro PAD_SETSV() rather than calling this function directly.
1438
1439 =cut
1440 */
1441
1442 void
1443 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
1444 {
1445     dVAR;
1446
1447     PERL_ARGS_ASSERT_PAD_SETSV;
1448
1449     ASSERT_CURPAD_ACTIVE("pad_setsv");
1450
1451     DEBUG_X(PerlIO_printf(Perl_debug_log,
1452         "Pad 0x%"UVxf"[0x%"UVxf"] setsv:   %ld sv=0x%"UVxf"\n",
1453         PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
1454     );
1455     PL_curpad[po] = sv;
1456 }
1457
1458 #endif /* DEBUGGING */
1459
1460 /*
1461 =for apidoc m|void|pad_block_start|int full
1462
1463 Update the pad compilation state variables on entry to a new block.
1464
1465 =cut
1466 */
1467
1468 /* XXX DAPM perhaps:
1469  *      - integrate this in general state-saving routine ???
1470  *      - combine with the state-saving going on in pad_new ???
1471  *      - introduce a new SAVE type that does all this in one go ?
1472  */
1473
1474 void
1475 Perl_pad_block_start(pTHX_ int full)
1476 {
1477     dVAR;
1478     ASSERT_CURPAD_ACTIVE("pad_block_start");
1479     SAVEI32(PL_comppad_name_floor);
1480     PL_comppad_name_floor = AvFILLp(PL_comppad_name);
1481     if (full)
1482         PL_comppad_name_fill = PL_comppad_name_floor;
1483     if (PL_comppad_name_floor < 0)
1484         PL_comppad_name_floor = 0;
1485     SAVEI32(PL_min_intro_pending);
1486     SAVEI32(PL_max_intro_pending);
1487     PL_min_intro_pending = 0;
1488     SAVEI32(PL_comppad_name_fill);
1489     SAVEI32(PL_padix_floor);
1490     PL_padix_floor = PL_padix;
1491     PL_pad_reset_pending = FALSE;
1492 }
1493
1494 /*
1495 =for apidoc m|U32|intro_my
1496
1497 "Introduce" my variables to visible status.  This is called during parsing
1498 at the end of each statement to make lexical variables visible to
1499 subsequent statements.
1500
1501 =cut
1502 */
1503
1504 U32
1505 Perl_intro_my(pTHX)
1506 {
1507     dVAR;
1508     SV **svp;
1509     I32 i;
1510     U32 seq;
1511
1512     ASSERT_CURPAD_ACTIVE("intro_my");
1513     if (! PL_min_intro_pending)
1514         return PL_cop_seqmax;
1515
1516     svp = AvARRAY(PL_comppad_name);
1517     for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1518         SV * const sv = svp[i];
1519
1520         if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
1521             && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
1522         {
1523             COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
1524             COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
1525             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1526                 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1527                 (long)i, SvPVX_const(sv),
1528                 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1529                 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1530             );
1531         }
1532     }
1533     seq = PL_cop_seqmax;
1534     PL_cop_seqmax++;
1535     if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1536         PL_cop_seqmax++;
1537     PL_min_intro_pending = 0;
1538     PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1539     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1540                 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));
1541
1542     return seq;
1543 }
1544
1545 /*
1546 =for apidoc m|void|pad_leavemy
1547
1548 Cleanup at end of scope during compilation: set the max seq number for
1549 lexicals in this scope and warn of any lexicals that never got introduced.
1550
1551 =cut
1552 */
1553
1554 OP *
1555 Perl_pad_leavemy(pTHX)
1556 {
1557     dVAR;
1558     I32 off;
1559     OP *o = NULL;
1560     SV * const * const svp = AvARRAY(PL_comppad_name);
1561
1562     PL_pad_reset_pending = FALSE;
1563
1564     ASSERT_CURPAD_ACTIVE("pad_leavemy");
1565     if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1566         for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1567             const SV * const sv = svp[off];
1568             if (sv && sv != &PL_sv_undef && !SvFAKE(sv))
1569                 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1570                                  "%"SVf" never introduced",
1571                                  SVfARG(sv));
1572         }
1573     }
1574     /* "Deintroduce" my variables that are leaving with this scope. */
1575     for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
1576         SV * const sv = svp[off];
1577         if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
1578             && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
1579         {
1580             COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
1581             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1582                 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1583                 (long)off, SvPVX_const(sv),
1584                 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1585                 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1586             );
1587             if (!PadnameIsSTATE(sv) && !PadnameIsOUR(sv)
1588              && *PadnamePV(sv) == '&' && PadnameLEN(sv) > 1) {
1589                 OP *kid = newOP(OP_INTROCV, 0);
1590                 kid->op_targ = off;
1591                 o = op_prepend_elem(OP_LINESEQ, kid, o);
1592             }
1593         }
1594     }
1595     PL_cop_seqmax++;
1596     if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1597         PL_cop_seqmax++;
1598     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1599             "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1600     return o;
1601 }
1602
1603 /*
1604 =for apidoc m|void|pad_swipe|PADOFFSET po|bool refadjust
1605
1606 Abandon the tmp in the current pad at offset po and replace with a
1607 new one.
1608
1609 =cut
1610 */
1611
1612 void
1613 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1614 {
1615     dVAR;
1616     ASSERT_CURPAD_LEGAL("pad_swipe");
1617     if (!PL_curpad)
1618         return;
1619     if (AvARRAY(PL_comppad) != PL_curpad)
1620         Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
1621                    AvARRAY(PL_comppad), PL_curpad);
1622     if (!po || ((SSize_t)po) > AvFILLp(PL_comppad))
1623         Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld",
1624                    (long)po, (long)AvFILLp(PL_comppad));
1625
1626     DEBUG_X(PerlIO_printf(Perl_debug_log,
1627                 "Pad 0x%"UVxf"[0x%"UVxf"] swipe:   %ld\n",
1628                 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1629
1630     if (PL_curpad[po])
1631         SvPADTMP_off(PL_curpad[po]);
1632     if (refadjust)
1633         SvREFCNT_dec(PL_curpad[po]);
1634
1635
1636     /* if pad tmps aren't shared between ops, then there's no need to
1637      * create a new tmp when an existing op is freed */
1638 #ifdef USE_BROKEN_PAD_RESET
1639     PL_curpad[po] = newSV(0);
1640     SvPADTMP_on(PL_curpad[po]);
1641 #else
1642     PL_curpad[po] = &PL_sv_undef;
1643 #endif
1644     if ((I32)po < PL_padix)
1645         PL_padix = po - 1;
1646 }
1647
1648 /*
1649 =for apidoc m|void|pad_reset
1650
1651 Mark all the current temporaries for reuse
1652
1653 =cut
1654 */
1655
1656 /* XXX pad_reset() is currently disabled because it results in serious bugs.
1657  * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
1658  * on the stack by OPs that use them, there are several ways to get an alias
1659  * to  a shared TARG.  Such an alias will change randomly and unpredictably.
1660  * We avoid doing this until we can think of a Better Way.
1661  * GSAR 97-10-29 */
1662 static void
1663 S_pad_reset(pTHX)
1664 {
1665     dVAR;
1666 #ifdef USE_BROKEN_PAD_RESET
1667     if (AvARRAY(PL_comppad) != PL_curpad)
1668         Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
1669                    AvARRAY(PL_comppad), PL_curpad);
1670
1671     DEBUG_X(PerlIO_printf(Perl_debug_log,
1672             "Pad 0x%"UVxf"[0x%"UVxf"] reset:     padix %ld -> %ld",
1673             PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1674                 (long)PL_padix, (long)PL_padix_floor
1675             )
1676     );
1677
1678     if (!TAINTING_get) {        /* Can't mix tainted and non-tainted temporaries. */
1679         I32 po;
1680         for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
1681             if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
1682                 SvPADTMP_off(PL_curpad[po]);
1683         }
1684         PL_padix = PL_padix_floor;
1685     }
1686 #endif
1687     PL_pad_reset_pending = FALSE;
1688 }
1689
1690 /*
1691 =for apidoc Amx|void|pad_tidy|padtidy_type type
1692
1693 Tidy up a pad at the end of compilation of the code to which it belongs.
1694 Jobs performed here are: remove most stuff from the pads of anonsub
1695 prototypes; give it a @_; mark temporaries as such.  I<type> indicates
1696 the kind of subroutine:
1697
1698     padtidy_SUB        ordinary subroutine
1699     padtidy_SUBCLONE   prototype for lexical closure
1700     padtidy_FORMAT     format
1701
1702 =cut
1703 */
1704
1705 /* XXX DAPM surely most of this stuff should be done properly
1706  * at the right time beforehand, rather than going around afterwards
1707  * cleaning up our mistakes ???
1708  */
1709
1710 void
1711 Perl_pad_tidy(pTHX_ padtidy_type type)
1712 {
1713     dVAR;
1714
1715     ASSERT_CURPAD_ACTIVE("pad_tidy");
1716
1717     /* If this CV has had any 'eval-capable' ops planted in it:
1718      * i.e. it contains any of:
1719      *
1720      *     * eval '...',
1721      *     * //ee,
1722      *     * use re 'eval'; /$var/
1723      *     * /(?{..})/),
1724      *
1725      * Then any anon prototypes in the chain of CVs should be marked as
1726      * cloneable, so that for example the eval's CV in
1727      *
1728      *    sub { eval '$x' }
1729      *
1730      * gets the right CvOUTSIDE.  If running with -d, *any* sub may
1731      * potentially have an eval executed within it.
1732      */
1733
1734     if (PL_cv_has_eval || PL_perldb) {
1735         const CV *cv;
1736         for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1737             if (cv != PL_compcv && CvCOMPILED(cv))
1738                 break; /* no need to mark already-compiled code */
1739             if (CvANON(cv)) {
1740                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1741                     "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1742                 CvCLONE_on(cv);
1743             }
1744             CvHASEVAL_on(cv);
1745         }
1746     }
1747
1748     /* extend curpad to match namepad */
1749     if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1750         av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1751
1752     if (type == padtidy_SUBCLONE) {
1753         SV * const * const namep = AvARRAY(PL_comppad_name);
1754         PADOFFSET ix;
1755
1756         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1757             SV *namesv;
1758
1759             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1760                 continue;
1761             /*
1762              * The only things that a clonable function needs in its
1763              * pad are anonymous subs.
1764              * The rest are created anew during cloning.
1765              */
1766             if (!((namesv = namep[ix]) != NULL &&
1767                   namesv != &PL_sv_undef &&
1768                    *SvPVX_const(namesv) == '&'))
1769             {
1770                 SvREFCNT_dec(PL_curpad[ix]);
1771                 PL_curpad[ix] = NULL;
1772             }
1773         }
1774     }
1775     else if (type == padtidy_SUB) {
1776         /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1777         AV * const av = newAV();                        /* Will be @_ */
1778         av_store(PL_comppad, 0, MUTABLE_SV(av));
1779         AvREIFY_only(av);
1780     }
1781
1782     if (type == padtidy_SUB || type == padtidy_FORMAT) {
1783         SV * const * const namep = AvARRAY(PL_comppad_name);
1784         PADOFFSET ix;
1785         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1786             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1787                 continue;
1788             if (!SvPADMY(PL_curpad[ix])) {
1789                 SvPADTMP_on(PL_curpad[ix]);
1790             } else if (!SvFAKE(namep[ix])) {
1791                 /* This is a work around for how the current implementation of
1792                    ?{ } blocks in regexps interacts with lexicals.
1793
1794                    One of our lexicals.
1795                    Can't do this on all lexicals, otherwise sub baz() won't
1796                    compile in
1797
1798                    my $foo;
1799
1800                    sub bar { ++$foo; }
1801
1802                    sub baz { ++$foo; }
1803
1804                    because completion of compiling &bar calling pad_tidy()
1805                    would cause (top level) $foo to be marked as stale, and
1806                    "no longer available".  */
1807                 SvPADSTALE_on(PL_curpad[ix]);
1808             }
1809         }
1810     }
1811     PL_curpad = AvARRAY(PL_comppad);
1812 }
1813
1814 /*
1815 =for apidoc m|void|pad_free|PADOFFSET po
1816
1817 Free the SV at offset po in the current pad.
1818
1819 =cut
1820 */
1821
1822 /* XXX DAPM integrate with pad_swipe ???? */
1823 void
1824 Perl_pad_free(pTHX_ PADOFFSET po)
1825 {
1826     dVAR;
1827     SV *sv;
1828     ASSERT_CURPAD_LEGAL("pad_free");
1829     if (!PL_curpad)
1830         return;
1831     if (AvARRAY(PL_comppad) != PL_curpad)
1832         Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
1833                    AvARRAY(PL_comppad), PL_curpad);
1834     if (!po)
1835         Perl_croak(aTHX_ "panic: pad_free po");
1836
1837     DEBUG_X(PerlIO_printf(Perl_debug_log,
1838             "Pad 0x%"UVxf"[0x%"UVxf"] free:    %ld\n",
1839             PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1840     );
1841
1842
1843     sv = PL_curpad[po];
1844     if (sv && sv != &PL_sv_undef && !SvPADMY(sv))
1845         SvFLAGS(sv) &= ~SVs_PADTMP;
1846
1847     if ((I32)po < PL_padix)
1848         PL_padix = po - 1;
1849 }
1850
1851 /*
1852 =for apidoc m|void|do_dump_pad|I32 level|PerlIO *file|PADLIST *padlist|int full
1853
1854 Dump the contents of a padlist
1855
1856 =cut
1857 */
1858
1859 void
1860 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1861 {
1862     dVAR;
1863     const AV *pad_name;
1864     const AV *pad;
1865     SV **pname;
1866     SV **ppad;
1867     I32 ix;
1868
1869     PERL_ARGS_ASSERT_DO_DUMP_PAD;
1870
1871     if (!padlist) {
1872         return;
1873     }
1874     pad_name = *PadlistARRAY(padlist);
1875     pad = PadlistARRAY(padlist)[1];
1876     pname = AvARRAY(pad_name);
1877     ppad = AvARRAY(pad);
1878     Perl_dump_indent(aTHX_ level, file,
1879             "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1880             PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1881     );
1882
1883     for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1884         const SV *namesv = pname[ix];
1885         if (namesv && namesv == &PL_sv_undef) {
1886             namesv = NULL;
1887         }
1888         if (namesv) {
1889             if (SvFAKE(namesv))
1890                 Perl_dump_indent(aTHX_ level+1, file,
1891                     "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1892                     (int) ix,
1893                     PTR2UV(ppad[ix]),
1894                     (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1895                     SvPVX_const(namesv),
1896                     (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1897                     (unsigned long)PARENT_PAD_INDEX(namesv)
1898
1899                 );
1900             else
1901                 Perl_dump_indent(aTHX_ level+1, file,
1902                     "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
1903                     (int) ix,
1904                     PTR2UV(ppad[ix]),
1905                     (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1906                     (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1907                     (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1908                     SvPVX_const(namesv)
1909                 );
1910         }
1911         else if (full) {
1912             Perl_dump_indent(aTHX_ level+1, file,
1913                 "%2d. 0x%"UVxf"<%lu>\n",
1914                 (int) ix,
1915                 PTR2UV(ppad[ix]),
1916                 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1917             );
1918         }
1919     }
1920 }
1921
1922 #ifdef DEBUGGING
1923
1924 /*
1925 =for apidoc m|void|cv_dump|CV *cv|const char *title
1926
1927 dump the contents of a CV
1928
1929 =cut
1930 */
1931
1932 STATIC void
1933 S_cv_dump(pTHX_ const CV *cv, const char *title)
1934 {
1935     dVAR;
1936     const CV * const outside = CvOUTSIDE(cv);
1937     PADLIST* const padlist = CvPADLIST(cv);
1938
1939     PERL_ARGS_ASSERT_CV_DUMP;
1940
1941     PerlIO_printf(Perl_debug_log,
1942                   "  %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1943                   title,
1944                   PTR2UV(cv),
1945                   (CvANON(cv) ? "ANON"
1946                    : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1947                    : (cv == PL_main_cv) ? "MAIN"
1948                    : CvUNIQUE(cv) ? "UNIQUE"
1949                    : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1950                   PTR2UV(outside),
1951                   (!outside ? "null"
1952                    : CvANON(outside) ? "ANON"
1953                    : (outside == PL_main_cv) ? "MAIN"
1954                    : CvUNIQUE(outside) ? "UNIQUE"
1955                    : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1956
1957     PerlIO_printf(Perl_debug_log,
1958                     "    PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1959     do_dump_pad(1, Perl_debug_log, padlist, 1);
1960 }
1961
1962 #endif /* DEBUGGING */
1963
1964 /*
1965 =for apidoc Am|CV *|cv_clone|CV *proto
1966
1967 Clone a CV, making a lexical closure.  I<proto> supplies the prototype
1968 of the function: its code, pad structure, and other attributes.
1969 The prototype is combined with a capture of outer lexicals to which the
1970 code refers, which are taken from the currently-executing instance of
1971 the immediately surrounding code.
1972
1973 =cut
1974 */
1975
1976 static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside);
1977
1978 static void
1979 S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv)
1980 {
1981     dVAR;
1982     I32 ix;
1983     PADLIST* const protopadlist = CvPADLIST(proto);
1984     PAD *const protopad_name = *PadlistARRAY(protopadlist);
1985     const PAD *const protopad = PadlistARRAY(protopadlist)[1];
1986     SV** const pname = AvARRAY(protopad_name);
1987     SV** const ppad = AvARRAY(protopad);
1988     const I32 fname = AvFILLp(protopad_name);
1989     const I32 fpad = AvFILLp(protopad);
1990     SV** outpad;
1991     long depth;
1992     bool subclones = FALSE;
1993
1994     assert(!CvUNIQUE(proto));
1995
1996     /* Anonymous subs have a weak CvOUTSIDE pointer, so its value is not
1997      * reliable.  The currently-running sub is always the one we need to
1998      * close over.
1999      * For my subs, the currently-running sub may not be the one we want.
2000      * We have to check whether it is a clone of CvOUTSIDE.
2001      * Note that in general for formats, CvOUTSIDE != find_runcv.
2002      * Since formats may be nested inside closures, CvOUTSIDE may point
2003      * to a prototype; we instead want the cloned parent who called us.
2004      */
2005
2006     if (!outside) {
2007       if (CvWEAKOUTSIDE(proto))
2008         outside = find_runcv(NULL);
2009       else {
2010         outside = CvOUTSIDE(proto);
2011         if ((CvCLONE(outside) && ! CvCLONED(outside))
2012             || !CvPADLIST(outside)
2013             || PadlistNAMES(CvPADLIST(outside))
2014                  != protopadlist->xpadl_outid) {
2015             outside = find_runcv_where(
2016                 FIND_RUNCV_padid_eq, PTR2IV(protopadlist->xpadl_outid), NULL
2017             );
2018             /* outside could be null */
2019         }
2020       }
2021     }
2022     depth = outside ? CvDEPTH(outside) : 0;
2023     if (!depth)
2024         depth = 1;
2025
2026     ENTER;
2027     SAVESPTR(PL_compcv);
2028     PL_compcv = cv;
2029     if (newcv) SAVEFREESV(cv); /* in case of fatal warnings */
2030
2031     if (CvHASEVAL(cv))
2032         CvOUTSIDE(cv)   = MUTABLE_CV(SvREFCNT_inc_simple(outside));
2033
2034     SAVESPTR(PL_comppad_name);
2035     PL_comppad_name = protopad_name;
2036     CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
2037
2038     av_fill(PL_comppad, fpad);
2039
2040     PL_curpad = AvARRAY(PL_comppad);
2041
2042     outpad = outside && CvPADLIST(outside)
2043         ? AvARRAY(PadlistARRAY(CvPADLIST(outside))[depth])
2044         : NULL;
2045     if (outpad)
2046         CvPADLIST(cv)->xpadl_outid = PadlistNAMES(CvPADLIST(outside));
2047
2048     for (ix = fpad; ix > 0; ix--) {
2049         SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
2050         SV *sv = NULL;
2051         if (namesv && namesv != &PL_sv_undef) { /* lexical */
2052             if (SvFAKE(namesv)) {   /* lexical from outside? */
2053                 /* formats may have an inactive, or even undefined, parent;
2054                    but state vars are always available. */
2055                 if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
2056                  || (  SvPADSTALE(sv) && !SvPAD_STATE(namesv)
2057                     && (!outside || !CvDEPTH(outside)))  ) {
2058                     S_unavailable(aTHX_ namesv);
2059                     sv = NULL;
2060                 }
2061                 else 
2062                     SvREFCNT_inc_simple_void_NN(sv);
2063             }
2064             if (!sv) {
2065                 const char sigil = SvPVX_const(namesv)[0];
2066                 if (sigil == '&')
2067                     /* If there are state subs, we need to clone them, too.
2068                        But they may need to close over variables we have
2069                        not cloned yet.  So we will have to do a second
2070                        pass.  Furthermore, there may be state subs clos-
2071                        ing over other state subs’ entries, so we have
2072                        to put a stub here and then clone into it on the
2073                        second pass. */
2074                     if (SvPAD_STATE(namesv) && !CvCLONED(ppad[ix])) {
2075                         assert(SvTYPE(ppad[ix]) == SVt_PVCV);
2076                         subclones = 1;
2077                         sv = newSV_type(SVt_PVCV);
2078                     }
2079                     else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv))
2080                     {
2081                         /* my sub */
2082                         /* Just provide a stub, but name it.  It will be
2083                            upgrade to the real thing on scope entry. */
2084                         sv = newSV_type(SVt_PVCV);
2085                         CvNAME_HEK_set(
2086                             sv,
2087                             share_hek(SvPVX_const(namesv)+1,
2088                                       SvCUR(namesv) - 1
2089                                          * (SvUTF8(namesv) ? -1 : 1),
2090                                       0)
2091                         );
2092                     }
2093                     else sv = SvREFCNT_inc(ppad[ix]);
2094                 else if (sigil == '@')
2095                     sv = MUTABLE_SV(newAV());
2096                 else if (sigil == '%')
2097                     sv = MUTABLE_SV(newHV());
2098                 else
2099                     sv = newSV(0);
2100                 SvPADMY_on(sv);
2101                 /* reset the 'assign only once' flag on each state var */
2102                 if (sigil != '&' && SvPAD_STATE(namesv))
2103                     SvPADSTALE_on(sv);
2104             }
2105         }
2106         else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
2107             sv = SvREFCNT_inc_NN(ppad[ix]);
2108         }
2109         else {
2110             sv = newSV(0);
2111             SvPADTMP_on(sv);
2112         }
2113         PL_curpad[ix] = sv;
2114     }
2115
2116     if (subclones)
2117         for (ix = fpad; ix > 0; ix--) {
2118             SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
2119             if (namesv && namesv != &PL_sv_undef && !SvFAKE(namesv)
2120              && SvPVX_const(namesv)[0] == '&' && SvPAD_STATE(namesv))
2121                 S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv);
2122         }
2123
2124     if (newcv) SvREFCNT_inc_simple_void_NN(cv);
2125     LEAVE;
2126 }
2127
2128 static CV *
2129 S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside)
2130 {
2131     dVAR;
2132     const bool newcv = !cv;
2133
2134     assert(!CvUNIQUE(proto));
2135
2136     if (!cv) cv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
2137     CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
2138                                     |CVf_SLABBED);
2139     CvCLONED_on(cv);
2140
2141     CvFILE(cv)          = CvDYNFILE(proto) ? savepv(CvFILE(proto))
2142                                            : CvFILE(proto);
2143     if (CvNAMED(proto))
2144          CvNAME_HEK_set(cv, share_hek_hek(CvNAME_HEK(proto)));
2145     else CvGV_set(cv,CvGV(proto));
2146     CvSTASH_set(cv, CvSTASH(proto));
2147     OP_REFCNT_LOCK;
2148     CvROOT(cv)          = OpREFCNT_inc(CvROOT(proto));
2149     OP_REFCNT_UNLOCK;
2150     CvSTART(cv)         = CvSTART(proto);
2151     CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
2152
2153     if (SvPOK(proto))
2154         sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
2155     if (SvMAGIC(proto))
2156         mg_copy((SV *)proto, (SV *)cv, 0, 0);
2157
2158     if (CvPADLIST(proto)) S_cv_clone_pad(aTHX_ proto, cv, outside, newcv);
2159
2160     DEBUG_Xv(
2161         PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
2162         if (CvOUTSIDE(cv)) cv_dump(CvOUTSIDE(cv), "Outside");
2163         cv_dump(proto,   "Proto");
2164         cv_dump(cv,      "To");
2165     );
2166
2167     if (CvCONST(cv)) {
2168         /* Constant sub () { $x } closing over $x - see lib/constant.pm:
2169          * The prototype was marked as a candiate for const-ization,
2170          * so try to grab the current const value, and if successful,
2171          * turn into a const sub:
2172          */
2173         SV* const const_sv = op_const_sv(CvSTART(cv), cv);
2174         if (const_sv) {
2175             SvREFCNT_dec_NN(cv);
2176             /* For this calling case, op_const_sv returns a *copy*, which we
2177                donate to newCONSTSUB. Yes, this is ugly, and should be killed.
2178                Need to fix how lib/constant.pm works to eliminate this.  */
2179             cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
2180         }
2181         else {
2182             CvCONST_off(cv);
2183         }
2184     }
2185
2186     return cv;
2187 }
2188
2189 CV *
2190 Perl_cv_clone(pTHX_ CV *proto)
2191 {
2192     PERL_ARGS_ASSERT_CV_CLONE;
2193
2194     if (!CvPADLIST(proto)) Perl_croak(aTHX_ "panic: no pad in cv_clone");
2195     return S_cv_clone(aTHX_ proto, NULL, NULL);
2196 }
2197
2198 /* Called only by pp_clonecv */
2199 CV *
2200 Perl_cv_clone_into(pTHX_ CV *proto, CV *target)
2201 {
2202     PERL_ARGS_ASSERT_CV_CLONE_INTO;
2203     cv_undef(target);
2204     return S_cv_clone(aTHX_ proto, target, NULL);
2205 }
2206
2207 /*
2208 =for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
2209
2210 For any anon CVs in the pad, change CvOUTSIDE of that CV from
2211 old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
2212 moved to a pre-existing CV struct.
2213
2214 =cut
2215 */
2216
2217 void
2218 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
2219 {
2220     dVAR;
2221     I32 ix;
2222     AV * const comppad_name = PadlistARRAY(padlist)[0];
2223     AV * const comppad = PadlistARRAY(padlist)[1];
2224     SV ** const namepad = AvARRAY(comppad_name);
2225     SV ** const curpad = AvARRAY(comppad);
2226
2227     PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
2228     PERL_UNUSED_ARG(old_cv);
2229
2230     for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
2231         const SV * const namesv = namepad[ix];
2232         if (namesv && namesv != &PL_sv_undef && !SvPAD_STATE(namesv)
2233             && *SvPVX_const(namesv) == '&')
2234         {
2235           if (SvTYPE(curpad[ix]) == SVt_PVCV) {
2236             MAGIC * const mg =
2237                 SvMAGICAL(curpad[ix])
2238                     ? mg_find(curpad[ix], PERL_MAGIC_proto)
2239                     : NULL;
2240             CV * const innercv = MUTABLE_CV(mg ? mg->mg_obj : curpad[ix]);
2241             if (CvOUTSIDE(innercv) == old_cv) {
2242                 if (!CvWEAKOUTSIDE(innercv)) {
2243                     SvREFCNT_dec(old_cv);
2244                     SvREFCNT_inc_simple_void_NN(new_cv);
2245                 }
2246                 CvOUTSIDE(innercv) = new_cv;
2247             }
2248           }
2249           else { /* format reference */
2250             SV * const rv = curpad[ix];
2251             CV *innercv;
2252             if (!SvOK(rv)) continue;
2253             assert(SvROK(rv));
2254             assert(SvWEAKREF(rv));
2255             innercv = (CV *)SvRV(rv);
2256             assert(!CvWEAKOUTSIDE(innercv));
2257             SvREFCNT_dec(CvOUTSIDE(innercv));
2258             CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
2259           }
2260         }
2261     }
2262 }
2263
2264 /*
2265 =for apidoc m|void|pad_push|PADLIST *padlist|int depth
2266
2267 Push a new pad frame onto the padlist, unless there's already a pad at
2268 this depth, in which case don't bother creating a new one.  Then give
2269 the new pad an @_ in slot zero.
2270
2271 =cut
2272 */
2273
2274 void
2275 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
2276 {
2277     dVAR;
2278
2279     PERL_ARGS_ASSERT_PAD_PUSH;
2280
2281     if (depth > PadlistMAX(padlist) || !PadlistARRAY(padlist)[depth]) {
2282         PAD** const svp = PadlistARRAY(padlist);
2283         AV* const newpad = newAV();
2284         SV** const oldpad = AvARRAY(svp[depth-1]);
2285         I32 ix = AvFILLp((const AV *)svp[1]);
2286         const I32 names_fill = AvFILLp((const AV *)svp[0]);
2287         SV** const names = AvARRAY(svp[0]);
2288         AV *av;
2289
2290         for ( ;ix > 0; ix--) {
2291             if (names_fill >= ix && names[ix] != &PL_sv_undef) {
2292                 const char sigil = SvPVX_const(names[ix])[0];
2293                 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2294                         || (SvFLAGS(names[ix]) & SVpad_STATE)
2295                         || sigil == '&')
2296                 {
2297                     /* outer lexical or anon code */
2298                     av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2299                 }
2300                 else {          /* our own lexical */
2301                     SV *sv; 
2302                     if (sigil == '@')
2303                         sv = MUTABLE_SV(newAV());
2304                     else if (sigil == '%')
2305                         sv = MUTABLE_SV(newHV());
2306                     else
2307                         sv = newSV(0);
2308                     av_store(newpad, ix, sv);
2309                     SvPADMY_on(sv);
2310                 }
2311             }
2312             else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2313                 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
2314             }
2315             else {
2316                 /* save temporaries on recursion? */
2317                 SV * const sv = newSV(0);
2318                 av_store(newpad, ix, sv);
2319                 SvPADTMP_on(sv);
2320             }
2321         }
2322         av = newAV();
2323         av_store(newpad, 0, MUTABLE_SV(av));
2324         AvREIFY_only(av);
2325
2326         padlist_store(padlist, depth, newpad);
2327     }
2328 }
2329
2330 /*
2331 =for apidoc Am|HV *|pad_compname_type|PADOFFSET po
2332
2333 Looks up the type of the lexical variable at position I<po> in the
2334 currently-compiling pad.  If the variable is typed, the stash of the
2335 class to which it is typed is returned.  If not, C<NULL> is returned.
2336
2337 =cut
2338 */
2339
2340 HV *
2341 Perl_pad_compname_type(pTHX_ const PADOFFSET po)
2342 {
2343     dVAR;
2344     SV* const * const av = av_fetch(PL_comppad_name, po, FALSE);
2345     if ( SvPAD_TYPED(*av) ) {
2346         return SvSTASH(*av);
2347     }
2348     return NULL;
2349 }
2350
2351 #if defined(USE_ITHREADS)
2352
2353 #  define av_dup_inc(s,t)       MUTABLE_AV(sv_dup_inc((const SV *)s,t))
2354
2355 /*
2356 =for apidoc padlist_dup
2357
2358 Duplicates a pad.
2359
2360 =cut
2361 */
2362
2363 PADLIST *
2364 Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
2365 {
2366     PADLIST *dstpad;
2367     bool cloneall;
2368     PADOFFSET max;
2369
2370     PERL_ARGS_ASSERT_PADLIST_DUP;
2371
2372     if (!srcpad)
2373         return NULL;
2374
2375     cloneall = param->flags & CLONEf_COPY_STACKS
2376         || SvREFCNT(PadlistARRAY(srcpad)[1]) > 1;
2377     assert (SvREFCNT(PadlistARRAY(srcpad)[1]) == 1);
2378
2379     max = cloneall ? PadlistMAX(srcpad) : 1;
2380
2381     Newx(dstpad, 1, PADLIST);
2382     ptr_table_store(PL_ptr_table, srcpad, dstpad);
2383     PadlistMAX(dstpad) = max;
2384     Newx(PadlistARRAY(dstpad), max + 1, PAD *);
2385
2386     if (cloneall) {
2387         PADOFFSET depth;
2388         for (depth = 0; depth <= max; ++depth)
2389             PadlistARRAY(dstpad)[depth] =
2390                 av_dup_inc(PadlistARRAY(srcpad)[depth], param);
2391     } else {
2392         /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2393            to build anything other than the first level of pads.  */
2394         I32 ix = AvFILLp(PadlistARRAY(srcpad)[1]);
2395         AV *pad1;
2396         const I32 names_fill = AvFILLp(PadlistARRAY(srcpad)[0]);
2397         const PAD *const srcpad1 = PadlistARRAY(srcpad)[1];
2398         SV **oldpad = AvARRAY(srcpad1);
2399         SV **names;
2400         SV **pad1a;
2401         AV *args;
2402
2403         PadlistARRAY(dstpad)[0] =
2404             av_dup_inc(PadlistARRAY(srcpad)[0], param);
2405         names = AvARRAY(PadlistARRAY(dstpad)[0]);
2406
2407         pad1 = newAV();
2408
2409         av_extend(pad1, ix);
2410         PadlistARRAY(dstpad)[1] = pad1;
2411         pad1a = AvARRAY(pad1);
2412
2413         if (ix > -1) {
2414             AvFILLp(pad1) = ix;
2415
2416             for ( ;ix > 0; ix--) {
2417                 if (!oldpad[ix]) {
2418                     pad1a[ix] = NULL;
2419                 } else if (names_fill >= ix && names[ix] != &PL_sv_undef) {
2420                     const char sigil = SvPVX_const(names[ix])[0];
2421                     if ((SvFLAGS(names[ix]) & SVf_FAKE)
2422                         || (SvFLAGS(names[ix]) & SVpad_STATE)
2423                         || sigil == '&')
2424                         {
2425                             /* outer lexical or anon code */
2426                             pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2427                         }
2428                     else {              /* our own lexical */
2429                         if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2430                             /* This is a work around for how the current
2431                                implementation of ?{ } blocks in regexps
2432                                interacts with lexicals.  */
2433                             pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2434                         } else {
2435                             SV *sv; 
2436                             
2437                             if (sigil == '@')
2438                                 sv = MUTABLE_SV(newAV());
2439                             else if (sigil == '%')
2440                                 sv = MUTABLE_SV(newHV());
2441                             else
2442                                 sv = newSV(0);
2443                             pad1a[ix] = sv;
2444                             SvPADMY_on(sv);
2445                         }
2446                     }
2447                 }
2448                 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2449                     pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2450                 }
2451                 else {
2452                     /* save temporaries on recursion? */
2453                     SV * const sv = newSV(0);
2454                     pad1a[ix] = sv;
2455
2456                     /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2457                        FIXTHAT before merging this branch.
2458                        (And I know how to) */
2459                     if (SvPADMY(oldpad[ix]))
2460                         SvPADMY_on(sv);
2461                     else
2462                         SvPADTMP_on(sv);
2463                 }
2464             }
2465
2466             if (oldpad[0]) {
2467                 args = newAV();                 /* Will be @_ */
2468                 AvREIFY_only(args);
2469                 pad1a[0] = (SV *)args;
2470             }
2471         }
2472     }
2473
2474     return dstpad;
2475 }
2476
2477 #endif /* USE_ITHREADS */
2478
2479 PAD **
2480 Perl_padlist_store(pTHX_ PADLIST *padlist, I32 key, PAD *val)
2481 {
2482     dVAR;
2483     PAD **ary;
2484     SSize_t const oldmax = PadlistMAX(padlist);
2485
2486     PERL_ARGS_ASSERT_PADLIST_STORE;
2487
2488     assert(key >= 0);
2489
2490     if (key > PadlistMAX(padlist)) {
2491         av_extend_guts(NULL,key,&PadlistMAX(padlist),
2492                        (SV ***)&PadlistARRAY(padlist),
2493                        (SV ***)&PadlistARRAY(padlist));
2494         Zero(PadlistARRAY(padlist)+oldmax+1, PadlistMAX(padlist)-oldmax,
2495              PAD *);
2496     }
2497     ary = PadlistARRAY(padlist);
2498     SvREFCNT_dec(ary[key]);
2499     ary[key] = val;
2500     return &ary[key];
2501 }
2502
2503 /*
2504  * Local variables:
2505  * c-indentation-style: bsd
2506  * c-basic-offset: 4
2507  * indent-tabs-mode: nil
2508  * End:
2509  *
2510  * ex: set ts=8 sts=4 sw=4 et:
2511  */