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