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