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