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