This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
In Perl_pad_check_dup(), use sv rather than name for diagnostics.
[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 This file contains the functions that create and manipulate scratchpads,
31 which are array-of-array data structures attached to a CV (ie a sub)
32 and which store lexical variables and opcode temporary and per-thread
33 values.
34
35 =for apidoc m|AV *|CvPADLIST|CV *cv
36 CV's can have CvPADLIST(cv) set to point to an AV.
37
38 For these purposes "forms" are a kind-of CV, eval""s are too (except they're
39 not callable at will and are always thrown away after the eval"" is done
40 executing). Require'd files are simply evals without any outer lexical
41 scope.
42
43 XSUBs don't have CvPADLIST set - dXSTARG fetches values from PL_curpad,
44 but that is really the callers pad (a slot of which is allocated by
45 every entersub).
46
47 The CvPADLIST AV has does not have AvREAL set, so REFCNT of component items
48 is managed "manual" (mostly in pad.c) rather than normal av.c rules.
49 The items in the AV are not SVs as for a normal AV, but other AVs:
50
51 0'th Entry of the CvPADLIST is an AV which represents the "names" or rather
52 the "static type information" for lexicals.
53
54 The CvDEPTH'th entry of CvPADLIST AV is an AV which is the stack frame at that
55 depth of recursion into the CV.
56 The 0'th slot of a frame AV is an AV which is @_.
57 other entries are storage for variables and op targets.
58
59 During compilation:
60 C<PL_comppad_name> is set to the names AV.
61 C<PL_comppad> is set to the frame AV for the frame CvDEPTH == 1.
62 C<PL_curpad> is set to the body of the frame AV (i.e. AvARRAY(PL_comppad)).
63
64 During execution, C<PL_comppad> and C<PL_curpad> refer to the live
65 frame of the currently executing sub.
66
67 Iterating over the names AV iterates over all possible pad
68 items. Pad slots that are SVs_PADTMP (targets/GVs/constants) end up having
69 &PL_sv_undef "names" (see pad_alloc()).
70
71 Only my/our variable (SVs_PADMY/SVs_PADOUR) slots get valid names.
72 The rest are op targets/GVs/constants which are statically allocated
73 or resolved at compile time.  These don't have names by which they
74 can be looked up from Perl code at run time through eval"" like
75 my/our variables can be.  Since they can't be looked up by "name"
76 but only by their index allocated at compile time (which is usually
77 in PL_op->op_targ), wasting a name SV for them doesn't make sense.
78
79 The SVs in the names AV have their PV being the name of the variable.
80 xlow+1..xhigh inclusive in the NV union is a range of cop_seq numbers for
81 which the name is valid.  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 SVf_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, SVf_PADSTALE is overloaded to mean 'not yet initialised'
111
112 =cut
113 */
114
115
116 #include "EXTERN.h"
117 #define PERL_IN_PAD_C
118 #include "perl.h"
119 #include "keywords.h"
120
121 #define COP_SEQ_RANGE_LOW_set(sv,val)           \
122   STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END
123 #define COP_SEQ_RANGE_HIGH_set(sv,val)          \
124   STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
125
126 #define PARENT_PAD_INDEX_set(sv,val)            \
127   STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END
128 #define PARENT_FAKELEX_FLAGS_set(sv,val)        \
129   STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
130
131 #define PAD_MAX I32_MAX
132
133 #ifdef PERL_MAD
134 void pad_peg(const char* s) {
135     static int pegcnt;
136
137     PERL_ARGS_ASSERT_PAD_PEG;
138
139     pegcnt++;
140 }
141 #endif
142
143 /*
144 =for apidoc pad_new
145
146 Create a new compiling padlist, saving and updating the various global
147 vars at the same time as creating the pad itself. The following flags
148 can be OR'ed together:
149
150     padnew_CLONE        this pad is for a cloned CV
151     padnew_SAVE         save old globals
152     padnew_SAVESUB      also save extra stuff for start of sub
153
154 =cut
155 */
156
157 PADLIST *
158 Perl_pad_new(pTHX_ int flags)
159 {
160     dVAR;
161     AV *padlist, *padname, *pad;
162
163     ASSERT_CURPAD_LEGAL("pad_new");
164
165     /* XXX DAPM really need a new SAVEt_PAD which restores all or most
166      * vars (based on flags) rather than storing vals + addresses for
167      * each individually. Also see pad_block_start.
168      * XXX DAPM Try to see whether all these conditionals are required
169      */
170
171     /* save existing state, ... */
172
173     if (flags & padnew_SAVE) {
174         SAVECOMPPAD();
175         SAVESPTR(PL_comppad_name);
176         if (! (flags & padnew_CLONE)) {
177             SAVEI32(PL_padix);
178             SAVEI32(PL_comppad_name_fill);
179             SAVEI32(PL_min_intro_pending);
180             SAVEI32(PL_max_intro_pending);
181             SAVEBOOL(PL_cv_has_eval);
182             if (flags & padnew_SAVESUB) {
183                 SAVEBOOL(PL_pad_reset_pending);
184             }
185         }
186     }
187     /* XXX DAPM interestingly, PL_comppad_name_floor never seems to be
188      * saved - check at some pt that this is okay */
189
190     /* ... create new pad ... */
191
192     padlist     = newAV();
193     padname     = newAV();
194     pad         = newAV();
195
196     if (flags & padnew_CLONE) {
197         /* XXX DAPM  I dont know why cv_clone needs it
198          * doing differently yet - perhaps this separate branch can be
199          * dispensed with eventually ???
200          */
201
202         AV * const a0 = newAV();                        /* will be @_ */
203         av_extend(a0, 0);
204         av_store(pad, 0, MUTABLE_SV(a0));
205         AvREIFY_only(a0);
206     }
207     else {
208         av_store(pad, 0, NULL);
209     }
210
211     AvREAL_off(padlist);
212     av_store(padlist, 0, MUTABLE_SV(padname));
213     av_store(padlist, 1, MUTABLE_SV(pad));
214
215     /* ... then update state variables */
216
217     PL_comppad_name     = MUTABLE_AV((*av_fetch(padlist, 0, FALSE)));
218     PL_comppad          = MUTABLE_AV((*av_fetch(padlist, 1, FALSE)));
219     PL_curpad           = AvARRAY(PL_comppad);
220
221     if (! (flags & padnew_CLONE)) {
222         PL_comppad_name_fill = 0;
223         PL_min_intro_pending = 0;
224         PL_padix             = 0;
225         PL_cv_has_eval       = 0;
226     }
227
228     DEBUG_X(PerlIO_printf(Perl_debug_log,
229           "Pad 0x%"UVxf"[0x%"UVxf"] new:       compcv=0x%"UVxf
230               " name=0x%"UVxf" flags=0x%"UVxf"\n",
231           PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(PL_compcv),
232               PTR2UV(padname), (UV)flags
233         )
234     );
235
236     return (PADLIST*)padlist;
237 }
238
239 /*
240 =for apidoc pad_undef
241
242 Free the padlist associated with a CV.
243 If parts of it happen to be current, we null the relevant
244 PL_*pad* global vars so that we don't have any dangling references left.
245 We also repoint the CvOUTSIDE of any about-to-be-orphaned
246 inner subs to the outer of this cv.
247
248 (This function should really be called pad_free, but the name was already
249 taken)
250
251 =cut
252 */
253
254 void
255 Perl_pad_undef(pTHX_ CV* cv)
256 {
257     dVAR;
258     I32 ix;
259     const PADLIST * const padlist = CvPADLIST(cv);
260
261     PERL_ARGS_ASSERT_PAD_UNDEF;
262
263     pad_peg("pad_undef");
264     if (!padlist)
265         return;
266     if (SvIS_FREED(padlist)) /* may be during global destruction */
267         return;
268
269     DEBUG_X(PerlIO_printf(Perl_debug_log,
270           "Pad undef: cv=0x%"UVxf" padlist=0x%"UVxf" comppad=0x%"UVxf"\n",
271             PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad))
272     );
273
274     /* detach any '&' anon children in the pad; if afterwards they
275      * are still live, fix up their CvOUTSIDEs to point to our outside,
276      * bypassing us. */
277     /* XXX DAPM for efficiency, we should only do this if we know we have
278      * children, or integrate this loop with general cleanup */
279
280     if (!PL_dirty) { /* don't bother during global destruction */
281         CV * const outercv = CvOUTSIDE(cv);
282         const U32 seq = CvOUTSIDE_SEQ(cv);
283         AV *  const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
284         SV ** const namepad = AvARRAY(comppad_name);
285         AV *  const comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
286         SV ** const curpad = AvARRAY(comppad);
287         for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
288             SV * const namesv = namepad[ix];
289             if (namesv && namesv != &PL_sv_undef
290                 && *SvPVX_const(namesv) == '&')
291             {
292                 CV * const innercv = MUTABLE_CV(curpad[ix]);
293                 U32 inner_rc = SvREFCNT(innercv);
294                 assert(inner_rc);
295                 namepad[ix] = NULL;
296                 SvREFCNT_dec(namesv);
297
298                 if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/  */
299                     curpad[ix] = NULL;
300                     SvREFCNT_dec(innercv);
301                     inner_rc--;
302                 }
303
304                 /* in use, not just a prototype */
305                 if (inner_rc && (CvOUTSIDE(innercv) == cv)) {
306                     assert(CvWEAKOUTSIDE(innercv));
307                     /* don't relink to grandfather if he's being freed */
308                     if (outercv && SvREFCNT(outercv)) {
309                         CvWEAKOUTSIDE_off(innercv);
310                         CvOUTSIDE(innercv) = outercv;
311                         CvOUTSIDE_SEQ(innercv) = seq;
312                         SvREFCNT_inc_simple_void_NN(outercv);
313                     }
314                     else {
315                         CvOUTSIDE(innercv) = NULL;
316                     }
317                 }
318             }
319         }
320     }
321
322     ix = AvFILLp(padlist);
323     while (ix >= 0) {
324         SV* const sv = AvARRAY(padlist)[ix--];
325         if (sv) {
326             if (sv == (const SV *)PL_comppad_name)
327                 PL_comppad_name = NULL;
328             else if (sv == (const SV *)PL_comppad) {
329                 PL_comppad = NULL;
330                 PL_curpad = NULL;
331             }
332         }
333         SvREFCNT_dec(sv);
334     }
335     SvREFCNT_dec(MUTABLE_SV(CvPADLIST(cv)));
336     CvPADLIST(cv) = NULL;
337 }
338
339
340
341
342 /*
343 =for apidoc pad_add_name
344
345 Create a new name and associated PADMY SV in the current pad; return the
346 offset.
347 If C<typestash> is valid, the name is for a typed lexical; set the
348 name's stash to that value.
349 If C<ourstash> is valid, it's an our lexical, set the name's
350 SvOURSTASH to that value
351
352 If fake, it means we're cloning an existing entry
353
354 =cut
355 */
356
357 PADOFFSET
358 Perl_pad_add_name(pTHX_ const char *name, HV* typestash, HV* ourstash, bool fake, bool state)
359 {
360     dVAR;
361     const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
362     SV* const namesv
363         = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV);
364
365     PERL_ARGS_ASSERT_PAD_ADD_NAME;
366
367     ASSERT_CURPAD_ACTIVE("pad_add_name");
368
369     sv_setpv(namesv, name);
370
371     if (typestash) {
372         assert(SvTYPE(namesv) == SVt_PVMG);
373         SvPAD_TYPED_on(namesv);
374         SvSTASH_set(namesv, MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash))));
375     }
376     if (ourstash) {
377         SvPAD_OUR_on(namesv);
378         SvOURSTASH_set(namesv, ourstash);
379         SvREFCNT_inc_simple_void_NN(ourstash);
380     }
381     else if (state) {
382         SvPAD_STATE_on(namesv);
383     }
384
385     av_store(PL_comppad_name, offset, namesv);
386     if (fake) {
387         SvFAKE_on(namesv);
388         DEBUG_Xv(PerlIO_printf(Perl_debug_log,
389             "Pad addname: %ld \"%s\" FAKE\n", (long)offset, name));
390     }
391     else {
392         /* not yet introduced */
393         COP_SEQ_RANGE_LOW_set(namesv, PAD_MAX); /* min */
394         COP_SEQ_RANGE_HIGH_set(namesv, 0);              /* max */
395
396         if (!PL_min_intro_pending)
397             PL_min_intro_pending = offset;
398         PL_max_intro_pending = offset;
399         /* if it's not a simple scalar, replace with an AV or HV */
400         /* XXX DAPM since slot has been allocated, replace
401          * av_store with PL_curpad[offset] ? */
402         if (*name == '@')
403             av_store(PL_comppad, offset, MUTABLE_SV(newAV()));
404         else if (*name == '%')
405             av_store(PL_comppad, offset, MUTABLE_SV(newHV()));
406         SvPADMY_on(PL_curpad[offset]);
407         DEBUG_Xv(PerlIO_printf(Perl_debug_log,
408             "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
409             (long)offset, name, PTR2UV(PL_curpad[offset])));
410     }
411
412     return offset;
413 }
414
415
416
417
418 /*
419 =for apidoc pad_alloc
420
421 Allocate a new my or tmp pad entry. For a my, simply push a null SV onto
422 the end of PL_comppad, but for a tmp, scan the pad from PL_padix upwards
423 for a slot which has no name and no active value.
424
425 =cut
426 */
427
428 /* XXX DAPM integrate alloc(), add_name() and add_anon(),
429  * or at least rationalise ??? */
430 /* And flag whether the incoming name is UTF8 or 8 bit?
431    Could do this either with the +ve/-ve hack of the HV code, or expanding
432    the flag bits. Either way, this makes proper Unicode safe pad support.
433    NWC
434 */
435
436 PADOFFSET
437 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
438 {
439     dVAR;
440     SV *sv;
441     I32 retval;
442
443     PERL_UNUSED_ARG(optype);
444     ASSERT_CURPAD_ACTIVE("pad_alloc");
445
446     if (AvARRAY(PL_comppad) != PL_curpad)
447         Perl_croak(aTHX_ "panic: pad_alloc");
448     if (PL_pad_reset_pending)
449         pad_reset();
450     if (tmptype & SVs_PADMY) {
451         sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
452         retval = AvFILLp(PL_comppad);
453     }
454     else {
455         SV * const * const names = AvARRAY(PL_comppad_name);
456         const SSize_t names_fill = AvFILLp(PL_comppad_name);
457         for (;;) {
458             /*
459              * "foreach" index vars temporarily become aliases to non-"my"
460              * values.  Thus we must skip, not just pad values that are
461              * marked as current pad values, but also those with names.
462              */
463             /* HVDS why copy to sv here? we don't seem to use it */
464             if (++PL_padix <= names_fill &&
465                    (sv = names[PL_padix]) && sv != &PL_sv_undef)
466                 continue;
467             sv = *av_fetch(PL_comppad, PL_padix, TRUE);
468             if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) &&
469                 !IS_PADGV(sv) && !IS_PADCONST(sv))
470                 break;
471         }
472         retval = PL_padix;
473     }
474     SvFLAGS(sv) |= tmptype;
475     PL_curpad = AvARRAY(PL_comppad);
476
477     DEBUG_X(PerlIO_printf(Perl_debug_log,
478           "Pad 0x%"UVxf"[0x%"UVxf"] alloc:   %ld for %s\n",
479           PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
480           PL_op_name[optype]));
481 #ifdef DEBUG_LEAKING_SCALARS
482     sv->sv_debug_optype = optype;
483     sv->sv_debug_inpad = 1;
484 #endif
485     return (PADOFFSET)retval;
486 }
487
488 /*
489 =for apidoc pad_add_anon
490
491 Add an anon code entry to the current compiling pad
492
493 =cut
494 */
495
496 PADOFFSET
497 Perl_pad_add_anon(pTHX_ SV* sv, OPCODE op_type)
498 {
499     dVAR;
500     PADOFFSET ix;
501     SV* const name = newSV_type(SVt_PVNV);
502
503     PERL_ARGS_ASSERT_PAD_ADD_ANON;
504
505     pad_peg("add_anon");
506     sv_setpvs(name, "&");
507     /* Are these two actually ever read? */
508     COP_SEQ_RANGE_HIGH_set(name, ~0);
509     COP_SEQ_RANGE_LOW_set(name, 1);
510     ix = pad_alloc(op_type, SVs_PADMY);
511     av_store(PL_comppad_name, ix, name);
512     /* XXX DAPM use PL_curpad[] ? */
513     av_store(PL_comppad, ix, sv);
514     SvPADMY_on(sv);
515
516     /* to avoid ref loops, we never have parent + child referencing each
517      * other simultaneously */
518     if (CvOUTSIDE((const CV *)sv)) {
519         assert(!CvWEAKOUTSIDE((const CV *)sv));
520         CvWEAKOUTSIDE_on(MUTABLE_CV(sv));
521         SvREFCNT_dec(CvOUTSIDE(MUTABLE_CV(sv)));
522     }
523     return ix;
524 }
525
526
527
528 /*
529 =for apidoc pad_check_dup
530
531 Check for duplicate declarations: report any of:
532      * a my in the current scope with the same name;
533      * an our (anywhere in the pad) with the same name and the same stash
534        as C<ourstash>
535 C<is_our> indicates that the name to check is an 'our' declaration
536
537 =cut
538 */
539
540 /* XXX DAPM integrate this into pad_add_name ??? */
541
542 void
543 Perl_pad_check_dup(pTHX_ const char *name, bool is_our, const HV *ourstash)
544 {
545     dVAR;
546     SV          **svp;
547     PADOFFSET   top, off;
548
549     PERL_ARGS_ASSERT_PAD_CHECK_DUP;
550
551     ASSERT_CURPAD_ACTIVE("pad_check_dup");
552     if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC))
553         return; /* nothing to check */
554
555     svp = AvARRAY(PL_comppad_name);
556     top = AvFILLp(PL_comppad_name);
557     /* check the current scope */
558     /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
559      * type ? */
560     for (off = top; (I32)off > PL_comppad_name_floor; off--) {
561         SV * const sv = svp[off];
562         if (sv
563             && sv != &PL_sv_undef
564             && !SvFAKE(sv)
565             && (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX || COP_SEQ_RANGE_HIGH(sv) == 0)
566             && strEQ(name, SvPVX_const(sv)))
567         {
568             if (is_our && (SvPAD_OUR(sv)))
569                 break; /* "our" masking "our" */
570             Perl_warner(aTHX_ packWARN(WARN_MISC),
571                 "\"%s\" variable %"SVf" masks earlier declaration in same %s",
572                 (is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"),
573                 sv,
574                 (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX ? "scope" : "statement"));
575             --off;
576             break;
577         }
578     }
579     /* check the rest of the pad */
580     if (is_our) {
581         do {
582             SV * const sv = svp[off];
583             if (sv
584                 && sv != &PL_sv_undef
585                 && !SvFAKE(sv)
586                 && (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX || COP_SEQ_RANGE_HIGH(sv) == 0)
587                 && SvOURSTASH(sv) == ourstash
588                 && strEQ(name, SvPVX_const(sv)))
589             {
590                 Perl_warner(aTHX_ packWARN(WARN_MISC),
591                     "\"our\" variable %"SVf" redeclared", sv);
592                 if ((I32)off <= PL_comppad_name_floor)
593                     Perl_warner(aTHX_ packWARN(WARN_MISC),
594                         "\t(Did you mean \"local\" instead of \"our\"?)\n");
595                 break;
596             }
597         } while ( off-- > 0 );
598     }
599 }
600
601
602 /*
603 =for apidoc pad_findmy
604
605 Given a lexical name, try to find its offset, first in the current pad,
606 or failing that, in the pads of any lexically enclosing subs (including
607 the complications introduced by eval). If the name is found in an outer pad,
608 then a fake entry is added to the current pad.
609 Returns the offset in the current pad, or NOT_IN_PAD on failure.
610
611 =cut
612 */
613
614 PADOFFSET
615 Perl_pad_findmy(pTHX_ const char *name, STRLEN len, U32 flags)
616 {
617     dVAR;
618     SV *out_sv;
619     int out_flags;
620     I32 offset;
621     const AV *nameav;
622     SV **name_svp;
623
624     PERL_ARGS_ASSERT_PAD_FINDMY;
625
626     pad_peg("pad_findmy");
627
628     if (flags)
629         Perl_croak(aTHX_ "panic: pad_findmy illegal flag bits 0x%" UVxf,
630                    (UV)flags);
631
632     /* Yes, it is a bug (read work in progress) that we're not really using this
633        length parameter, and instead relying on strlen() later on. But I'm not
634        comfortable about changing the pad API piecemeal to use and rely on
635        lengths. This only exists to avoid an "unused parameter" warning.  */
636     if (len < 2) 
637         return NOT_IN_PAD;
638
639     /* But until we're using the length for real, cross check that we're being
640        told the truth.  */
641     assert(strlen(name) == len);
642
643     offset = pad_findlex(name, PL_compcv, PL_cop_seqmax, 1,
644                 NULL, &out_sv, &out_flags);
645     if ((PADOFFSET)offset != NOT_IN_PAD) 
646         return offset;
647
648     /* look for an our that's being introduced; this allows
649      *    our $foo = 0 unless defined $foo;
650      * to not give a warning. (Yes, this is a hack) */
651
652     nameav = MUTABLE_AV(AvARRAY(CvPADLIST(PL_compcv))[0]);
653     name_svp = AvARRAY(nameav);
654     for (offset = AvFILLp(nameav); offset > 0; offset--) {
655         const SV * const namesv = name_svp[offset];
656         if (namesv && namesv != &PL_sv_undef
657             && !SvFAKE(namesv)
658             && (SvPAD_OUR(namesv))
659             && strEQ(SvPVX_const(namesv), name)
660             && COP_SEQ_RANGE_LOW(namesv) == PAD_MAX /* min */
661         )
662             return offset;
663     }
664     return NOT_IN_PAD;
665 }
666
667 /*
668  * Returns the offset of a lexical $_, if there is one, at run time.
669  * Used by the UNDERBAR XS macro.
670  */
671
672 PADOFFSET
673 Perl_find_rundefsvoffset(pTHX)
674 {
675     dVAR;
676     SV *out_sv;
677     int out_flags;
678     return pad_findlex("$_", find_runcv(NULL), PL_curcop->cop_seq, 1,
679             NULL, &out_sv, &out_flags);
680 }
681
682 /*
683 =for apidoc pad_findlex
684
685 Find a named lexical anywhere in a chain of nested pads. Add fake entries
686 in the inner pads if it's found in an outer one.
687
688 Returns the offset in the bottom pad of the lex or the fake lex.
689 cv is the CV in which to start the search, and seq is the current cop_seq
690 to match against. If warn is true, print appropriate warnings.  The out_*
691 vars return values, and so are pointers to where the returned values
692 should be stored. out_capture, if non-null, requests that the innermost
693 instance of the lexical is captured; out_name_sv is set to the innermost
694 matched namesv or fake namesv; out_flags returns the flags normally
695 associated with the IVX field of a fake namesv.
696
697 Note that pad_findlex() is recursive; it recurses up the chain of CVs,
698 then comes back down, adding fake entries as it goes. It has to be this way
699 because fake namesvs in anon protoypes have to store in xlow the index into
700 the parent pad.
701
702 =cut
703 */
704
705 /* the CV has finished being compiled. This is not a sufficient test for
706  * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
707 #define CvCOMPILED(cv)  CvROOT(cv)
708
709 /* the CV does late binding of its lexicals */
710 #define CvLATE(cv) (CvANON(cv) || SvTYPE(cv) == SVt_PVFM)
711
712
713 STATIC PADOFFSET
714 S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn,
715         SV** out_capture, SV** out_name_sv, int *out_flags)
716 {
717     dVAR;
718     I32 offset, new_offset;
719     SV *new_capture;
720     SV **new_capturep;
721     const AV * const padlist = CvPADLIST(cv);
722
723     PERL_ARGS_ASSERT_PAD_FINDLEX;
724
725     *out_flags = 0;
726
727     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
728         "Pad findlex cv=0x%"UVxf" searching \"%s\" seq=%d%s\n",
729         PTR2UV(cv), name, (int)seq, out_capture ? " capturing" : "" ));
730
731     /* first, search this pad */
732
733     if (padlist) { /* not an undef CV */
734         I32 fake_offset = 0;
735         const AV * const nameav = MUTABLE_AV(AvARRAY(padlist)[0]);
736         SV * const * const name_svp = AvARRAY(nameav);
737
738         for (offset = AvFILLp(nameav); offset > 0; offset--) {
739             const SV * const namesv = name_svp[offset];
740             if (namesv && namesv != &PL_sv_undef
741                     && strEQ(SvPVX_const(namesv), name))
742             {
743                 if (SvFAKE(namesv))
744                     fake_offset = offset; /* in case we don't find a real one */
745                 else if (  seq >  COP_SEQ_RANGE_LOW(namesv)     /* min */
746                         && seq <= COP_SEQ_RANGE_HIGH(namesv))   /* max */
747                     break;
748             }
749         }
750
751         if (offset > 0 || fake_offset > 0 ) { /* a match! */
752             if (offset > 0) { /* not fake */
753                 fake_offset = 0;
754                 *out_name_sv = name_svp[offset]; /* return the namesv */
755
756                 /* set PAD_FAKELEX_MULTI if this lex can have multiple
757                  * instances. For now, we just test !CvUNIQUE(cv), but
758                  * ideally, we should detect my's declared within loops
759                  * etc - this would allow a wider range of 'not stayed
760                  * shared' warnings. We also treated alreadly-compiled
761                  * lexes as not multi as viewed from evals. */
762
763                 *out_flags = CvANON(cv) ?
764                         PAD_FAKELEX_ANON :
765                             (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
766                                 ? PAD_FAKELEX_MULTI : 0;
767
768                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
769                     "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n",
770                     PTR2UV(cv), (long)offset,
771                     (unsigned long)COP_SEQ_RANGE_LOW(*out_name_sv),
772                     (unsigned long)COP_SEQ_RANGE_HIGH(*out_name_sv)));
773             }
774             else { /* fake match */
775                 offset = fake_offset;
776                 *out_name_sv = name_svp[offset]; /* return the namesv */
777                 *out_flags = PARENT_FAKELEX_FLAGS(*out_name_sv);
778                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
779                     "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
780                     PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
781                     (unsigned long) PARENT_PAD_INDEX(*out_name_sv) 
782                 ));
783             }
784
785             /* return the lex? */
786
787             if (out_capture) {
788
789                 /* our ? */
790                 if (SvPAD_OUR(*out_name_sv)) {
791                     *out_capture = NULL;
792                     return offset;
793                 }
794
795                 /* trying to capture from an anon prototype? */
796                 if (CvCOMPILED(cv)
797                         ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
798                         : *out_flags & PAD_FAKELEX_ANON)
799                 {
800                     if (warn)
801                         Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
802                                        "Variable \"%s\" is not available", name);
803                     *out_capture = NULL;
804                 }
805
806                 /* real value */
807                 else {
808                     int newwarn = warn;
809                     if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
810                          && !SvPAD_STATE(name_svp[offset])
811                          && warn && ckWARN(WARN_CLOSURE)) {
812                         newwarn = 0;
813                         Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
814                             "Variable \"%s\" will not stay shared", name);
815                     }
816
817                     if (fake_offset && CvANON(cv)
818                             && CvCLONE(cv) &&!CvCLONED(cv))
819                     {
820                         SV *n;
821                         /* not yet caught - look further up */
822                         DEBUG_Xv(PerlIO_printf(Perl_debug_log,
823                             "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
824                             PTR2UV(cv)));
825                         n = *out_name_sv;
826                         (void) pad_findlex(name, CvOUTSIDE(cv),
827                             CvOUTSIDE_SEQ(cv),
828                             newwarn, out_capture, out_name_sv, out_flags);
829                         *out_name_sv = n;
830                         return offset;
831                     }
832
833                     *out_capture = AvARRAY(MUTABLE_AV(AvARRAY(padlist)[
834                                     CvDEPTH(cv) ? CvDEPTH(cv) : 1]))[offset];
835                     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
836                         "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
837                         PTR2UV(cv), PTR2UV(*out_capture)));
838
839                     if (SvPADSTALE(*out_capture)
840                         && !SvPAD_STATE(name_svp[offset]))
841                     {
842                         Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
843                                        "Variable \"%s\" is not available", name);
844                         *out_capture = NULL;
845                     }
846                 }
847                 if (!*out_capture) {
848                     if (*name == '@')
849                         *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
850                     else if (*name == '%')
851                         *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
852                     else
853                         *out_capture = sv_newmortal();
854                 }
855             }
856
857             return offset;
858         }
859     }
860
861     /* it's not in this pad - try above */
862
863     if (!CvOUTSIDE(cv))
864         return NOT_IN_PAD;
865
866     /* out_capture non-null means caller wants us to capture lex; in
867      * addition we capture ourselves unless it's an ANON/format */
868     new_capturep = out_capture ? out_capture :
869                 CvLATE(cv) ? NULL : &new_capture;
870
871     offset = pad_findlex(name, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
872                 new_capturep, out_name_sv, out_flags);
873     if ((PADOFFSET)offset == NOT_IN_PAD)
874         return NOT_IN_PAD;
875
876     /* found in an outer CV. Add appropriate fake entry to this pad */
877
878     /* don't add new fake entries (via eval) to CVs that we have already
879      * finished compiling, or to undef CVs */
880     if (CvCOMPILED(cv) || !padlist)
881         return 0; /* this dummy (and invalid) value isnt used by the caller */
882
883     {
884         SV *new_namesv;
885         AV *  const ocomppad_name = PL_comppad_name;
886         PAD * const ocomppad = PL_comppad;
887         PL_comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
888         PL_comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
889         PL_curpad = AvARRAY(PL_comppad);
890
891         new_offset = pad_add_name(
892             SvPVX_const(*out_name_sv),
893             SvPAD_TYPED(*out_name_sv)
894                     ? SvSTASH(*out_name_sv) : NULL,
895             SvOURSTASH(*out_name_sv),
896             1,  /* fake */
897             SvPAD_STATE(*out_name_sv) ? 1 : 0 /* state variable ? */
898         );
899
900         new_namesv = AvARRAY(PL_comppad_name)[new_offset];
901         PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags);
902
903         PARENT_PAD_INDEX_set(new_namesv, 0);
904         if (SvPAD_OUR(new_namesv)) {
905             NOOP;   /* do nothing */
906         }
907         else if (CvLATE(cv)) {
908             /* delayed creation - just note the offset within parent pad */
909             PARENT_PAD_INDEX_set(new_namesv, offset);
910             CvCLONE_on(cv);
911         }
912         else {
913             /* immediate creation - capture outer value right now */
914             av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
915             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
916                 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
917                 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
918         }
919         *out_name_sv = new_namesv;
920         *out_flags = PARENT_FAKELEX_FLAGS(new_namesv);
921
922         PL_comppad_name = ocomppad_name;
923         PL_comppad = ocomppad;
924         PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
925     }
926     return new_offset;
927 }
928
929
930 #ifdef DEBUGGING
931 /*
932 =for apidoc pad_sv
933
934 Get the value at offset po in the current pad.
935 Use macro PAD_SV instead of calling this function directly.
936
937 =cut
938 */
939
940
941 SV *
942 Perl_pad_sv(pTHX_ PADOFFSET po)
943 {
944     dVAR;
945     ASSERT_CURPAD_ACTIVE("pad_sv");
946
947     if (!po)
948         Perl_croak(aTHX_ "panic: pad_sv po");
949     DEBUG_X(PerlIO_printf(Perl_debug_log,
950         "Pad 0x%"UVxf"[0x%"UVxf"] sv:      %ld sv=0x%"UVxf"\n",
951         PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
952     );
953     return PL_curpad[po];
954 }
955
956
957 /*
958 =for apidoc pad_setsv
959
960 Set the entry at offset po in the current pad to sv.
961 Use the macro PAD_SETSV() rather than calling this function directly.
962
963 =cut
964 */
965
966 void
967 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
968 {
969     dVAR;
970
971     PERL_ARGS_ASSERT_PAD_SETSV;
972
973     ASSERT_CURPAD_ACTIVE("pad_setsv");
974
975     DEBUG_X(PerlIO_printf(Perl_debug_log,
976         "Pad 0x%"UVxf"[0x%"UVxf"] setsv:   %ld sv=0x%"UVxf"\n",
977         PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
978     );
979     PL_curpad[po] = sv;
980 }
981 #endif
982
983
984
985 /*
986 =for apidoc pad_block_start
987
988 Update the pad compilation state variables on entry to a new block
989
990 =cut
991 */
992
993 /* XXX DAPM perhaps:
994  *      - integrate this in general state-saving routine ???
995  *      - combine with the state-saving going on in pad_new ???
996  *      - introduce a new SAVE type that does all this in one go ?
997  */
998
999 void
1000 Perl_pad_block_start(pTHX_ int full)
1001 {
1002     dVAR;
1003     ASSERT_CURPAD_ACTIVE("pad_block_start");
1004     SAVEI32(PL_comppad_name_floor);
1005     PL_comppad_name_floor = AvFILLp(PL_comppad_name);
1006     if (full)
1007         PL_comppad_name_fill = PL_comppad_name_floor;
1008     if (PL_comppad_name_floor < 0)
1009         PL_comppad_name_floor = 0;
1010     SAVEI32(PL_min_intro_pending);
1011     SAVEI32(PL_max_intro_pending);
1012     PL_min_intro_pending = 0;
1013     SAVEI32(PL_comppad_name_fill);
1014     SAVEI32(PL_padix_floor);
1015     PL_padix_floor = PL_padix;
1016     PL_pad_reset_pending = FALSE;
1017 }
1018
1019
1020 /*
1021 =for apidoc intro_my
1022
1023 "Introduce" my variables to visible status.
1024
1025 =cut
1026 */
1027
1028 U32
1029 Perl_intro_my(pTHX)
1030 {
1031     dVAR;
1032     SV **svp;
1033     I32 i;
1034
1035     ASSERT_CURPAD_ACTIVE("intro_my");
1036     if (! PL_min_intro_pending)
1037         return PL_cop_seqmax;
1038
1039     svp = AvARRAY(PL_comppad_name);
1040     for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1041         SV * const sv = svp[i];
1042
1043         if (sv && sv != &PL_sv_undef && !SvFAKE(sv) && !COP_SEQ_RANGE_HIGH(sv)) {
1044             COP_SEQ_RANGE_HIGH_set(sv, PAD_MAX);        /* Don't know scope end yet. */
1045             COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
1046             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1047                 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1048                 (long)i, SvPVX_const(sv),
1049                 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1050                 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1051             );
1052         }
1053     }
1054     PL_min_intro_pending = 0;
1055     PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1056     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1057                 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax+1)));
1058
1059     return PL_cop_seqmax++;
1060 }
1061
1062 /*
1063 =for apidoc pad_leavemy
1064
1065 Cleanup at end of scope during compilation: set the max seq number for
1066 lexicals in this scope and warn of any lexicals that never got introduced.
1067
1068 =cut
1069 */
1070
1071 void
1072 Perl_pad_leavemy(pTHX)
1073 {
1074     dVAR;
1075     I32 off;
1076     SV * const * const svp = AvARRAY(PL_comppad_name);
1077
1078     PL_pad_reset_pending = FALSE;
1079
1080     ASSERT_CURPAD_ACTIVE("pad_leavemy");
1081     if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1082         for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1083             const SV * const sv = svp[off];
1084             if (sv && sv != &PL_sv_undef && !SvFAKE(sv))
1085                 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1086                                  "%"SVf" never introduced",
1087                                  SVfARG(sv));
1088         }
1089     }
1090     /* "Deintroduce" my variables that are leaving with this scope. */
1091     for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
1092         const SV * const sv = svp[off];
1093         if (sv && sv != &PL_sv_undef && !SvFAKE(sv) && COP_SEQ_RANGE_HIGH(sv) == PAD_MAX) {
1094             COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
1095             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1096                 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1097                 (long)off, SvPVX_const(sv),
1098                 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1099                 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1100             );
1101         }
1102     }
1103     PL_cop_seqmax++;
1104     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1105             "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1106 }
1107
1108
1109 /*
1110 =for apidoc pad_swipe
1111
1112 Abandon the tmp in the current pad at offset po and replace with a
1113 new one.
1114
1115 =cut
1116 */
1117
1118 void
1119 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1120 {
1121     dVAR;
1122     ASSERT_CURPAD_LEGAL("pad_swipe");
1123     if (!PL_curpad)
1124         return;
1125     if (AvARRAY(PL_comppad) != PL_curpad)
1126         Perl_croak(aTHX_ "panic: pad_swipe curpad");
1127     if (!po)
1128         Perl_croak(aTHX_ "panic: pad_swipe po");
1129
1130     DEBUG_X(PerlIO_printf(Perl_debug_log,
1131                 "Pad 0x%"UVxf"[0x%"UVxf"] swipe:   %ld\n",
1132                 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1133
1134     if (PL_curpad[po])
1135         SvPADTMP_off(PL_curpad[po]);
1136     if (refadjust)
1137         SvREFCNT_dec(PL_curpad[po]);
1138
1139
1140     /* if pad tmps aren't shared between ops, then there's no need to
1141      * create a new tmp when an existing op is freed */
1142 #ifdef USE_BROKEN_PAD_RESET
1143     PL_curpad[po] = newSV(0);
1144     SvPADTMP_on(PL_curpad[po]);
1145 #else
1146     PL_curpad[po] = &PL_sv_undef;
1147 #endif
1148     if ((I32)po < PL_padix)
1149         PL_padix = po - 1;
1150 }
1151
1152
1153 /*
1154 =for apidoc pad_reset
1155
1156 Mark all the current temporaries for reuse
1157
1158 =cut
1159 */
1160
1161 /* XXX pad_reset() is currently disabled because it results in serious bugs.
1162  * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
1163  * on the stack by OPs that use them, there are several ways to get an alias
1164  * to  a shared TARG.  Such an alias will change randomly and unpredictably.
1165  * We avoid doing this until we can think of a Better Way.
1166  * GSAR 97-10-29 */
1167 static void
1168 S_pad_reset(pTHX)
1169 {
1170     dVAR;
1171 #ifdef USE_BROKEN_PAD_RESET
1172     if (AvARRAY(PL_comppad) != PL_curpad)
1173         Perl_croak(aTHX_ "panic: pad_reset curpad");
1174
1175     DEBUG_X(PerlIO_printf(Perl_debug_log,
1176             "Pad 0x%"UVxf"[0x%"UVxf"] reset:     padix %ld -> %ld",
1177             PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1178                 (long)PL_padix, (long)PL_padix_floor
1179             )
1180     );
1181
1182     if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
1183         register I32 po;
1184         for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
1185             if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
1186                 SvPADTMP_off(PL_curpad[po]);
1187         }
1188         PL_padix = PL_padix_floor;
1189     }
1190 #endif
1191     PL_pad_reset_pending = FALSE;
1192 }
1193
1194
1195 /*
1196 =for apidoc pad_tidy
1197
1198 Tidy up a pad after we've finished compiling it:
1199     * remove most stuff from the pads of anonsub prototypes;
1200     * give it a @_;
1201     * mark tmps as such.
1202
1203 =cut
1204 */
1205
1206 /* XXX DAPM surely most of this stuff should be done properly
1207  * at the right time beforehand, rather than going around afterwards
1208  * cleaning up our mistakes ???
1209  */
1210
1211 void
1212 Perl_pad_tidy(pTHX_ padtidy_type type)
1213 {
1214     dVAR;
1215
1216     ASSERT_CURPAD_ACTIVE("pad_tidy");
1217
1218     /* If this CV has had any 'eval-capable' ops planted in it
1219      * (ie it contains eval '...', //ee, /$var/ or /(?{..})/), Then any
1220      * anon prototypes in the chain of CVs should be marked as cloneable,
1221      * so that for example the eval's CV in C<< sub { eval '$x' } >> gets
1222      * the right CvOUTSIDE.
1223      * If running with -d, *any* sub may potentially have an eval
1224      * excuted within it.
1225      */
1226
1227     if (PL_cv_has_eval || PL_perldb) {
1228         const CV *cv;
1229         for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1230             if (cv != PL_compcv && CvCOMPILED(cv))
1231                 break; /* no need to mark already-compiled code */
1232             if (CvANON(cv)) {
1233                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1234                     "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1235                 CvCLONE_on(cv);
1236             }
1237         }
1238     }
1239
1240     /* extend curpad to match namepad */
1241     if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1242         av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1243
1244     if (type == padtidy_SUBCLONE) {
1245         SV * const * const namep = AvARRAY(PL_comppad_name);
1246         PADOFFSET ix;
1247
1248         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1249             SV *namesv;
1250
1251             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1252                 continue;
1253             /*
1254              * The only things that a clonable function needs in its
1255              * pad are anonymous subs.
1256              * The rest are created anew during cloning.
1257              */
1258             if (!((namesv = namep[ix]) != NULL &&
1259                   namesv != &PL_sv_undef &&
1260                    *SvPVX_const(namesv) == '&'))
1261             {
1262                 SvREFCNT_dec(PL_curpad[ix]);
1263                 PL_curpad[ix] = NULL;
1264             }
1265         }
1266     }
1267     else if (type == padtidy_SUB) {
1268         /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1269         AV * const av = newAV();                        /* Will be @_ */
1270         av_extend(av, 0);
1271         av_store(PL_comppad, 0, MUTABLE_SV(av));
1272         AvREIFY_only(av);
1273     }
1274
1275     /* XXX DAPM rationalise these two similar branches */
1276
1277     if (type == padtidy_SUB) {
1278         PADOFFSET ix;
1279         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1280             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1281                 continue;
1282             if (!SvPADMY(PL_curpad[ix]))
1283                 SvPADTMP_on(PL_curpad[ix]);
1284         }
1285     }
1286     else if (type == padtidy_FORMAT) {
1287         PADOFFSET ix;
1288         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1289             if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
1290                 SvPADTMP_on(PL_curpad[ix]);
1291         }
1292     }
1293     PL_curpad = AvARRAY(PL_comppad);
1294 }
1295
1296
1297 /*
1298 =for apidoc pad_free
1299
1300 Free the SV at offset po in the current pad.
1301
1302 =cut
1303 */
1304
1305 /* XXX DAPM integrate with pad_swipe ???? */
1306 void
1307 Perl_pad_free(pTHX_ PADOFFSET po)
1308 {
1309     dVAR;
1310     ASSERT_CURPAD_LEGAL("pad_free");
1311     if (!PL_curpad)
1312         return;
1313     if (AvARRAY(PL_comppad) != PL_curpad)
1314         Perl_croak(aTHX_ "panic: pad_free curpad");
1315     if (!po)
1316         Perl_croak(aTHX_ "panic: pad_free po");
1317
1318     DEBUG_X(PerlIO_printf(Perl_debug_log,
1319             "Pad 0x%"UVxf"[0x%"UVxf"] free:    %ld\n",
1320             PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1321     );
1322
1323     if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
1324         SvPADTMP_off(PL_curpad[po]);
1325 #ifdef USE_ITHREADS
1326         /* SV could be a shared hash key (eg bugid #19022) */
1327         if (!SvIsCOW(PL_curpad[po]))
1328             SvREADONLY_off(PL_curpad[po]);      /* could be a freed constant */
1329 #endif
1330     }
1331     if ((I32)po < PL_padix)
1332         PL_padix = po - 1;
1333 }
1334
1335
1336
1337 /*
1338 =for apidoc do_dump_pad
1339
1340 Dump the contents of a padlist
1341
1342 =cut
1343 */
1344
1345 void
1346 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1347 {
1348     dVAR;
1349     const AV *pad_name;
1350     const AV *pad;
1351     SV **pname;
1352     SV **ppad;
1353     I32 ix;
1354
1355     PERL_ARGS_ASSERT_DO_DUMP_PAD;
1356
1357     if (!padlist) {
1358         return;
1359     }
1360     pad_name = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 0, FALSE));
1361     pad = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 1, FALSE));
1362     pname = AvARRAY(pad_name);
1363     ppad = AvARRAY(pad);
1364     Perl_dump_indent(aTHX_ level, file,
1365             "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1366             PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1367     );
1368
1369     for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1370         const SV *namesv = pname[ix];
1371         if (namesv && namesv == &PL_sv_undef) {
1372             namesv = NULL;
1373         }
1374         if (namesv) {
1375             if (SvFAKE(namesv))
1376                 Perl_dump_indent(aTHX_ level+1, file,
1377                     "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1378                     (int) ix,
1379                     PTR2UV(ppad[ix]),
1380                     (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1381                     SvPVX_const(namesv),
1382                     (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1383                     (unsigned long)PARENT_PAD_INDEX(namesv)
1384
1385                 );
1386             else
1387                 Perl_dump_indent(aTHX_ level+1, file,
1388                     "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
1389                     (int) ix,
1390                     PTR2UV(ppad[ix]),
1391                     (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1392                     (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1393                     (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1394                     SvPVX_const(namesv)
1395                 );
1396         }
1397         else if (full) {
1398             Perl_dump_indent(aTHX_ level+1, file,
1399                 "%2d. 0x%"UVxf"<%lu>\n",
1400                 (int) ix,
1401                 PTR2UV(ppad[ix]),
1402                 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1403             );
1404         }
1405     }
1406 }
1407
1408
1409
1410 /*
1411 =for apidoc cv_dump
1412
1413 dump the contents of a CV
1414
1415 =cut
1416 */
1417
1418 #ifdef DEBUGGING
1419 STATIC void
1420 S_cv_dump(pTHX_ const CV *cv, const char *title)
1421 {
1422     dVAR;
1423     const CV * const outside = CvOUTSIDE(cv);
1424     AV* const padlist = CvPADLIST(cv);
1425
1426     PERL_ARGS_ASSERT_CV_DUMP;
1427
1428     PerlIO_printf(Perl_debug_log,
1429                   "  %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1430                   title,
1431                   PTR2UV(cv),
1432                   (CvANON(cv) ? "ANON"
1433                    : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1434                    : (cv == PL_main_cv) ? "MAIN"
1435                    : CvUNIQUE(cv) ? "UNIQUE"
1436                    : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1437                   PTR2UV(outside),
1438                   (!outside ? "null"
1439                    : CvANON(outside) ? "ANON"
1440                    : (outside == PL_main_cv) ? "MAIN"
1441                    : CvUNIQUE(outside) ? "UNIQUE"
1442                    : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1443
1444     PerlIO_printf(Perl_debug_log,
1445                     "    PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1446     do_dump_pad(1, Perl_debug_log, padlist, 1);
1447 }
1448 #endif /* DEBUGGING */
1449
1450
1451
1452
1453
1454 /*
1455 =for apidoc cv_clone
1456
1457 Clone a CV: make a new CV which points to the same code etc, but which
1458 has a newly-created pad built by copying the prototype pad and capturing
1459 any outer lexicals.
1460
1461 =cut
1462 */
1463
1464 CV *
1465 Perl_cv_clone(pTHX_ CV *proto)
1466 {
1467     dVAR;
1468     I32 ix;
1469     AV* const protopadlist = CvPADLIST(proto);
1470     const AV *const protopad_name = (const AV *)*av_fetch(protopadlist, 0, FALSE);
1471     const AV *const protopad = (const AV *)*av_fetch(protopadlist, 1, FALSE);
1472     SV** const pname = AvARRAY(protopad_name);
1473     SV** const ppad = AvARRAY(protopad);
1474     const I32 fname = AvFILLp(protopad_name);
1475     const I32 fpad = AvFILLp(protopad);
1476     CV* cv;
1477     SV** outpad;
1478     CV* outside;
1479     long depth;
1480
1481     PERL_ARGS_ASSERT_CV_CLONE;
1482
1483     assert(!CvUNIQUE(proto));
1484
1485     /* Since cloneable anon subs can be nested, CvOUTSIDE may point
1486      * to a prototype; we instead want the cloned parent who called us.
1487      * Note that in general for formats, CvOUTSIDE != find_runcv */
1488
1489     outside = CvOUTSIDE(proto);
1490     if (outside && CvCLONE(outside) && ! CvCLONED(outside))
1491         outside = find_runcv(NULL);
1492     depth = CvDEPTH(outside);
1493     assert(depth || SvTYPE(proto) == SVt_PVFM);
1494     if (!depth)
1495         depth = 1;
1496     assert(CvPADLIST(outside));
1497
1498     ENTER;
1499     SAVESPTR(PL_compcv);
1500
1501     cv = PL_compcv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
1502     CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE);
1503     CvCLONED_on(cv);
1504
1505 #ifdef USE_ITHREADS
1506     CvFILE(cv)          = CvISXSUB(proto) ? CvFILE(proto)
1507                                           : savepv(CvFILE(proto));
1508 #else
1509     CvFILE(cv)          = CvFILE(proto);
1510 #endif
1511     CvGV(cv)            = CvGV(proto);
1512     CvSTASH(cv)         = CvSTASH(proto);
1513     OP_REFCNT_LOCK;
1514     CvROOT(cv)          = OpREFCNT_inc(CvROOT(proto));
1515     OP_REFCNT_UNLOCK;
1516     CvSTART(cv)         = CvSTART(proto);
1517     CvOUTSIDE(cv)       = MUTABLE_CV(SvREFCNT_inc_simple(outside));
1518     CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
1519
1520     if (SvPOK(proto))
1521         sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
1522
1523     CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
1524
1525     av_fill(PL_comppad, fpad);
1526     for (ix = fname; ix >= 0; ix--)
1527         av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
1528
1529     PL_curpad = AvARRAY(PL_comppad);
1530
1531     outpad = AvARRAY(AvARRAY(CvPADLIST(outside))[depth]);
1532
1533     for (ix = fpad; ix > 0; ix--) {
1534         SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
1535         SV *sv = NULL;
1536         if (namesv && namesv != &PL_sv_undef) { /* lexical */
1537             if (SvFAKE(namesv)) {   /* lexical from outside? */
1538                 sv = outpad[PARENT_PAD_INDEX(namesv)];
1539                 assert(sv);
1540                 /* formats may have an inactive parent,
1541                    while my $x if $false can leave an active var marked as
1542                    stale. And state vars are always available */
1543                 if (SvPADSTALE(sv) && !SvPAD_STATE(namesv)) {
1544                     Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1545                                    "Variable \"%s\" is not available", SvPVX_const(namesv));
1546                     sv = NULL;
1547                 }
1548                 else 
1549                     SvREFCNT_inc_simple_void_NN(sv);
1550             }
1551             if (!sv) {
1552                 const char sigil = SvPVX_const(namesv)[0];
1553                 if (sigil == '&')
1554                     sv = SvREFCNT_inc(ppad[ix]);
1555                 else if (sigil == '@')
1556                     sv = MUTABLE_SV(newAV());
1557                 else if (sigil == '%')
1558                     sv = MUTABLE_SV(newHV());
1559                 else
1560                     sv = newSV(0);
1561                 SvPADMY_on(sv);
1562                 /* reset the 'assign only once' flag on each state var */
1563                 if (SvPAD_STATE(namesv))
1564                     SvPADSTALE_on(sv);
1565             }
1566         }
1567         else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
1568             sv = SvREFCNT_inc_NN(ppad[ix]);
1569         }
1570         else {
1571             sv = newSV(0);
1572             SvPADTMP_on(sv);
1573         }
1574         PL_curpad[ix] = sv;
1575     }
1576
1577     DEBUG_Xv(
1578         PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
1579         cv_dump(outside, "Outside");
1580         cv_dump(proto,   "Proto");
1581         cv_dump(cv,      "To");
1582     );
1583
1584     LEAVE;
1585
1586     if (CvCONST(cv)) {
1587         /* Constant sub () { $x } closing over $x - see lib/constant.pm:
1588          * The prototype was marked as a candiate for const-ization,
1589          * so try to grab the current const value, and if successful,
1590          * turn into a const sub:
1591          */
1592         SV* const const_sv = op_const_sv(CvSTART(cv), cv);
1593         if (const_sv) {
1594             SvREFCNT_dec(cv);
1595             cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
1596         }
1597         else {
1598             CvCONST_off(cv);
1599         }
1600     }
1601
1602     return cv;
1603 }
1604
1605
1606 /*
1607 =for apidoc pad_fixup_inner_anons
1608
1609 For any anon CVs in the pad, change CvOUTSIDE of that CV from
1610 old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
1611 moved to a pre-existing CV struct.
1612
1613 =cut
1614 */
1615
1616 void
1617 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
1618 {
1619     dVAR;
1620     I32 ix;
1621     AV * const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
1622     AV * const comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
1623     SV ** const namepad = AvARRAY(comppad_name);
1624     SV ** const curpad = AvARRAY(comppad);
1625
1626     PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
1627     PERL_UNUSED_ARG(old_cv);
1628
1629     for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
1630         const SV * const namesv = namepad[ix];
1631         if (namesv && namesv != &PL_sv_undef
1632             && *SvPVX_const(namesv) == '&')
1633         {
1634             CV * const innercv = MUTABLE_CV(curpad[ix]);
1635             assert(CvWEAKOUTSIDE(innercv));
1636             assert(CvOUTSIDE(innercv) == old_cv);
1637             CvOUTSIDE(innercv) = new_cv;
1638         }
1639     }
1640 }
1641
1642
1643 /*
1644 =for apidoc pad_push
1645
1646 Push a new pad frame onto the padlist, unless there's already a pad at
1647 this depth, in which case don't bother creating a new one.  Then give
1648 the new pad an @_ in slot zero.
1649
1650 =cut
1651 */
1652
1653 void
1654 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
1655 {
1656     dVAR;
1657
1658     PERL_ARGS_ASSERT_PAD_PUSH;
1659
1660     if (depth > AvFILLp(padlist)) {
1661         SV** const svp = AvARRAY(padlist);
1662         AV* const newpad = newAV();
1663         SV** const oldpad = AvARRAY(svp[depth-1]);
1664         I32 ix = AvFILLp((const AV *)svp[1]);
1665         const I32 names_fill = AvFILLp((const AV *)svp[0]);
1666         SV** const names = AvARRAY(svp[0]);
1667         AV *av;
1668
1669         for ( ;ix > 0; ix--) {
1670             if (names_fill >= ix && names[ix] != &PL_sv_undef) {
1671                 const char sigil = SvPVX_const(names[ix])[0];
1672                 if ((SvFLAGS(names[ix]) & SVf_FAKE)
1673                         || (SvFLAGS(names[ix]) & SVpad_STATE)
1674                         || sigil == '&')
1675                 {
1676                     /* outer lexical or anon code */
1677                     av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
1678                 }
1679                 else {          /* our own lexical */
1680                     SV *sv; 
1681                     if (sigil == '@')
1682                         sv = MUTABLE_SV(newAV());
1683                     else if (sigil == '%')
1684                         sv = MUTABLE_SV(newHV());
1685                     else
1686                         sv = newSV(0);
1687                     av_store(newpad, ix, sv);
1688                     SvPADMY_on(sv);
1689                 }
1690             }
1691             else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
1692                 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
1693             }
1694             else {
1695                 /* save temporaries on recursion? */
1696                 SV * const sv = newSV(0);
1697                 av_store(newpad, ix, sv);
1698                 SvPADTMP_on(sv);
1699             }
1700         }
1701         av = newAV();
1702         av_extend(av, 0);
1703         av_store(newpad, 0, MUTABLE_SV(av));
1704         AvREIFY_only(av);
1705
1706         av_store(padlist, depth, MUTABLE_SV(newpad));
1707         AvFILLp(padlist) = depth;
1708     }
1709 }
1710
1711
1712 HV *
1713 Perl_pad_compname_type(pTHX_ const PADOFFSET po)
1714 {
1715     dVAR;
1716     SV* const * const av = av_fetch(PL_comppad_name, po, FALSE);
1717     if ( SvPAD_TYPED(*av) ) {
1718         return SvSTASH(*av);
1719     }
1720     return NULL;
1721 }
1722
1723 /*
1724  * Local variables:
1725  * c-indentation-style: bsd
1726  * c-basic-offset: 4
1727  * indent-tabs-mode: t
1728  * End:
1729  *
1730  * ex: set ts=8 sts=4 sw=4 noet:
1731  */