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