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