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