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