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