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