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