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