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