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