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