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