This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
ba45bcf0caa8dfbe531a1bea48fed389ee586e16
[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 NV+1..IV inclusive is a range of cop_seq numbers for which the name is
76 valid.  For typed lexicals name SV is SVt_PVMG and SvSTASH points at the
77 type.  For C<our> lexicals, the type is also SVt_PVMG, with the OURSTASH slot
78 pointing at the stash of the associated global (so that duplicate C<our>
79 declarations in the same package can be detected).  SvCUR is sometimes
80 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 NVX and IVX to store a cop_seq range, since it is
85 in scope throughout. Instead IVX 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, NVX 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)           SvNV_set(sv, (NV)val)
115 #define COP_SEQ_RANGE_HIGH_set(sv,val)          SvUV_set(sv, val)
116
117 #define PARENT_PAD_INDEX_set(sv,val)            SvNV_set(sv, (NV)val)
118 #define PARENT_FAKELEX_FLAGS_set(sv,val)        SvUV_set(sv, val)
119
120 #define PAD_MAX IV_MAX
121
122 #ifdef PERL_MAD
123 void pad_peg(const char* s) {
124     static int pegcnt;
125     pegcnt++;
126 }
127 #endif
128
129 /*
130 =for apidoc pad_new
131
132 Create a new compiling padlist, saving and updating the various global
133 vars at the same time as creating the pad itself. The following flags
134 can be OR'ed together:
135
136     padnew_CLONE        this pad is for a cloned CV
137     padnew_SAVE         save old globals
138     padnew_SAVESUB      also save extra stuff for start of sub
139
140 =cut
141 */
142
143 PADLIST *
144 Perl_pad_new(pTHX_ int flags)
145 {
146     dVAR;
147     AV *padlist, *padname, *pad;
148
149     ASSERT_CURPAD_LEGAL("pad_new");
150
151     /* XXX DAPM really need a new SAVEt_PAD which restores all or most
152      * vars (based on flags) rather than storing vals + addresses for
153      * each individually. Also see pad_block_start.
154      * XXX DAPM Try to see whether all these conditionals are required
155      */
156
157     /* save existing state, ... */
158
159     if (flags & padnew_SAVE) {
160         SAVECOMPPAD();
161         SAVESPTR(PL_comppad_name);
162         if (! (flags & padnew_CLONE)) {
163             SAVEI32(PL_padix);
164             SAVEI32(PL_comppad_name_fill);
165             SAVEI32(PL_min_intro_pending);
166             SAVEI32(PL_max_intro_pending);
167             SAVEI32(PL_cv_has_eval);
168             if (flags & padnew_SAVESUB) {
169                 SAVEI32(PL_pad_reset_pending);
170             }
171         }
172     }
173     /* XXX DAPM interestingly, PL_comppad_name_floor never seems to be
174      * saved - check at some pt that this is okay */
175
176     /* ... create new pad ... */
177
178     padlist     = newAV();
179     padname     = newAV();
180     pad         = newAV();
181
182     if (flags & padnew_CLONE) {
183         /* XXX DAPM  I dont know why cv_clone needs it
184          * doing differently yet - perhaps this separate branch can be
185          * dispensed with eventually ???
186          */
187
188         AV * const a0 = newAV();                        /* will be @_ */
189         av_extend(a0, 0);
190         av_store(pad, 0, (SV*)a0);
191         AvREIFY_only(a0);
192     }
193     else {
194         av_store(pad, 0, NULL);
195     }
196
197     AvREAL_off(padlist);
198     av_store(padlist, 0, (SV*)padname);
199     av_store(padlist, 1, (SV*)pad);
200
201     /* ... then update state variables */
202
203     PL_comppad_name     = (AV*)(*av_fetch(padlist, 0, FALSE));
204     PL_comppad          = (AV*)(*av_fetch(padlist, 1, FALSE));
205     PL_curpad           = AvARRAY(PL_comppad);
206
207     if (! (flags & padnew_CLONE)) {
208         PL_comppad_name_fill = 0;
209         PL_min_intro_pending = 0;
210         PL_padix             = 0;
211         PL_cv_has_eval       = 0;
212     }
213
214     DEBUG_X(PerlIO_printf(Perl_debug_log,
215           "Pad 0x%"UVxf"[0x%"UVxf"] new:       compcv=0x%"UVxf
216               " name=0x%"UVxf" flags=0x%"UVxf"\n",
217           PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(PL_compcv),
218               PTR2UV(padname), (UV)flags
219         )
220     );
221
222     return (PADLIST*)padlist;
223 }
224
225 /*
226 =for apidoc pad_undef
227
228 Free the padlist associated with a CV.
229 If parts of it happen to be current, we null the relevant
230 PL_*pad* global vars so that we don't have any dangling references left.
231 We also repoint the CvOUTSIDE of any about-to-be-orphaned
232 inner subs to the outer of this cv.
233
234 (This function should really be called pad_free, but the name was already
235 taken)
236
237 =cut
238 */
239
240 void
241 Perl_pad_undef(pTHX_ CV* cv)
242 {
243     dVAR;
244     I32 ix;
245     const PADLIST * const padlist = CvPADLIST(cv);
246
247     pad_peg("pad_undef");
248     if (!padlist)
249         return;
250     if (SvIS_FREED(padlist)) /* may be during global destruction */
251         return;
252
253     DEBUG_X(PerlIO_printf(Perl_debug_log,
254           "Pad undef: cv=0x%"UVxf" padlist=0x%"UVxf"\n",
255             PTR2UV(cv), PTR2UV(padlist))
256     );
257
258     /* detach any '&' anon children in the pad; if afterwards they
259      * are still live, fix up their CvOUTSIDEs to point to our outside,
260      * bypassing us. */
261     /* XXX DAPM for efficiency, we should only do this if we know we have
262      * children, or integrate this loop with general cleanup */
263
264     if (!PL_dirty) { /* don't bother during global destruction */
265         CV * const outercv = CvOUTSIDE(cv);
266         const U32 seq = CvOUTSIDE_SEQ(cv);
267         AV *  const comppad_name = (AV*)AvARRAY(padlist)[0];
268         SV ** const namepad = AvARRAY(comppad_name);
269         AV *  const comppad = (AV*)AvARRAY(padlist)[1];
270         SV ** const curpad = AvARRAY(comppad);
271         for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
272             SV * const namesv = namepad[ix];
273             if (namesv && namesv != &PL_sv_undef
274                 && *SvPVX_const(namesv) == '&')
275             {
276                 CV * const innercv = (CV*)curpad[ix];
277                 U32 inner_rc = SvREFCNT(innercv);
278                 assert(inner_rc);
279                 namepad[ix] = NULL;
280                 SvREFCNT_dec(namesv);
281
282                 if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/  */
283                     curpad[ix] = NULL;
284                     SvREFCNT_dec(innercv);
285                     inner_rc--;
286                 }
287
288                 /* in use, not just a prototype */
289                 if (inner_rc && (CvOUTSIDE(innercv) == cv)) {
290                     assert(CvWEAKOUTSIDE(innercv));
291                     /* don't relink to grandfather if he's being freed */
292                     if (outercv && SvREFCNT(outercv)) {
293                         CvWEAKOUTSIDE_off(innercv);
294                         CvOUTSIDE(innercv) = outercv;
295                         CvOUTSIDE_SEQ(innercv) = seq;
296                         SvREFCNT_inc_simple_void_NN(outercv);
297                     }
298                     else {
299                         CvOUTSIDE(innercv) = NULL;
300                     }
301                 }
302             }
303         }
304     }
305
306     ix = AvFILLp(padlist);
307     while (ix >= 0) {
308         const SV* const sv = AvARRAY(padlist)[ix--];
309         if (sv) {
310             if (sv == (SV*)PL_comppad_name)
311                 PL_comppad_name = NULL;
312             else if (sv == (SV*)PL_comppad) {
313                 PL_comppad = NULL;
314                 PL_curpad = NULL;
315             }
316         }
317         SvREFCNT_dec(sv);
318     }
319     SvREFCNT_dec((SV*)CvPADLIST(cv));
320     CvPADLIST(cv) = NULL;
321 }
322
323
324
325
326 /*
327 =for apidoc pad_add_name
328
329 Create a new name and associated PADMY SV in the current pad; return the
330 offset.
331 If C<typestash> is valid, the name is for a typed lexical; set the
332 name's stash to that value.
333 If C<ourstash> is valid, it's an our lexical, set the name's
334 OURSTASH to that value
335
336 If fake, it means we're cloning an existing entry
337
338 =cut
339 */
340
341 PADOFFSET
342 Perl_pad_add_name(pTHX_ const char *name, HV* typestash, HV* ourstash, bool fake, bool state)
343 {
344     dVAR;
345     const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
346     SV* const namesv = newSV(0);
347
348     ASSERT_CURPAD_ACTIVE("pad_add_name");
349
350
351     sv_upgrade(namesv, (ourstash || typestash) ? SVt_PVMG : SVt_PVNV);
352     sv_setpv(namesv, name);
353
354     if (typestash) {
355         assert(SvTYPE(namesv) == SVt_PVMG);
356         SvPAD_TYPED_on(namesv);
357         SvSTASH_set(namesv, (HV*)SvREFCNT_inc_simple_NN((SV*)typestash));
358     }
359     if (ourstash) {
360         SvPAD_OUR_on(namesv);
361         OURSTASH_set(namesv, ourstash);
362         SvREFCNT_inc_simple_void_NN(ourstash);
363     }
364     else if (state) {
365         SvPAD_STATE_on(namesv);
366     }
367
368     av_store(PL_comppad_name, offset, namesv);
369     if (fake) {
370         SvFAKE_on(namesv);
371         DEBUG_Xv(PerlIO_printf(Perl_debug_log,
372             "Pad addname: %ld \"%s\" FAKE\n", (long)offset, name));
373     }
374     else {
375         /* not yet introduced */
376         COP_SEQ_RANGE_LOW_set(namesv, PAD_MAX); /* min */
377         COP_SEQ_RANGE_HIGH_set(namesv, 0);              /* max */
378
379         if (!PL_min_intro_pending)
380             PL_min_intro_pending = offset;
381         PL_max_intro_pending = offset;
382         /* if it's not a simple scalar, replace with an AV or HV */
383         /* XXX DAPM since slot has been allocated, replace
384          * av_store with PL_curpad[offset] ? */
385         if (*name == '@')
386             av_store(PL_comppad, offset, (SV*)newAV());
387         else if (*name == '%')
388             av_store(PL_comppad, offset, (SV*)newHV());
389         SvPADMY_on(PL_curpad[offset]);
390         DEBUG_Xv(PerlIO_printf(Perl_debug_log,
391             "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
392             (long)offset, name, PTR2UV(PL_curpad[offset])));
393     }
394
395     return offset;
396 }
397
398
399
400
401 /*
402 =for apidoc pad_alloc
403
404 Allocate a new my or tmp pad entry. For a my, simply push a null SV onto
405 the end of PL_comppad, but for a tmp, scan the pad from PL_padix upwards
406 for a slot which has no name and no active value.
407
408 =cut
409 */
410
411 /* XXX DAPM integrate alloc(), add_name() and add_anon(),
412  * or at least rationalise ??? */
413 /* And flag whether the incoming name is UTF8 or 8 bit?
414    Could do this either with the +ve/-ve hack of the HV code, or expanding
415    the flag bits. Either way, this makes proper Unicode safe pad support.
416    Also could change the sv structure to make the NV a union with 2 U32s,
417    so that SvCUR() could stop being overloaded in pad SVs.
418    NWC
419 */
420
421 PADOFFSET
422 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
423 {
424     dVAR;
425     SV *sv;
426     I32 retval;
427
428     PERL_UNUSED_ARG(optype);
429     ASSERT_CURPAD_ACTIVE("pad_alloc");
430
431     if (AvARRAY(PL_comppad) != PL_curpad)
432         Perl_croak(aTHX_ "panic: pad_alloc");
433     if (PL_pad_reset_pending)
434         pad_reset();
435     if (tmptype & SVs_PADMY) {
436         sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
437         retval = AvFILLp(PL_comppad);
438     }
439     else {
440         SV * const * const names = AvARRAY(PL_comppad_name);
441         const SSize_t names_fill = AvFILLp(PL_comppad_name);
442         for (;;) {
443             /*
444              * "foreach" index vars temporarily become aliases to non-"my"
445              * values.  Thus we must skip, not just pad values that are
446              * marked as current pad values, but also those with names.
447              */
448             /* HVDS why copy to sv here? we don't seem to use it */
449             if (++PL_padix <= names_fill &&
450                    (sv = names[PL_padix]) && sv != &PL_sv_undef)
451                 continue;
452             sv = *av_fetch(PL_comppad, PL_padix, TRUE);
453             if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) &&
454                 !IS_PADGV(sv) && !IS_PADCONST(sv))
455                 break;
456         }
457         retval = PL_padix;
458     }
459     SvFLAGS(sv) |= tmptype;
460     PL_curpad = AvARRAY(PL_comppad);
461
462     DEBUG_X(PerlIO_printf(Perl_debug_log,
463           "Pad 0x%"UVxf"[0x%"UVxf"] alloc:   %ld for %s\n",
464           PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
465           PL_op_name[optype]));
466 #ifdef DEBUG_LEAKING_SCALARS
467     sv->sv_debug_optype = optype;
468     sv->sv_debug_inpad = 1;
469 #endif
470     return (PADOFFSET)retval;
471 }
472
473 /*
474 =for apidoc pad_add_anon
475
476 Add an anon code entry to the current compiling pad
477
478 =cut
479 */
480
481 PADOFFSET
482 Perl_pad_add_anon(pTHX_ SV* sv, OPCODE op_type)
483 {
484     dVAR;
485     PADOFFSET ix;
486     SV* const name = newSV(0);
487     pad_peg("add_anon");
488     sv_upgrade(name, SVt_PVNV);
489     sv_setpvn(name, "&", 1);
490     /* Are these two actually ever read? */
491     COP_SEQ_RANGE_HIGH_set(name, ~0);
492     COP_SEQ_RANGE_LOW_set(name, 1);
493     ix = pad_alloc(op_type, SVs_PADMY);
494     av_store(PL_comppad_name, ix, name);
495     /* XXX DAPM use PL_curpad[] ? */
496     av_store(PL_comppad, ix, sv);
497     SvPADMY_on(sv);
498
499     /* to avoid ref loops, we never have parent + child referencing each
500      * other simultaneously */
501     if (CvOUTSIDE((CV*)sv)) {
502         assert(!CvWEAKOUTSIDE((CV*)sv));
503         CvWEAKOUTSIDE_on((CV*)sv);
504         SvREFCNT_dec(CvOUTSIDE((CV*)sv));
505     }
506     return ix;
507 }
508
509
510
511 /*
512 =for apidoc pad_check_dup
513
514 Check for duplicate declarations: report any of:
515      * a my in the current scope with the same name;
516      * an our (anywhere in the pad) with the same name and the same stash
517        as C<ourstash>
518 C<is_our> indicates that the name to check is an 'our' declaration
519
520 =cut
521 */
522
523 /* XXX DAPM integrate this into pad_add_name ??? */
524
525 void
526 Perl_pad_check_dup(pTHX_ const char *name, bool is_our, const HV *ourstash)
527 {
528     dVAR;
529     SV          **svp;
530     PADOFFSET   top, off;
531
532     ASSERT_CURPAD_ACTIVE("pad_check_dup");
533     if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC))
534         return; /* nothing to check */
535
536     svp = AvARRAY(PL_comppad_name);
537     top = AvFILLp(PL_comppad_name);
538     /* check the current scope */
539     /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
540      * type ? */
541     for (off = top; (I32)off > PL_comppad_name_floor; off--) {
542         SV * const sv = svp[off];
543         if (sv
544             && sv != &PL_sv_undef
545             && !SvFAKE(sv)
546             && (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX || COP_SEQ_RANGE_HIGH(sv) == 0)
547             && strEQ(name, SvPVX_const(sv)))
548         {
549             if (is_our && (SvPAD_OUR(sv)))
550                 break; /* "our" masking "our" */
551             Perl_warner(aTHX_ packWARN(WARN_MISC),
552                 "\"%s\" variable %s masks earlier declaration in same %s",
553                 (is_our ? "our" : PL_in_my == KEY_my ? "my" : "state"),
554                 name,
555                 (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX ? "scope" : "statement"));
556             --off;
557             break;
558         }
559     }
560     /* check the rest of the pad */
561     if (is_our) {
562         do {
563             SV * const sv = svp[off];
564             if (sv
565                 && sv != &PL_sv_undef
566                 && !SvFAKE(sv)
567                 && (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX || COP_SEQ_RANGE_HIGH(sv) == 0)
568                 && OURSTASH(sv) == ourstash
569                 && strEQ(name, SvPVX_const(sv)))
570             {
571                 Perl_warner(aTHX_ packWARN(WARN_MISC),
572                     "\"our\" variable %s redeclared", name);
573                 if ((I32)off <= PL_comppad_name_floor)
574                     Perl_warner(aTHX_ packWARN(WARN_MISC),
575                         "\t(Did you mean \"local\" instead of \"our\"?)\n");
576                 break;
577             }
578         } while ( off-- > 0 );
579     }
580 }
581
582
583 /*
584 =for apidoc pad_findmy
585
586 Given a lexical name, try to find its offset, first in the current pad,
587 or failing that, in the pads of any lexically enclosing subs (including
588 the complications introduced by eval). If the name is found in an outer pad,
589 then a fake entry is added to the current pad.
590 Returns the offset in the current pad, or NOT_IN_PAD on failure.
591
592 =cut
593 */
594
595 PADOFFSET
596 Perl_pad_findmy(pTHX_ const char *name)
597 {
598     dVAR;
599     SV *out_sv;
600     int out_flags;
601     I32 offset;
602     const AV *nameav;
603     SV **name_svp;
604
605     pad_peg("pad_findmy");
606     offset = pad_findlex(name, PL_compcv, PL_cop_seqmax, 1,
607                 NULL, &out_sv, &out_flags);
608     if ((PADOFFSET)offset != NOT_IN_PAD) 
609         return offset;
610
611     /* look for an our that's being introduced; this allows
612      *    our $foo = 0 unless defined $foo;
613      * to not give a warning. (Yes, this is a hack) */
614
615     nameav = (AV*)AvARRAY(CvPADLIST(PL_compcv))[0];
616     name_svp = AvARRAY(nameav);
617     for (offset = AvFILLp(nameav); offset > 0; offset--) {
618         const SV * const namesv = name_svp[offset];
619         if (namesv && namesv != &PL_sv_undef
620             && !SvFAKE(namesv)
621             && (SvPAD_OUR(namesv))
622             && strEQ(SvPVX_const(namesv), name)
623             && COP_SEQ_RANGE_LOW(namesv) == PAD_MAX /* min */
624         )
625             return offset;
626     }
627     return NOT_IN_PAD;
628 }
629
630 /*
631  * Returns the offset of a lexical $_, if there is one, at run time.
632  * Used by the UNDERBAR XS macro.
633  */
634
635 PADOFFSET
636 Perl_find_rundefsvoffset(pTHX)
637 {
638     dVAR;
639     SV *out_sv;
640     int out_flags;
641     return pad_findlex("$_", find_runcv(NULL), PL_curcop->cop_seq, 1,
642             NULL, &out_sv, &out_flags);
643 }
644
645 /*
646 =for apidoc pad_findlex
647
648 Find a named lexical anywhere in a chain of nested pads. Add fake entries
649 in the inner pads if it's found in an outer one.
650
651 Returns the offset in the bottom pad of the lex or the fake lex.
652 cv is the CV in which to start the search, and seq is the current cop_seq
653 to match against. If warn is true, print appropriate warnings.  The out_*
654 vars return values, and so are pointers to where the returned values
655 should be stored. out_capture, if non-null, requests that the innermost
656 instance of the lexical is captured; out_name_sv is set to the innermost
657 matched namesv or fake namesv; out_flags returns the flags normally
658 associated with the IVX field of a fake namesv.
659
660 Note that pad_findlex() is recursive; it recurses up the chain of CVs,
661 then comes back down, adding fake entries as it goes. It has to be this way
662 because fake namesvs in anon protoypes have to store in NVX the index into
663 the parent pad.
664
665 =cut
666 */
667
668 /* Flags set in the SvIVX field of FAKE namesvs */
669
670 #define PAD_FAKELEX_ANON   1 /* the lex is declared in an ANON, or ... */
671 #define PAD_FAKELEX_MULTI  2 /* the lex can be instantiated multiple times */
672
673 /* the CV has finished being compiled. This is not a sufficient test for
674  * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
675 #define CvCOMPILED(cv)  CvROOT(cv)
676
677 /* the CV does late binding of its lexicals */
678 #define CvLATE(cv) (CvANON(cv) || SvTYPE(cv) == SVt_PVFM)
679
680
681 STATIC PADOFFSET
682 S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn,
683         SV** out_capture, SV** out_name_sv, int *out_flags)
684 {
685     dVAR;
686     I32 offset, new_offset;
687     SV *new_capture;
688     SV **new_capturep;
689     const AV * const padlist = CvPADLIST(cv);
690
691     *out_flags = 0;
692
693     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
694         "Pad findlex cv=0x%"UVxf" searching \"%s\" seq=%d%s\n",
695         PTR2UV(cv), name, (int)seq, out_capture ? " capturing" : "" ));
696
697     /* first, search this pad */
698
699     if (padlist) { /* not an undef CV */
700         I32 fake_offset = 0;
701         const AV * const nameav = (AV*)AvARRAY(padlist)[0];
702         SV * const * const name_svp = AvARRAY(nameav);
703
704         for (offset = AvFILLp(nameav); offset > 0; offset--) {
705             const SV * const namesv = name_svp[offset];
706             if (namesv && namesv != &PL_sv_undef
707                     && strEQ(SvPVX_const(namesv), name))
708             {
709                 if (SvFAKE(namesv))
710                     fake_offset = offset; /* in case we don't find a real one */
711                 else if (  seq >  COP_SEQ_RANGE_LOW(namesv)     /* min */
712                         && seq <= COP_SEQ_RANGE_HIGH(namesv))   /* max */
713                     break;
714             }
715         }
716
717         if (offset > 0 || fake_offset > 0 ) { /* a match! */
718             if (offset > 0) { /* not fake */
719                 fake_offset = 0;
720                 *out_name_sv = name_svp[offset]; /* return the namesv */
721
722                 /* set PAD_FAKELEX_MULTI if this lex can have multiple
723                  * instances. For now, we just test !CvUNIQUE(cv), but
724                  * ideally, we should detect my's declared within loops
725                  * etc - this would allow a wider range of 'not stayed
726                  * shared' warnings. We also treated alreadly-compiled
727                  * lexes as not multi as viewed from evals. */
728
729                 *out_flags = CvANON(cv) ?
730                         PAD_FAKELEX_ANON :
731                             (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
732                                 ? PAD_FAKELEX_MULTI : 0;
733
734                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
735                     "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n",
736                     PTR2UV(cv), (long)offset,
737                     (unsigned long)COP_SEQ_RANGE_LOW(*out_name_sv),
738                     (unsigned long)COP_SEQ_RANGE_HIGH(*out_name_sv)));
739             }
740             else { /* fake match */
741                 offset = fake_offset;
742                 *out_name_sv = name_svp[offset]; /* return the namesv */
743                 *out_flags = PARENT_FAKELEX_FLAGS(*out_name_sv);
744                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
745                     "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
746                     PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
747                     (unsigned long) PARENT_PAD_INDEX(*out_name_sv) 
748                 ));
749             }
750
751             /* return the lex? */
752
753             if (out_capture) {
754
755                 /* our ? */
756                 if (SvPAD_OUR(*out_name_sv)) {
757                     *out_capture = NULL;
758                     return offset;
759                 }
760
761                 /* trying to capture from an anon prototype? */
762                 if (CvCOMPILED(cv)
763                         ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
764                         : *out_flags & PAD_FAKELEX_ANON)
765                 {
766                     if (warn && ckWARN(WARN_CLOSURE))
767                         Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
768                             "Variable \"%s\" is not available", name);
769                     *out_capture = NULL;
770                 }
771
772                 /* real value */
773                 else {
774                     int newwarn = warn;
775                     if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
776                          && warn && ckWARN(WARN_CLOSURE)) {
777                         newwarn = 0;
778                         Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
779                             "Variable \"%s\" will not stay shared", name);
780                     }
781
782                     if (fake_offset && CvANON(cv)
783                             && CvCLONE(cv) &&!CvCLONED(cv))
784                     {
785                         SV *n;
786                         /* not yet caught - look further up */
787                         DEBUG_Xv(PerlIO_printf(Perl_debug_log,
788                             "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
789                             PTR2UV(cv)));
790                         n = *out_name_sv;
791                         (void) pad_findlex(name, CvOUTSIDE(cv),
792                             CvOUTSIDE_SEQ(cv),
793                             newwarn, out_capture, out_name_sv, out_flags);
794                         *out_name_sv = n;
795                         return offset;
796                     }
797
798                     *out_capture = AvARRAY((AV*)AvARRAY(padlist)[
799                                     CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset];
800                     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
801                         "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
802                         PTR2UV(cv), PTR2UV(*out_capture)));
803
804                     if (SvPADSTALE(*out_capture)) {
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             OURSTASH(*out_name_sv),
860             1,  /* fake */
861             0   /* not a 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                             (void*)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(0);
1464     sv_upgrade((SV *)cv, SvTYPE(proto));
1465     CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE);
1466     CvCLONED_on(cv);
1467
1468 #ifdef USE_ITHREADS
1469     CvFILE(cv)          = CvISXSUB(proto) ? CvFILE(proto)
1470                                           : savepv(CvFILE(proto));
1471 #else
1472     CvFILE(cv)          = CvFILE(proto);
1473 #endif
1474     CvGV(cv)            = CvGV(proto);
1475     CvSTASH(cv)         = CvSTASH(proto);
1476     OP_REFCNT_LOCK;
1477     CvROOT(cv)          = OpREFCNT_inc(CvROOT(proto));
1478     OP_REFCNT_UNLOCK;
1479     CvSTART(cv)         = CvSTART(proto);
1480     CvOUTSIDE(cv)       = (CV*)SvREFCNT_inc_simple(outside);
1481     CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
1482
1483     if (SvPOK(proto))
1484         sv_setpvn((SV*)cv, SvPVX_const(proto), SvCUR(proto));
1485
1486     CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
1487
1488     av_fill(PL_comppad, fpad);
1489     for (ix = fname; ix >= 0; ix--)
1490         av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
1491
1492     PL_curpad = AvARRAY(PL_comppad);
1493
1494     outpad = AvARRAY(AvARRAY(CvPADLIST(outside))[depth]);
1495
1496     for (ix = fpad; ix > 0; ix--) {
1497         SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
1498         SV *sv = NULL;
1499         if (namesv && namesv != &PL_sv_undef) { /* lexical */
1500             if (SvFAKE(namesv)) {   /* lexical from outside? */
1501                 sv = outpad[PARENT_PAD_INDEX(namesv)];
1502                 assert(sv);
1503                 /* formats may have an inactive parent */
1504                 if (SvTYPE(proto) == SVt_PVFM && SvPADSTALE(sv)) {
1505                     if (ckWARN(WARN_CLOSURE))
1506                         Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
1507                             "Variable \"%s\" is not available", SvPVX_const(namesv));
1508                     sv = NULL;
1509                 }
1510                 else {
1511                     assert(!SvPADSTALE(sv));
1512                     SvREFCNT_inc_simple_void_NN(sv);
1513                 }
1514             }
1515             if (!sv) {
1516                 const char sigil = SvPVX_const(namesv)[0];
1517                 if (sigil == '&')
1518                     sv = SvREFCNT_inc(ppad[ix]);
1519                 else if (sigil == '@')
1520                     sv = (SV*)newAV();
1521                 else if (sigil == '%')
1522                     sv = (SV*)newHV();
1523                 else
1524                     sv = newSV(0);
1525                 SvPADMY_on(sv);
1526             }
1527         }
1528         else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
1529             sv = SvREFCNT_inc_NN(ppad[ix]);
1530         }
1531         else {
1532             sv = newSV(0);
1533             SvPADTMP_on(sv);
1534         }
1535         PL_curpad[ix] = sv;
1536     }
1537
1538     DEBUG_Xv(
1539         PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
1540         cv_dump(outside, "Outside");
1541         cv_dump(proto,   "Proto");
1542         cv_dump(cv,      "To");
1543     );
1544
1545     LEAVE;
1546
1547     if (CvCONST(cv)) {
1548         /* Constant sub () { $x } closing over $x - see lib/constant.pm:
1549          * The prototype was marked as a candiate for const-ization,
1550          * so try to grab the current const value, and if successful,
1551          * turn into a const sub:
1552          */
1553         SV* const const_sv = op_const_sv(CvSTART(cv), cv);
1554         if (const_sv) {
1555             SvREFCNT_dec(cv);
1556             cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
1557         }
1558         else {
1559             CvCONST_off(cv);
1560         }
1561     }
1562
1563     return cv;
1564 }
1565
1566
1567 /*
1568 =for apidoc pad_fixup_inner_anons
1569
1570 For any anon CVs in the pad, change CvOUTSIDE of that CV from
1571 old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
1572 moved to a pre-existing CV struct.
1573
1574 =cut
1575 */
1576
1577 void
1578 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
1579 {
1580     dVAR;
1581     I32 ix;
1582     AV * const comppad_name = (AV*)AvARRAY(padlist)[0];
1583     AV * const comppad = (AV*)AvARRAY(padlist)[1];
1584     SV ** const namepad = AvARRAY(comppad_name);
1585     SV ** const curpad = AvARRAY(comppad);
1586     PERL_UNUSED_ARG(old_cv);
1587
1588     for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
1589         const SV * const namesv = namepad[ix];
1590         if (namesv && namesv != &PL_sv_undef
1591             && *SvPVX_const(namesv) == '&')
1592         {
1593             CV * const innercv = (CV*)curpad[ix];
1594             assert(CvWEAKOUTSIDE(innercv));
1595             assert(CvOUTSIDE(innercv) == old_cv);
1596             CvOUTSIDE(innercv) = new_cv;
1597         }
1598     }
1599 }
1600
1601
1602 /*
1603 =for apidoc pad_push
1604
1605 Push a new pad frame onto the padlist, unless there's already a pad at
1606 this depth, in which case don't bother creating a new one.  Then give
1607 the new pad an @_ in slot zero.
1608
1609 =cut
1610 */
1611
1612 void
1613 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
1614 {
1615     dVAR;
1616     if (depth > AvFILLp(padlist)) {
1617         SV** const svp = AvARRAY(padlist);
1618         AV* const newpad = newAV();
1619         SV** const oldpad = AvARRAY(svp[depth-1]);
1620         I32 ix = AvFILLp((AV*)svp[1]);
1621         const I32 names_fill = AvFILLp((AV*)svp[0]);
1622         SV** const names = AvARRAY(svp[0]);
1623         AV *av;
1624
1625         for ( ;ix > 0; ix--) {
1626             if (names_fill >= ix && names[ix] != &PL_sv_undef) {
1627                 const char sigil = SvPVX_const(names[ix])[0];
1628                 if ((SvFLAGS(names[ix]) & SVf_FAKE) || sigil == '&') {
1629                     /* outer lexical or anon code */
1630                     av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
1631                 }
1632                 else {          /* our own lexical */
1633                     SV *sv; 
1634                     if (sigil == '@')
1635                         sv = (SV*)newAV();
1636                     else if (sigil == '%')
1637                         sv = (SV*)newHV();
1638                     else
1639                         sv = newSV(0);
1640                     av_store(newpad, ix, sv);
1641                     SvPADMY_on(sv);
1642                 }
1643             }
1644             else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
1645                 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
1646             }
1647             else {
1648                 /* save temporaries on recursion? */
1649                 SV * const sv = newSV(0);
1650                 av_store(newpad, ix, sv);
1651                 SvPADTMP_on(sv);
1652             }
1653         }
1654         av = newAV();
1655         av_extend(av, 0);
1656         av_store(newpad, 0, (SV*)av);
1657         AvREIFY_only(av);
1658
1659         av_store(padlist, depth, (SV*)newpad);
1660         AvFILLp(padlist) = depth;
1661     }
1662 }
1663
1664
1665 HV *
1666 Perl_pad_compname_type(pTHX_ const PADOFFSET po)
1667 {
1668     dVAR;
1669     SV* const * const av = av_fetch(PL_comppad_name, po, FALSE);
1670     if ( SvPAD_TYPED(*av) ) {
1671         return SvSTASH(*av);
1672     }
1673     return NULL;
1674 }
1675
1676 /*
1677  * Local variables:
1678  * c-indentation-style: bsd
1679  * c-basic-offset: 4
1680  * indent-tabs-mode: t
1681  * End:
1682  *
1683  * ex: set ts=8 sts=4 sw=4 noet:
1684  */