XS staticing in ext and dist
[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 =for apidoc Amx|PADLIST *|CvPADLIST|CV *cv
31
32 CV's can have CvPADLIST(cv) set to point to a PADLIST.  This is the CV's
33 scratchpad, which stores lexical variables and opcode temporary and
34 per-thread values.
35
36 For these purposes "formats" 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 do not have a C<CvPADLIST>.  C<dXSTARG> fetches values from C<PL_curpad>,
42 but that is really the callers pad (a slot of which is allocated by
43 every entersub). Do not get or set C<CvPADLIST> if a CV is an XSUB (as
44 determined by C<CvISXSUB()>), C<CvPADLIST> slot is reused for a different
45 internal purpose in XSUBs.
46
47 The PADLIST has a C array where pads are stored.
48
49 The 0th entry of the PADLIST is a PADNAMELIST
50 which represents the "names" or rather
51 the "static type information" for lexicals.  The individual elements of a
52 PADNAMELIST are PADNAMEs.  Future
53 refactorings might stop the PADNAMELIST from being stored in the PADLIST's
54 array, so don't rely on it.  See L</PadlistNAMES>.
55
56 The CvDEPTH'th entry of a PADLIST is a PAD (an AV) which is the stack frame
57 at that depth of recursion into the CV.  The 0th slot of a frame AV is an
58 AV which is C<@_>.  Other entries are storage for variables and op targets.
59
60 Iterating over the PADNAMELIST iterates over all possible pad
61 items.  Pad slots for targets (C<SVs_PADTMP>)
62 and GVs end up having &PL_padname_undef "names", while slots for constants 
63 have C<&PL_padname_const> "names" (see C<L</pad_alloc>>).  That
64 C<&PL_padname_undef>
65 and C<&PL_padname_const> are used is an implementation detail subject to
66 change.  To test for them, use C<!PadnamePV(name)> and
67 S<C<PadnamePV(name) && !PadnameLEN(name)>>, respectively.
68
69 Only C<my>/C<our> variable slots get valid names.
70 The rest are op targets/GVs/constants which are statically allocated
71 or resolved at compile time.  These don't have names by which they
72 can be looked up from Perl code at run time through eval"" the way
73 C<my>/C<our> variables can be.  Since they can't be looked up by "name"
74 but only by their index allocated at compile time (which is usually
75 in C<PL_op->op_targ>), wasting a name SV for them doesn't make sense.
76
77 The pad names in the PADNAMELIST have their PV holding the name of
78 the variable.  The C<COP_SEQ_RANGE_LOW> and C<_HIGH> fields form a range
79 (low+1..high inclusive) of cop_seq numbers for which the name is
80 valid.  During compilation, these fields may hold the special value
81 PERL_PADSEQ_INTRO to indicate various stages:
82
83  COP_SEQ_RANGE_LOW        _HIGH
84  -----------------        -----
85  PERL_PADSEQ_INTRO            0   variable not yet introduced:
86                                   { my ($x
87  valid-seq#   PERL_PADSEQ_INTRO   variable in scope:
88                                   { my ($x)
89  valid-seq#          valid-seq#   compilation of scope complete:
90                                   { my ($x) }
91
92 For typed lexicals C<PadnameTYPE> points at the type stash.  For C<our>
93 lexicals, C<PadnameOURSTASH> points at the stash of the associated global (so
94 that duplicate C<our> declarations in the same package can be detected).
95 C<PadnameGEN> is sometimes used to store the generation number during
96 compilation.
97
98 If C<PadnameOUTER> is set on the pad name, then that slot in the frame AV
99 is a REFCNT'ed reference to a lexical from "outside".  Such entries
100 are sometimes referred to as 'fake'.  In this case, the name does not
101 use 'low' and 'high' to store a cop_seq range, since it is in scope
102 throughout.  Instead 'high' stores some flags containing info about
103 the real lexical (is it declared in an anon, and is it capable of being
104 instantiated multiple times?), and for fake ANONs, 'low' contains the index
105 within the parent's pad where the lexical's value is stored, to make
106 cloning quicker.
107
108 If the 'name' is C<&> the corresponding entry in the PAD
109 is a CV representing a possible closure.
110
111 Note that formats are treated as anon subs, and are cloned each time
112 write is called (if necessary).
113
114 The flag C<SVs_PADSTALE> is cleared on lexicals each time the C<my()> is executed,
115 and set on scope exit.  This allows the
116 C<"Variable $x is not available"> warning
117 to be generated in evals, such as 
118
119     { my $x = 1; sub f { eval '$x'} } f();
120
121 For state vars, C<SVs_PADSTALE> is overloaded to mean 'not yet initialised',
122 but this internal state is stored in a separate pad entry.
123
124 =for apidoc AmxU|PADNAMELIST *|PL_comppad_name
125
126 During compilation, this points to the array containing the names part
127 of the pad for the currently-compiling code.
128
129 =for apidoc AmxU|PAD *|PL_comppad
130
131 During compilation, this points to the array containing the values
132 part of the pad for the currently-compiling code.  (At runtime a CV may
133 have many such value arrays; at compile time just one is constructed.)
134 At runtime, this points to the array containing the currently-relevant
135 values for the pad for the currently-executing code.
136
137 =for apidoc AmxU|SV **|PL_curpad
138
139 Points directly to the body of the L</PL_comppad> array.
140 (I.e., this is C<PAD_ARRAY(PL_comppad)>.)
141
142 =cut
143 */
144
145
146 #include "EXTERN.h"
147 #define PERL_IN_PAD_C
148 #include "perl.h"
149 #include "keywords.h"
150
151 #define COP_SEQ_RANGE_LOW_set(sv,val)           \
152   STMT_START { (sv)->xpadn_low = (val); } STMT_END
153 #define COP_SEQ_RANGE_HIGH_set(sv,val)          \
154   STMT_START { (sv)->xpadn_high = (val); } STMT_END
155
156 #define PARENT_PAD_INDEX_set            COP_SEQ_RANGE_LOW_set
157 #define PARENT_FAKELEX_FLAGS_set        COP_SEQ_RANGE_HIGH_set
158
159 #ifdef DEBUGGING
160 void
161 Perl_set_padlist(CV * cv, PADLIST *padlist){
162     PERL_ARGS_ASSERT_SET_PADLIST;
163 #  if PTRSIZE == 8
164     assert((Size_t)padlist != UINT64_C(0xEFEFEFEFEFEFEFEF));
165 #  elif PTRSIZE == 4
166     assert((Size_t)padlist != 0xEFEFEFEF);
167 #  else
168 #    error unknown pointer size
169 #  endif
170     assert(!CvISXSUB(cv));
171     ((XPVCV*)MUTABLE_PTR(SvANY(cv)))->xcv_padlist_u.xcv_padlist = padlist;
172 }
173 #endif
174
175 /*
176 =for apidoc Am|PADLIST *|pad_new|int flags
177
178 Create a new padlist, updating the global variables for the
179 currently-compiling padlist to point to the new padlist.  The following
180 flags can be OR'ed together:
181
182     padnew_CLONE        this pad is for a cloned CV
183     padnew_SAVE         save old globals on the save stack
184     padnew_SAVESUB      also save extra stuff for start of sub
185
186 =cut
187 */
188
189 PADLIST *
190 Perl_pad_new(pTHX_ int flags)
191 {
192     PADLIST *padlist;
193     PADNAMELIST *padname;
194     PAD *pad;
195     PAD **ary;
196
197     ASSERT_CURPAD_LEGAL("pad_new");
198
199     /* XXX DAPM really need a new SAVEt_PAD which restores all or most
200      * vars (based on flags) rather than storing vals + addresses for
201      * each individually. Also see pad_block_start.
202      * XXX DAPM Try to see whether all these conditionals are required
203      */
204
205     /* save existing state, ... */
206
207     if (flags & padnew_SAVE) {
208         SAVECOMPPAD();
209         if (! (flags & padnew_CLONE)) {
210             SAVESPTR(PL_comppad_name);
211             SAVEI32(PL_padix);
212             SAVEI32(PL_constpadix);
213             SAVEI32(PL_comppad_name_fill);
214             SAVEI32(PL_min_intro_pending);
215             SAVEI32(PL_max_intro_pending);
216             SAVEBOOL(PL_cv_has_eval);
217             if (flags & padnew_SAVESUB) {
218                 SAVEBOOL(PL_pad_reset_pending);
219             }
220         }
221     }
222     /* XXX DAPM interestingly, PL_comppad_name_floor never seems to be
223      * saved - check at some pt that this is okay */
224
225     /* ... create new pad ... */
226
227     Newxz(padlist, 1, PADLIST);
228     pad         = newAV();
229
230     if (flags & padnew_CLONE) {
231         /* XXX DAPM  I dont know why cv_clone needs it
232          * doing differently yet - perhaps this separate branch can be
233          * dispensed with eventually ???
234          */
235
236         AV * const a0 = newAV();                        /* will be @_ */
237         av_store(pad, 0, MUTABLE_SV(a0));
238         AvREIFY_only(a0);
239
240         PadnamelistREFCNT(padname = PL_comppad_name)++;
241     }
242     else {
243         padlist->xpadl_id = PL_padlist_generation++;
244         av_store(pad, 0, NULL);
245         padname = newPADNAMELIST(0);
246         padnamelist_store(padname, 0, &PL_padname_undef);
247     }
248
249     /* Most subroutines never recurse, hence only need 2 entries in the padlist
250        array - names, and depth=1.  The default for av_store() is to allocate
251        0..3, and even an explicit call to av_extend() with <3 will be rounded
252        up, so we inline the allocation of the array here.  */
253     Newx(ary, 2, PAD *);
254     PadlistMAX(padlist) = 1;
255     PadlistARRAY(padlist) = ary;
256     ary[0] = (PAD *)padname;
257     ary[1] = pad;
258
259     /* ... then update state variables */
260
261     PL_comppad          = pad;
262     PL_curpad           = AvARRAY(pad);
263
264     if (! (flags & padnew_CLONE)) {
265         PL_comppad_name      = padname;
266         PL_comppad_name_fill = 0;
267         PL_min_intro_pending = 0;
268         PL_padix             = 0;
269         PL_constpadix        = 0;
270         PL_cv_has_eval       = 0;
271     }
272
273     DEBUG_X(PerlIO_printf(Perl_debug_log,
274           "Pad 0x%"UVxf"[0x%"UVxf"] new:       compcv=0x%"UVxf
275               " name=0x%"UVxf" flags=0x%"UVxf"\n",
276           PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(PL_compcv),
277               PTR2UV(padname), (UV)flags
278         )
279     );
280
281     return (PADLIST*)padlist;
282 }
283
284
285 /*
286 =head1 Embedding Functions
287
288 =for apidoc cv_undef
289
290 Clear out all the active components of a CV.  This can happen either
291 by an explicit C<undef &foo>, or by the reference count going to zero.
292 In the former case, we keep the C<CvOUTSIDE> pointer, so that any anonymous
293 children can still follow the full lexical scope chain.
294
295 =cut
296 */
297
298 void
299 Perl_cv_undef(pTHX_ CV *cv)
300 {
301     PERL_ARGS_ASSERT_CV_UNDEF;
302     cv_undef_flags(cv, 0);
303 }
304
305 void
306 Perl_cv_undef_flags(pTHX_ CV *cv, U32 flags)
307 {
308     CV cvbody;/*CV body will never be realloced inside this func,
309                so dont read it more than once, use fake CV so existing macros
310                will work, the indirection and CV head struct optimized away*/
311     SvANY(&cvbody) = SvANY(cv);
312
313     PERL_ARGS_ASSERT_CV_UNDEF_FLAGS;
314
315     DEBUG_X(PerlIO_printf(Perl_debug_log,
316           "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
317             PTR2UV(cv), PTR2UV(PL_comppad))
318     );
319
320     if (CvFILE(&cvbody)) {
321         char * file = CvFILE(&cvbody);
322         CvFILE(&cvbody) = NULL;
323         if(CvDYNFILE(&cvbody))
324             Safefree(file);
325     }
326
327     /* CvSLABBED_off(&cvbody); *//* turned off below */
328     /* release the sub's body */
329     if (!CvISXSUB(&cvbody)) {
330         if(CvROOT(&cvbody)) {
331             assert(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM); /*unsafe is safe */
332             if (CvDEPTHunsafe(&cvbody)) {
333                 assert(SvTYPE(cv) == SVt_PVCV);
334                 Perl_croak_nocontext("Can't undef active subroutine");
335             }
336             ENTER;
337
338             PAD_SAVE_SETNULLPAD();
339
340             if (CvSLABBED(&cvbody)) OpslabREFCNT_dec_padok(OpSLAB(CvROOT(&cvbody)));
341             op_free(CvROOT(&cvbody));
342             CvROOT(&cvbody) = NULL;
343             CvSTART(&cvbody) = NULL;
344             LEAVE;
345         }
346         else if (CvSLABBED(&cvbody)) {
347             if( CvSTART(&cvbody)) {
348                 ENTER;
349                 PAD_SAVE_SETNULLPAD();
350
351                 /* discard any leaked ops */
352                 if (PL_parser)
353                     parser_free_nexttoke_ops(PL_parser, (OPSLAB *)CvSTART(&cvbody));
354                 opslab_force_free((OPSLAB *)CvSTART(&cvbody));
355                 CvSTART(&cvbody) = NULL;
356
357                 LEAVE;
358             }
359 #ifdef DEBUGGING
360             else Perl_warn(aTHX_ "Slab leaked from cv %p", (void*)cv);
361 #endif
362         }
363     }
364     else { /* dont bother checking if CvXSUB(cv) is true, less branching */
365         CvXSUB(&cvbody) = NULL;
366     }
367     SvPOK_off(MUTABLE_SV(cv));          /* forget prototype */
368     sv_unmagic((SV *)cv, PERL_MAGIC_checkcall);
369     if (!(flags & CV_UNDEF_KEEP_NAME)) {
370         if (CvNAMED(&cvbody)) {
371             CvNAME_HEK_set(&cvbody, NULL);
372             CvNAMED_off(&cvbody);
373         }
374         else CvGV_set(cv, NULL);
375     }
376
377     /* This statement and the subsequence if block was pad_undef().  */
378     pad_peg("pad_undef");
379
380     if (!CvISXSUB(&cvbody) && CvPADLIST(&cvbody)) {
381         I32 ix;
382         const PADLIST *padlist = CvPADLIST(&cvbody);
383
384         /* Free the padlist associated with a CV.
385            If parts of it happen to be current, we null the relevant PL_*pad*
386            global vars so that we don't have any dangling references left.
387            We also repoint the CvOUTSIDE of any about-to-be-orphaned inner
388            subs to the outer of this cv.  */
389
390         DEBUG_X(PerlIO_printf(Perl_debug_log,
391                               "Pad undef: cv=0x%"UVxf" padlist=0x%"UVxf" comppad=0x%"UVxf"\n",
392                               PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad))
393                 );
394
395         /* detach any '&' anon children in the pad; if afterwards they
396          * are still live, fix up their CvOUTSIDEs to point to our outside,
397          * bypassing us. */
398         /* XXX DAPM for efficiency, we should only do this if we know we have
399          * children, or integrate this loop with general cleanup */
400
401         if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */
402             CV * const outercv = CvOUTSIDE(&cvbody);
403             const U32 seq = CvOUTSIDE_SEQ(&cvbody);
404             PADNAMELIST * const comppad_name = PadlistNAMES(padlist);
405             PADNAME ** const namepad = PadnamelistARRAY(comppad_name);
406             PAD * const comppad = PadlistARRAY(padlist)[1];
407             SV ** const curpad = AvARRAY(comppad);
408             for (ix = PadnamelistMAX(comppad_name); ix > 0; ix--) {
409                 PADNAME * const name = namepad[ix];
410                 if (name && PadnamePV(name) && *PadnamePV(name) == '&')
411                     {
412                         CV * const innercv = MUTABLE_CV(curpad[ix]);
413                         U32 inner_rc = SvREFCNT(innercv);
414                         assert(inner_rc);
415                         assert(SvTYPE(innercv) != SVt_PVFM);
416
417                         if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/  */
418                             curpad[ix] = NULL;
419                             SvREFCNT_dec_NN(innercv);
420                             inner_rc--;
421                         }
422
423                         /* in use, not just a prototype */
424                         if (inner_rc && SvTYPE(innercv) == SVt_PVCV
425                          && (CvOUTSIDE(innercv) == cv))
426                         {
427                             assert(CvWEAKOUTSIDE(innercv));
428                             /* don't relink to grandfather if he's being freed */
429                             if (outercv && SvREFCNT(outercv)) {
430                                 CvWEAKOUTSIDE_off(innercv);
431                                 CvOUTSIDE(innercv) = outercv;
432                                 CvOUTSIDE_SEQ(innercv) = seq;
433                                 SvREFCNT_inc_simple_void_NN(outercv);
434                             }
435                             else {
436                                 CvOUTSIDE(innercv) = NULL;
437                             }
438                         }
439                     }
440             }
441         }
442
443         ix = PadlistMAX(padlist);
444         while (ix > 0) {
445             PAD * const sv = PadlistARRAY(padlist)[ix--];
446             if (sv) {
447                 if (sv == PL_comppad) {
448                     PL_comppad = NULL;
449                     PL_curpad = NULL;
450                 }
451                 SvREFCNT_dec_NN(sv);
452             }
453         }
454         {
455             PADNAMELIST * const names = PadlistNAMES(padlist);
456             if (names == PL_comppad_name && PadnamelistREFCNT(names) == 1)
457                 PL_comppad_name = NULL;
458             PadnamelistREFCNT_dec(names);
459         }
460         if (PadlistARRAY(padlist)) Safefree(PadlistARRAY(padlist));
461         Safefree(padlist);
462         CvPADLIST_set(&cvbody, NULL);
463     }
464     else if (CvISXSUB(&cvbody))
465         CvHSCXT(&cvbody) = NULL;
466     /* else is (!CvISXSUB(&cvbody) && !CvPADLIST(&cvbody)) {do nothing;} */
467
468
469     /* remove CvOUTSIDE unless this is an undef rather than a free */
470     if (!SvREFCNT(cv)) {
471         CV * outside = CvOUTSIDE(&cvbody);
472         if(outside) {
473             CvOUTSIDE(&cvbody) = NULL;
474             if (!CvWEAKOUTSIDE(&cvbody))
475                 SvREFCNT_dec_NN(outside);
476         }
477     }
478     if (CvCONST(&cvbody)) {
479         SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(&cvbody).any_ptr));
480         /* CvCONST_off(cv); *//* turned off below */
481     }
482     /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
483      * ref status of CvOUTSIDE and CvGV, and ANON, NAMED and
484      * LEXICAL, which are used to determine the sub's name.  */
485     CvFLAGS(&cvbody) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON|CVf_LEXICAL
486                    |CVf_NAMED);
487 }
488
489 /*
490 =for apidoc cv_forget_slab
491
492 When a CV has a reference count on its slab (C<CvSLABBED>), it is responsible
493 for making sure it is freed.  (Hence, no two CVs should ever have a
494 reference count on the same slab.)  The CV only needs to reference the slab
495 during compilation.  Once it is compiled and C<CvROOT> attached, it has
496 finished its job, so it can forget the slab.
497
498 =cut
499 */
500
501 void
502 Perl_cv_forget_slab(pTHX_ CV *cv)
503 {
504     bool slabbed;
505     OPSLAB *slab = NULL;
506
507     if (!cv)
508         return;
509     slabbed = cBOOL(CvSLABBED(cv));
510     if (!slabbed) return;
511
512     CvSLABBED_off(cv);
513
514     if      (CvROOT(cv))  slab = OpSLAB(CvROOT(cv));
515     else if (CvSTART(cv)) slab = (OPSLAB *)CvSTART(cv);
516 #ifdef DEBUGGING
517     else if (slabbed)     Perl_warn(aTHX_ "Slab leaked from cv %p", (void*)cv);
518 #endif
519
520     if (slab) {
521 #ifdef PERL_DEBUG_READONLY_OPS
522         const size_t refcnt = slab->opslab_refcnt;
523 #endif
524         OpslabREFCNT_dec(slab);
525 #ifdef PERL_DEBUG_READONLY_OPS
526         if (refcnt > 1) Slab_to_ro(slab);
527 #endif
528     }
529 }
530
531 /*
532 =for apidoc m|PADOFFSET|pad_alloc_name|PADNAME *name|U32 flags|HV *typestash|HV *ourstash
533
534 Allocates a place in the currently-compiling
535 pad (via L<perlapi/pad_alloc>) and
536 then stores a name for that entry.  C<name> is adopted and
537 becomes the name entry; it must already contain the name
538 string.  C<typestash> and C<ourstash> and the C<padadd_STATE>
539 flag get added to C<name>.  None of the other
540 processing of L<perlapi/pad_add_name_pvn>
541 is done.  Returns the offset of the allocated pad slot.
542
543 =cut
544 */
545
546 static PADOFFSET
547 S_pad_alloc_name(pTHX_ PADNAME *name, U32 flags, HV *typestash,
548                        HV *ourstash)
549 {
550     const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
551
552     PERL_ARGS_ASSERT_PAD_ALLOC_NAME;
553
554     ASSERT_CURPAD_ACTIVE("pad_alloc_name");
555
556     if (typestash) {
557         SvPAD_TYPED_on(name);
558         PadnameTYPE(name) =
559             MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash)));
560     }
561     if (ourstash) {
562         SvPAD_OUR_on(name);
563         SvOURSTASH_set(name, ourstash);
564         SvREFCNT_inc_simple_void_NN(ourstash);
565     }
566     else if (flags & padadd_STATE) {
567         SvPAD_STATE_on(name);
568     }
569
570     padnamelist_store(PL_comppad_name, offset, name);
571     if (PadnameLEN(name) > 1)
572         PadnamelistMAXNAMED(PL_comppad_name) = offset;
573     return offset;
574 }
575
576 /*
577 =for apidoc Am|PADOFFSET|pad_add_name_pvn|const char *namepv|STRLEN namelen|U32 flags|HV *typestash|HV *ourstash
578
579 Allocates a place in the currently-compiling pad for a named lexical
580 variable.  Stores the name and other metadata in the name part of the
581 pad, and makes preparations to manage the variable's lexical scoping.
582 Returns the offset of the allocated pad slot.
583
584 C<namepv>/C<namelen> specify the variable's name, including leading sigil.
585 If C<typestash> is non-null, the name is for a typed lexical, and this
586 identifies the type.  If C<ourstash> is non-null, it's a lexical reference
587 to a package variable, and this identifies the package.  The following
588 flags can be OR'ed together:
589
590  padadd_OUR          redundantly specifies if it's a package var
591  padadd_STATE        variable will retain value persistently
592  padadd_NO_DUP_CHECK skip check for lexical shadowing
593
594 =cut
595 */
596
597 PADOFFSET
598 Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen,
599                 U32 flags, HV *typestash, HV *ourstash)
600 {
601     PADOFFSET offset;
602     PADNAME *name;
603
604     PERL_ARGS_ASSERT_PAD_ADD_NAME_PVN;
605
606     if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK))
607         Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf,
608                    (UV)flags);
609
610     name = newPADNAMEpvn(namepv, namelen);
611
612     if ((flags & padadd_NO_DUP_CHECK) == 0) {
613         ENTER;
614         SAVEFREEPADNAME(name); /* in case of fatal warnings */
615         /* check for duplicate declaration */
616         pad_check_dup(name, flags & padadd_OUR, ourstash);
617         PadnameREFCNT(name)++;
618         LEAVE;
619     }
620
621     offset = pad_alloc_name(name, flags, typestash, ourstash);
622
623     /* not yet introduced */
624     COP_SEQ_RANGE_LOW_set(name, PERL_PADSEQ_INTRO);
625     COP_SEQ_RANGE_HIGH_set(name, 0);
626
627     if (!PL_min_intro_pending)
628         PL_min_intro_pending = offset;
629     PL_max_intro_pending = offset;
630     /* if it's not a simple scalar, replace with an AV or HV */
631     assert(SvTYPE(PL_curpad[offset]) == SVt_NULL);
632     assert(SvREFCNT(PL_curpad[offset]) == 1);
633     if (namelen != 0 && *namepv == '@')
634         sv_upgrade(PL_curpad[offset], SVt_PVAV);
635     else if (namelen != 0 && *namepv == '%')
636         sv_upgrade(PL_curpad[offset], SVt_PVHV);
637     else if (namelen != 0 && *namepv == '&')
638         sv_upgrade(PL_curpad[offset], SVt_PVCV);
639     assert(SvPADMY(PL_curpad[offset]));
640     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
641                            "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
642                            (long)offset, PadnamePV(name),
643                            PTR2UV(PL_curpad[offset])));
644
645     return offset;
646 }
647
648 /*
649 =for apidoc Am|PADOFFSET|pad_add_name_pv|const char *name|U32 flags|HV *typestash|HV *ourstash
650
651 Exactly like L</pad_add_name_pvn>, but takes a nul-terminated string
652 instead of a string/length pair.
653
654 =cut
655 */
656
657 PADOFFSET
658 Perl_pad_add_name_pv(pTHX_ const char *name,
659                      const U32 flags, HV *typestash, HV *ourstash)
660 {
661     PERL_ARGS_ASSERT_PAD_ADD_NAME_PV;
662     return pad_add_name_pvn(name, strlen(name), flags, typestash, ourstash);
663 }
664
665 /*
666 =for apidoc Am|PADOFFSET|pad_add_name_sv|SV *name|U32 flags|HV *typestash|HV *ourstash
667
668 Exactly like L</pad_add_name_pvn>, but takes the name string in the form
669 of an SV instead of a string/length pair.
670
671 =cut
672 */
673
674 PADOFFSET
675 Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash)
676 {
677     char *namepv;
678     STRLEN namelen;
679     PERL_ARGS_ASSERT_PAD_ADD_NAME_SV;
680     namepv = SvPVutf8(name, namelen);
681     return pad_add_name_pvn(namepv, namelen, flags, typestash, ourstash);
682 }
683
684 /*
685 =for apidoc Amx|PADOFFSET|pad_alloc|I32 optype|U32 tmptype
686
687 Allocates a place in the currently-compiling pad,
688 returning the offset of the allocated pad slot.
689 No name is initially attached to the pad slot.
690 C<tmptype> is a set of flags indicating the kind of pad entry required,
691 which will be set in the value SV for the allocated pad entry:
692
693     SVs_PADMY    named lexical variable ("my", "our", "state")
694     SVs_PADTMP   unnamed temporary store
695     SVf_READONLY constant shared between recursion levels
696
697 C<SVf_READONLY> has been supported here only since perl 5.20.  To work with
698 earlier versions as well, use C<SVf_READONLY|SVs_PADTMP>.  C<SVf_READONLY>
699 does not cause the SV in the pad slot to be marked read-only, but simply
700 tells C<pad_alloc> that it I<will> be made read-only (by the caller), or at
701 least should be treated as such.
702
703 C<optype> should be an opcode indicating the type of operation that the
704 pad entry is to support.  This doesn't affect operational semantics,
705 but is used for debugging.
706
707 =cut
708 */
709
710 /* XXX DAPM integrate alloc(), add_name() and add_anon(),
711  * or at least rationalise ??? */
712
713 PADOFFSET
714 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
715 {
716     SV *sv;
717     I32 retval;
718
719     PERL_UNUSED_ARG(optype);
720     ASSERT_CURPAD_ACTIVE("pad_alloc");
721
722     if (AvARRAY(PL_comppad) != PL_curpad)
723         Perl_croak(aTHX_ "panic: pad_alloc, %p!=%p",
724                    AvARRAY(PL_comppad), PL_curpad);
725     if (PL_pad_reset_pending)
726         pad_reset();
727     if (tmptype == SVs_PADMY) { /* Not & because this ‘flag’ is 0.  */
728         /* For a my, simply push a null SV onto the end of PL_comppad. */
729         sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
730         retval = AvFILLp(PL_comppad);
731     }
732     else {
733         /* For a tmp, scan the pad from PL_padix upwards
734          * for a slot which has no name and no active value.
735          * For a constant, likewise, but use PL_constpadix.
736          */
737         PADNAME * const * const names = PadnamelistARRAY(PL_comppad_name);
738         const SSize_t names_fill = PadnamelistMAX(PL_comppad_name);
739         const bool konst = cBOOL(tmptype & SVf_READONLY);
740         retval = konst ? PL_constpadix : PL_padix;
741         for (;;) {
742             /*
743              * Entries that close over unavailable variables
744              * in outer subs contain values not marked PADMY.
745              * Thus we must skip, not just pad values that are
746              * marked as current pad values, but also those with names.
747              * If pad_reset is enabled, ‘current’ means different
748              * things depending on whether we are allocating a con-
749              * stant or a target.  For a target, things marked PADTMP
750              * can be reused; not so for constants.
751              */
752             PADNAME *pn;
753             if (++retval <= names_fill &&
754                    (pn = names[retval]) && PadnamePV(pn))
755                 continue;
756             sv = *av_fetch(PL_comppad, retval, TRUE);
757             if (!(SvFLAGS(sv) &
758 #ifdef USE_PAD_RESET
759                     (konst ? SVs_PADTMP : 0))
760 #else
761                     SVs_PADTMP
762 #endif
763                  ))
764                 break;
765         }
766         if (konst) {
767             padnamelist_store(PL_comppad_name, retval, &PL_padname_const);
768             tmptype &= ~SVf_READONLY;
769             tmptype |= SVs_PADTMP;
770         }
771         *(konst ? &PL_constpadix : &PL_padix) = retval;
772     }
773     SvFLAGS(sv) |= tmptype;
774     PL_curpad = AvARRAY(PL_comppad);
775
776     DEBUG_X(PerlIO_printf(Perl_debug_log,
777           "Pad 0x%"UVxf"[0x%"UVxf"] alloc:   %ld for %s\n",
778           PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
779           PL_op_name[optype]));
780 #ifdef DEBUG_LEAKING_SCALARS
781     sv->sv_debug_optype = optype;
782     sv->sv_debug_inpad = 1;
783 #endif
784     return (PADOFFSET)retval;
785 }
786
787 /*
788 =for apidoc Am|PADOFFSET|pad_add_anon|CV *func|I32 optype
789
790 Allocates a place in the currently-compiling pad (via L</pad_alloc>)
791 for an anonymous function that is lexically scoped inside the
792 currently-compiling function.
793 The function C<func> is linked into the pad, and its C<CvOUTSIDE> link
794 to the outer scope is weakened to avoid a reference loop.
795
796 One reference count is stolen, so you may need to do C<SvREFCNT_inc(func)>.
797
798 C<optype> should be an opcode indicating the type of operation that the
799 pad entry is to support.  This doesn't affect operational semantics,
800 but is used for debugging.
801
802 =cut
803 */
804
805 PADOFFSET
806 Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
807 {
808     PADOFFSET ix;
809     PADNAME * const name = newPADNAMEpvn("&", 1);
810
811     PERL_ARGS_ASSERT_PAD_ADD_ANON;
812     assert (SvTYPE(func) == SVt_PVCV);
813
814     pad_peg("add_anon");
815     /* These two aren't used; just make sure they're not equal to
816      * PERL_PADSEQ_INTRO.  They should be 0 by default.  */
817     assert(COP_SEQ_RANGE_LOW (name) != PERL_PADSEQ_INTRO);
818     assert(COP_SEQ_RANGE_HIGH(name) != PERL_PADSEQ_INTRO);
819     ix = pad_alloc(optype, SVs_PADMY);
820     padnamelist_store(PL_comppad_name, ix, name);
821     /* XXX DAPM use PL_curpad[] ? */
822     av_store(PL_comppad, ix, (SV*)func);
823
824     /* to avoid ref loops, we never have parent + child referencing each
825      * other simultaneously */
826     if (CvOUTSIDE(func)) {
827         assert(!CvWEAKOUTSIDE(func));
828         CvWEAKOUTSIDE_on(func);
829         SvREFCNT_dec_NN(CvOUTSIDE(func));
830     }
831     return ix;
832 }
833
834 void
835 Perl_pad_add_weakref(pTHX_ CV* func)
836 {
837     const PADOFFSET ix = pad_alloc(OP_NULL, SVs_PADMY);
838     PADNAME * const name = newPADNAMEpvn("&", 1);
839     SV * const rv = newRV_inc((SV *)func);
840
841     PERL_ARGS_ASSERT_PAD_ADD_WEAKREF;
842
843     /* These two aren't used; just make sure they're not equal to
844      * PERL_PADSEQ_INTRO.  They should be 0 by default.  */
845     assert(COP_SEQ_RANGE_LOW (name) != PERL_PADSEQ_INTRO);
846     assert(COP_SEQ_RANGE_HIGH(name) != PERL_PADSEQ_INTRO);
847     padnamelist_store(PL_comppad_name, ix, name);
848     sv_rvweaken(rv);
849     av_store(PL_comppad, ix, rv);
850 }
851
852 /*
853 =for apidoc pad_check_dup
854
855 Check for duplicate declarations: report any of:
856
857      * a 'my' in the current scope with the same name;
858      * an 'our' (anywhere in the pad) with the same name and the
859        same stash as 'ourstash'
860
861 C<is_our> indicates that the name to check is an C<"our"> declaration.
862
863 =cut
864 */
865
866 STATIC void
867 S_pad_check_dup(pTHX_ PADNAME *name, U32 flags, const HV *ourstash)
868 {
869     PADNAME     **svp;
870     PADOFFSET   top, off;
871     const U32   is_our = flags & padadd_OUR;
872
873     PERL_ARGS_ASSERT_PAD_CHECK_DUP;
874
875     ASSERT_CURPAD_ACTIVE("pad_check_dup");
876
877     assert((flags & ~padadd_OUR) == 0);
878
879     if (PadnamelistMAX(PL_comppad_name) < 0 || !ckWARN(WARN_MISC))
880         return; /* nothing to check */
881
882     svp = PadnamelistARRAY(PL_comppad_name);
883     top = PadnamelistMAX(PL_comppad_name);
884     /* check the current scope */
885     /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
886      * type ? */
887     for (off = top; (I32)off > PL_comppad_name_floor; off--) {
888         PADNAME * const sv = svp[off];
889         if (sv
890             && PadnameLEN(sv) == PadnameLEN(name)
891             && !PadnameOUTER(sv)
892             && (   COP_SEQ_RANGE_LOW(sv)  == PERL_PADSEQ_INTRO
893                 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
894             && memEQ(PadnamePV(sv), PadnamePV(name), PadnameLEN(name)))
895         {
896             if (is_our && (SvPAD_OUR(sv)))
897                 break; /* "our" masking "our" */
898             /* diag_listed_as: "%s" variable %s masks earlier declaration in same %s */
899             Perl_warner(aTHX_ packWARN(WARN_MISC),
900                 "\"%s\" %s %"PNf" masks earlier declaration in same %s",
901                 (is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"),
902                 *PadnamePV(sv) == '&' ? "subroutine" : "variable",
903                 PNfARG(sv),
904                 (COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO
905                     ? "scope" : "statement"));
906             --off;
907             break;
908         }
909     }
910     /* check the rest of the pad */
911     if (is_our) {
912         while (off > 0) {
913             PADNAME * const sv = svp[off];
914             if (sv
915                 && PadnameLEN(sv) == PadnameLEN(name)
916                 && !PadnameOUTER(sv)
917                 && (   COP_SEQ_RANGE_LOW(sv)  == PERL_PADSEQ_INTRO
918                     || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
919                 && SvOURSTASH(sv) == ourstash
920                 && memEQ(PadnamePV(sv), PadnamePV(name), PadnameLEN(name)))
921             {
922                 Perl_warner(aTHX_ packWARN(WARN_MISC),
923                     "\"our\" variable %"PNf" redeclared", PNfARG(sv));
924                 if ((I32)off <= PL_comppad_name_floor)
925                     Perl_warner(aTHX_ packWARN(WARN_MISC),
926                         "\t(Did you mean \"local\" instead of \"our\"?)\n");
927                 break;
928             }
929             --off;
930         }
931     }
932 }
933
934
935 /*
936 =for apidoc Am|PADOFFSET|pad_findmy_pvn|const char *namepv|STRLEN namelen|U32 flags
937
938 Given the name of a lexical variable, find its position in the
939 currently-compiling pad.
940 C<namepv>/C<namelen> specify the variable's name, including leading sigil.
941 C<flags> is reserved and must be zero.
942 If it is not in the current pad but appears in the pad of any lexically
943 enclosing scope, then a pseudo-entry for it is added in the current pad.
944 Returns the offset in the current pad,
945 or C<NOT_IN_PAD> if no such lexical is in scope.
946
947 =cut
948 */
949
950 PADOFFSET
951 Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags)
952 {
953     PADNAME *out_pn;
954     int out_flags;
955     I32 offset;
956     const PADNAMELIST *namelist;
957     PADNAME **name_p;
958
959     PERL_ARGS_ASSERT_PAD_FINDMY_PVN;
960
961     pad_peg("pad_findmy_pvn");
962
963     if (flags)
964         Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf,
965                    (UV)flags);
966
967     /* compilation errors can zero PL_compcv */
968     if (!PL_compcv)
969         return NOT_IN_PAD;
970
971     offset = pad_findlex(namepv, namelen, flags,
972                 PL_compcv, PL_cop_seqmax, 1, NULL, &out_pn, &out_flags);
973     if ((PADOFFSET)offset != NOT_IN_PAD) 
974         return offset;
975
976     /* Skip the ‘our’ hack for subroutines, as the warning does not apply.
977      */
978     if (*namepv == '&') return NOT_IN_PAD;
979
980     /* look for an our that's being introduced; this allows
981      *    our $foo = 0 unless defined $foo;
982      * to not give a warning. (Yes, this is a hack) */
983
984     namelist = PadlistNAMES(CvPADLIST(PL_compcv));
985     name_p = PadnamelistARRAY(namelist);
986     for (offset = PadnamelistMAXNAMED(namelist); offset > 0; offset--) {
987         const PADNAME * const name = name_p[offset];
988         if (name && PadnameLEN(name) == namelen
989             && !PadnameOUTER(name)
990             && (PadnameIsOUR(name))
991             && (  PadnamePV(name) == namepv
992                || memEQ(PadnamePV(name), namepv, namelen)  )
993             && COP_SEQ_RANGE_LOW(name) == PERL_PADSEQ_INTRO
994         )
995             return offset;
996     }
997     return NOT_IN_PAD;
998 }
999
1000 /*
1001 =for apidoc Am|PADOFFSET|pad_findmy_pv|const char *name|U32 flags
1002
1003 Exactly like L</pad_findmy_pvn>, but takes a nul-terminated string
1004 instead of a string/length pair.
1005
1006 =cut
1007 */
1008
1009 PADOFFSET
1010 Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags)
1011 {
1012     PERL_ARGS_ASSERT_PAD_FINDMY_PV;
1013     return pad_findmy_pvn(name, strlen(name), flags);
1014 }
1015
1016 /*
1017 =for apidoc Am|PADOFFSET|pad_findmy_sv|SV *name|U32 flags
1018
1019 Exactly like L</pad_findmy_pvn>, but takes the name string in the form
1020 of an SV instead of a string/length pair.
1021
1022 =cut
1023 */
1024
1025 PADOFFSET
1026 Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags)
1027 {
1028     char *namepv;
1029     STRLEN namelen;
1030     PERL_ARGS_ASSERT_PAD_FINDMY_SV;
1031     namepv = SvPVutf8(name, namelen);
1032     return pad_findmy_pvn(namepv, namelen, flags);
1033 }
1034
1035 /*
1036 =for apidoc Amp|PADOFFSET|find_rundefsvoffset
1037
1038 Until the lexical C<$_> feature was removed, this function would
1039 find the position of the lexical C<$_> in the pad of the
1040 currently-executing function and returns the offset in the current pad,
1041 or C<NOT_IN_PAD>.
1042
1043 Now it always returns C<NOT_IN_PAD>.
1044
1045 =cut
1046 */
1047
1048 PADOFFSET
1049 Perl_find_rundefsvoffset(pTHX)
1050 {
1051     PERL_UNUSED_CONTEXT; /* Can we just remove the pTHX from the sig? */
1052     return NOT_IN_PAD;
1053 }
1054
1055 /*
1056 =for apidoc Am|SV *|find_rundefsv
1057
1058 Returns the global variable C<$_>.
1059
1060 =cut
1061 */
1062
1063 SV *
1064 Perl_find_rundefsv(pTHX)
1065 {
1066     return DEFSV;
1067 }
1068
1069 /*
1070 =for apidoc m|PADOFFSET|pad_findlex|const char *namepv|STRLEN namelen|U32 flags|const CV* cv|U32 seq|int warn|SV** out_capture|PADNAME** out_name|int *out_flags
1071
1072 Find a named lexical anywhere in a chain of nested pads.  Add fake entries
1073 in the inner pads if it's found in an outer one.
1074
1075 Returns the offset in the bottom pad of the lex or the fake lex.
1076 C<cv> is the CV in which to start the search, and seq is the current C<cop_seq>
1077 to match against.  If C<warn> is true, print appropriate warnings.  The C<out_>*
1078 vars return values, and so are pointers to where the returned values
1079 should be stored.  C<out_capture>, if non-null, requests that the innermost
1080 instance of the lexical is captured; C<out_name> is set to the innermost
1081 matched pad name or fake pad name; C<out_flags> returns the flags normally
1082 associated with the C<PARENT_FAKELEX_FLAGS> field of a fake pad name.
1083
1084 Note that C<pad_findlex()> is recursive; it recurses up the chain of CVs,
1085 then comes back down, adding fake entries
1086 as it goes.  It has to be this way
1087 because fake names in anon protoypes have to store in C<xlow> the index into
1088 the parent pad.
1089
1090 =cut
1091 */
1092
1093 /* the CV has finished being compiled. This is not a sufficient test for
1094  * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
1095 #define CvCOMPILED(cv)  CvROOT(cv)
1096
1097 /* the CV does late binding of its lexicals */
1098 #define CvLATE(cv) (CvANON(cv) || CvCLONE(cv) || SvTYPE(cv) == SVt_PVFM)
1099
1100 static void
1101 S_unavailable(pTHX_ PADNAME *name)
1102 {
1103     /* diag_listed_as: Variable "%s" is not available */
1104     Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1105                         "%se \"%"PNf"\" is not available",
1106                          *PadnamePV(name) == '&'
1107                                          ? "Subroutin"
1108                                          : "Variabl",
1109                          PNfARG(name));
1110 }
1111
1112 STATIC PADOFFSET
1113 S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq,
1114         int warn, SV** out_capture, PADNAME** out_name, int *out_flags)
1115 {
1116     I32 offset, new_offset;
1117     SV *new_capture;
1118     SV **new_capturep;
1119     const PADLIST * const padlist = CvPADLIST(cv);
1120     const bool staleok = !!(flags & padadd_STALEOK);
1121
1122     PERL_ARGS_ASSERT_PAD_FINDLEX;
1123
1124     flags &= ~ padadd_STALEOK; /* one-shot flag */
1125     if (flags)
1126         Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf,
1127                    (UV)flags);
1128
1129     *out_flags = 0;
1130
1131     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1132         "Pad findlex cv=0x%"UVxf" searching \"%.*s\" seq=%d%s\n",
1133                            PTR2UV(cv), (int)namelen, namepv, (int)seq,
1134         out_capture ? " capturing" : "" ));
1135
1136     /* first, search this pad */
1137
1138     if (padlist) { /* not an undef CV */
1139         I32 fake_offset = 0;
1140         const PADNAMELIST * const names = PadlistNAMES(padlist);
1141         PADNAME * const * const name_p = PadnamelistARRAY(names);
1142
1143         for (offset = PadnamelistMAXNAMED(names); offset > 0; offset--) {
1144             const PADNAME * const name = name_p[offset];
1145             if (name && PadnameLEN(name) == namelen
1146                      && (  PadnamePV(name) == namepv
1147                         || memEQ(PadnamePV(name), namepv, namelen)  ))
1148             {
1149                 if (PadnameOUTER(name)) {
1150                     fake_offset = offset; /* in case we don't find a real one */
1151                     continue;
1152                 }
1153                 if (PadnameIN_SCOPE(name, seq))
1154                     break;
1155             }
1156         }
1157
1158         if (offset > 0 || fake_offset > 0 ) { /* a match! */
1159             if (offset > 0) { /* not fake */
1160                 fake_offset = 0;
1161                 *out_name = name_p[offset]; /* return the name */
1162
1163                 /* set PAD_FAKELEX_MULTI if this lex can have multiple
1164                  * instances. For now, we just test !CvUNIQUE(cv), but
1165                  * ideally, we should detect my's declared within loops
1166                  * etc - this would allow a wider range of 'not stayed
1167                  * shared' warnings. We also treated already-compiled
1168                  * lexes as not multi as viewed from evals. */
1169
1170                 *out_flags = CvANON(cv) ?
1171                         PAD_FAKELEX_ANON :
1172                             (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
1173                                 ? PAD_FAKELEX_MULTI : 0;
1174
1175                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1176                     "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n",
1177                     PTR2UV(cv), (long)offset,
1178                     (unsigned long)COP_SEQ_RANGE_LOW(*out_name),
1179                     (unsigned long)COP_SEQ_RANGE_HIGH(*out_name)));
1180             }
1181             else { /* fake match */
1182                 offset = fake_offset;
1183                 *out_name = name_p[offset]; /* return the name */
1184                 *out_flags = PARENT_FAKELEX_FLAGS(*out_name);
1185                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1186                     "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
1187                     PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
1188                     (unsigned long) PARENT_PAD_INDEX(*out_name) 
1189                 ));
1190             }
1191
1192             /* return the lex? */
1193
1194             if (out_capture) {
1195
1196                 /* our ? */
1197                 if (PadnameIsOUR(*out_name)) {
1198                     *out_capture = NULL;
1199                     return offset;
1200                 }
1201
1202                 /* trying to capture from an anon prototype? */
1203                 if (CvCOMPILED(cv)
1204                         ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
1205                         : *out_flags & PAD_FAKELEX_ANON)
1206                 {
1207                     if (warn)
1208                         S_unavailable(aTHX_
1209                                       *out_name);
1210
1211                     *out_capture = NULL;
1212                 }
1213
1214                 /* real value */
1215                 else {
1216                     int newwarn = warn;
1217                     if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
1218                          && !PadnameIsSTATE(name_p[offset])
1219                          && warn && ckWARN(WARN_CLOSURE)) {
1220                         newwarn = 0;
1221                         /* diag_listed_as: Variable "%s" will not stay
1222                                            shared */
1223                         Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
1224                             "%se \"%"UTF8f"\" will not stay shared",
1225                              *namepv == '&' ? "Subroutin" : "Variabl",
1226                              UTF8fARG(1, namelen, namepv));
1227                     }
1228
1229                     if (fake_offset && CvANON(cv)
1230                             && CvCLONE(cv) &&!CvCLONED(cv))
1231                     {
1232                         PADNAME *n;
1233                         /* not yet caught - look further up */
1234                         DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1235                             "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
1236                             PTR2UV(cv)));
1237                         n = *out_name;
1238                         (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv),
1239                             CvOUTSIDE_SEQ(cv),
1240                             newwarn, out_capture, out_name, out_flags);
1241                         *out_name = n;
1242                         return offset;
1243                     }
1244
1245                     *out_capture = AvARRAY(PadlistARRAY(padlist)[
1246                                     CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset];
1247                     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1248                         "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
1249                         PTR2UV(cv), PTR2UV(*out_capture)));
1250
1251                     if (SvPADSTALE(*out_capture)
1252                         && (!CvDEPTH(cv) || !staleok)
1253                         && !PadnameIsSTATE(name_p[offset]))
1254                     {
1255                         S_unavailable(aTHX_
1256                                       name_p[offset]);
1257                         *out_capture = NULL;
1258                     }
1259                 }
1260                 if (!*out_capture) {
1261                     if (namelen != 0 && *namepv == '@')
1262                         *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
1263                     else if (namelen != 0 && *namepv == '%')
1264                         *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
1265                     else if (namelen != 0 && *namepv == '&')
1266                         *out_capture = sv_2mortal(newSV_type(SVt_PVCV));
1267                     else
1268                         *out_capture = sv_newmortal();
1269                 }
1270             }
1271
1272             return offset;
1273         }
1274     }
1275
1276     /* it's not in this pad - try above */
1277
1278     if (!CvOUTSIDE(cv))
1279         return NOT_IN_PAD;
1280
1281     /* out_capture non-null means caller wants us to capture lex; in
1282      * addition we capture ourselves unless it's an ANON/format */
1283     new_capturep = out_capture ? out_capture :
1284                 CvLATE(cv) ? NULL : &new_capture;
1285
1286     offset = pad_findlex(namepv, namelen,
1287                 flags | padadd_STALEOK*(new_capturep == &new_capture),
1288                 CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
1289                 new_capturep, out_name, out_flags);
1290     if ((PADOFFSET)offset == NOT_IN_PAD)
1291         return NOT_IN_PAD;
1292
1293     /* found in an outer CV. Add appropriate fake entry to this pad */
1294
1295     /* don't add new fake entries (via eval) to CVs that we have already
1296      * finished compiling, or to undef CVs */
1297     if (CvCOMPILED(cv) || !padlist)
1298         return 0; /* this dummy (and invalid) value isnt used by the caller */
1299
1300     {
1301         PADNAME *new_name = newPADNAMEouter(*out_name);
1302         PADNAMELIST * const ocomppad_name = PL_comppad_name;
1303         PAD * const ocomppad = PL_comppad;
1304         PL_comppad_name = PadlistNAMES(padlist);
1305         PL_comppad = PadlistARRAY(padlist)[1];
1306         PL_curpad = AvARRAY(PL_comppad);
1307
1308         new_offset
1309             = pad_alloc_name(new_name,
1310                               PadnameIsSTATE(*out_name) ? padadd_STATE : 0,
1311                               PadnameTYPE(*out_name),
1312                               PadnameOURSTASH(*out_name)
1313                               );
1314
1315         DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1316                                "Pad addname: %ld \"%.*s\" FAKE\n",
1317                                (long)new_offset,
1318                                (int) PadnameLEN(new_name),
1319                                PadnamePV(new_name)));
1320         PARENT_FAKELEX_FLAGS_set(new_name, *out_flags);
1321
1322         PARENT_PAD_INDEX_set(new_name, 0);
1323         if (PadnameIsOUR(new_name)) {
1324             NOOP;   /* do nothing */
1325         }
1326         else if (CvLATE(cv)) {
1327             /* delayed creation - just note the offset within parent pad */
1328             PARENT_PAD_INDEX_set(new_name, offset);
1329             CvCLONE_on(cv);
1330         }
1331         else {
1332             /* immediate creation - capture outer value right now */
1333             av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
1334             /* But also note the offset, as newMYSUB needs it */
1335             PARENT_PAD_INDEX_set(new_name, offset);
1336             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1337                 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
1338                 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
1339         }
1340         *out_name = new_name;
1341         *out_flags = PARENT_FAKELEX_FLAGS(new_name);
1342
1343         PL_comppad_name = ocomppad_name;
1344         PL_comppad = ocomppad;
1345         PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
1346     }
1347     return new_offset;
1348 }
1349
1350 #ifdef DEBUGGING
1351
1352 /*
1353 =for apidoc Am|SV *|pad_sv|PADOFFSET po
1354
1355 Get the value at offset C<po> in the current (compiling or executing) pad.
1356 Use macro C<PAD_SV> instead of calling this function directly.
1357
1358 =cut
1359 */
1360
1361 SV *
1362 Perl_pad_sv(pTHX_ PADOFFSET po)
1363 {
1364     ASSERT_CURPAD_ACTIVE("pad_sv");
1365
1366     if (!po)
1367         Perl_croak(aTHX_ "panic: pad_sv po");
1368     DEBUG_X(PerlIO_printf(Perl_debug_log,
1369         "Pad 0x%"UVxf"[0x%"UVxf"] sv:      %ld sv=0x%"UVxf"\n",
1370         PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
1371     );
1372     return PL_curpad[po];
1373 }
1374
1375 /*
1376 =for apidoc Am|void|pad_setsv|PADOFFSET po|SV *sv
1377
1378 Set the value at offset C<po> in the current (compiling or executing) pad.
1379 Use the macro C<PAD_SETSV()> rather than calling this function directly.
1380
1381 =cut
1382 */
1383
1384 void
1385 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
1386 {
1387     PERL_ARGS_ASSERT_PAD_SETSV;
1388
1389     ASSERT_CURPAD_ACTIVE("pad_setsv");
1390
1391     DEBUG_X(PerlIO_printf(Perl_debug_log,
1392         "Pad 0x%"UVxf"[0x%"UVxf"] setsv:   %ld sv=0x%"UVxf"\n",
1393         PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
1394     );
1395     PL_curpad[po] = sv;
1396 }
1397
1398 #endif /* DEBUGGING */
1399
1400 /*
1401 =for apidoc m|void|pad_block_start|int full
1402
1403 Update the pad compilation state variables on entry to a new block.
1404
1405 =cut
1406 */
1407
1408 /* XXX DAPM perhaps:
1409  *      - integrate this in general state-saving routine ???
1410  *      - combine with the state-saving going on in pad_new ???
1411  *      - introduce a new SAVE type that does all this in one go ?
1412  */
1413
1414 void
1415 Perl_pad_block_start(pTHX_ int full)
1416 {
1417     ASSERT_CURPAD_ACTIVE("pad_block_start");
1418     SAVEI32(PL_comppad_name_floor);
1419     PL_comppad_name_floor = PadnamelistMAX(PL_comppad_name);
1420     if (full)
1421         PL_comppad_name_fill = PL_comppad_name_floor;
1422     if (PL_comppad_name_floor < 0)
1423         PL_comppad_name_floor = 0;
1424     SAVEI32(PL_min_intro_pending);
1425     SAVEI32(PL_max_intro_pending);
1426     PL_min_intro_pending = 0;
1427     SAVEI32(PL_comppad_name_fill);
1428     SAVEI32(PL_padix_floor);
1429     /* PL_padix_floor is what PL_padix is reset to at the start of each
1430        statement, by pad_reset().  We set it when entering a new scope
1431        to keep things like this working:
1432             print "$foo$bar", do { this(); that() . "foo" };
1433        We must not let "$foo$bar" and the later concatenation share the
1434        same target.  */
1435     PL_padix_floor = PL_padix;
1436     PL_pad_reset_pending = FALSE;
1437 }
1438
1439 /*
1440 =for apidoc Am|U32|intro_my
1441
1442 "Introduce" C<my> variables to visible status.  This is called during parsing
1443 at the end of each statement to make lexical variables visible to subsequent
1444 statements.
1445
1446 =cut
1447 */
1448
1449 U32
1450 Perl_intro_my(pTHX)
1451 {
1452     PADNAME **svp;
1453     I32 i;
1454     U32 seq;
1455
1456     ASSERT_CURPAD_ACTIVE("intro_my");
1457     if (PL_compiling.cop_seq) {
1458         seq = PL_compiling.cop_seq;
1459         PL_compiling.cop_seq = 0;
1460     }
1461     else
1462         seq = PL_cop_seqmax;
1463     if (! PL_min_intro_pending)
1464         return seq;
1465
1466     svp = PadnamelistARRAY(PL_comppad_name);
1467     for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1468         PADNAME * const sv = svp[i];
1469
1470         if (sv && PadnameLEN(sv) && !PadnameOUTER(sv)
1471             && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
1472         {
1473             COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
1474             COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
1475             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1476                 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1477                 (long)i, PadnamePV(sv),
1478                 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1479                 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1480             );
1481         }
1482     }
1483     COP_SEQMAX_INC;
1484     PL_min_intro_pending = 0;
1485     PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1486     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1487                 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));
1488
1489     return seq;
1490 }
1491
1492 /*
1493 =for apidoc m|void|pad_leavemy
1494
1495 Cleanup at end of scope during compilation: set the max seq number for
1496 lexicals in this scope and warn of any lexicals that never got introduced.
1497
1498 =cut
1499 */
1500
1501 OP *
1502 Perl_pad_leavemy(pTHX)
1503 {
1504     I32 off;
1505     OP *o = NULL;
1506     PADNAME * const * const svp = PadnamelistARRAY(PL_comppad_name);
1507
1508     PL_pad_reset_pending = FALSE;
1509
1510     ASSERT_CURPAD_ACTIVE("pad_leavemy");
1511     if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1512         for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1513             const PADNAME * const name = svp[off];
1514             if (name && PadnameLEN(name) && !PadnameOUTER(name))
1515                 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1516                                       "%"PNf" never introduced",
1517                                        PNfARG(name));
1518         }
1519     }
1520     /* "Deintroduce" my variables that are leaving with this scope. */
1521     for (off = PadnamelistMAX(PL_comppad_name);
1522          off > PL_comppad_name_fill; off--) {
1523         PADNAME * const sv = svp[off];
1524         if (sv && PadnameLEN(sv) && !PadnameOUTER(sv)
1525             && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
1526         {
1527             COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
1528             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1529                 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1530                 (long)off, PadnamePV(sv),
1531                 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1532                 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1533             );
1534             if (!PadnameIsSTATE(sv) && !PadnameIsOUR(sv)
1535              && *PadnamePV(sv) == '&' && PadnameLEN(sv) > 1) {
1536                 OP *kid = newOP(OP_INTROCV, 0);
1537                 kid->op_targ = off;
1538                 o = op_prepend_elem(OP_LINESEQ, kid, o);
1539             }
1540         }
1541     }
1542     COP_SEQMAX_INC;
1543     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1544             "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1545     return o;
1546 }
1547
1548 /*
1549 =for apidoc m|void|pad_swipe|PADOFFSET po|bool refadjust
1550
1551 Abandon the tmp in the current pad at offset C<po> and replace with a
1552 new one.
1553
1554 =cut
1555 */
1556
1557 void
1558 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1559 {
1560     ASSERT_CURPAD_LEGAL("pad_swipe");
1561     if (!PL_curpad)
1562         return;
1563     if (AvARRAY(PL_comppad) != PL_curpad)
1564         Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
1565                    AvARRAY(PL_comppad), PL_curpad);
1566     if (!po || ((SSize_t)po) > AvFILLp(PL_comppad))
1567         Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld",
1568                    (long)po, (long)AvFILLp(PL_comppad));
1569
1570     DEBUG_X(PerlIO_printf(Perl_debug_log,
1571                 "Pad 0x%"UVxf"[0x%"UVxf"] swipe:   %ld\n",
1572                 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1573
1574     if (refadjust)
1575         SvREFCNT_dec(PL_curpad[po]);
1576
1577
1578     /* if pad tmps aren't shared between ops, then there's no need to
1579      * create a new tmp when an existing op is freed */
1580 #ifdef USE_PAD_RESET
1581     PL_curpad[po] = newSV(0);
1582     SvPADTMP_on(PL_curpad[po]);
1583 #else
1584     PL_curpad[po] = NULL;
1585 #endif
1586     if (PadnamelistMAX(PL_comppad_name) != -1
1587      && (PADOFFSET)PadnamelistMAX(PL_comppad_name) >= po) {
1588         if (PadnamelistARRAY(PL_comppad_name)[po]) {
1589             assert(!PadnameLEN(PadnamelistARRAY(PL_comppad_name)[po]));
1590         }
1591         PadnamelistARRAY(PL_comppad_name)[po] = &PL_padname_undef;
1592     }
1593     /* Use PL_constpadix here, not PL_padix.  The latter may have been
1594        reset by pad_reset.  We don’t want pad_alloc to have to scan the
1595        whole pad when allocating a constant. */
1596     if ((I32)po < PL_constpadix)
1597         PL_constpadix = po - 1;
1598 }
1599
1600 /*
1601 =for apidoc m|void|pad_reset
1602
1603 Mark all the current temporaries for reuse
1604
1605 =cut
1606 */
1607
1608 /* pad_reset() causes pad temp TARGs (operator targets) to be shared
1609  * between OPs from different statements.  During compilation, at the start
1610  * of each statement pad_reset resets PL_padix back to its previous value.
1611  * When allocating a target, pad_alloc begins its scan through the pad at
1612  * PL_padix+1.  */
1613 static void
1614 S_pad_reset(pTHX)
1615 {
1616 #ifdef USE_PAD_RESET
1617     if (AvARRAY(PL_comppad) != PL_curpad)
1618         Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
1619                    AvARRAY(PL_comppad), PL_curpad);
1620
1621     DEBUG_X(PerlIO_printf(Perl_debug_log,
1622             "Pad 0x%"UVxf"[0x%"UVxf"] reset:     padix %ld -> %ld",
1623             PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1624                 (long)PL_padix, (long)PL_padix_floor
1625             )
1626     );
1627
1628     if (!TAINTING_get) {        /* Can't mix tainted and non-tainted temporaries. */
1629         PL_padix = PL_padix_floor;
1630     }
1631 #endif
1632     PL_pad_reset_pending = FALSE;
1633 }
1634
1635 /*
1636 =for apidoc Amx|void|pad_tidy|padtidy_type type
1637
1638 Tidy up a pad at the end of compilation of the code to which it belongs.
1639 Jobs performed here are: remove most stuff from the pads of anonsub
1640 prototypes; give it a C<@_>; mark temporaries as such.  C<type> indicates
1641 the kind of subroutine:
1642
1643     padtidy_SUB        ordinary subroutine
1644     padtidy_SUBCLONE   prototype for lexical closure
1645     padtidy_FORMAT     format
1646
1647 =cut
1648 */
1649
1650 /* XXX DAPM surely most of this stuff should be done properly
1651  * at the right time beforehand, rather than going around afterwards
1652  * cleaning up our mistakes ???
1653  */
1654
1655 void
1656 Perl_pad_tidy(pTHX_ padtidy_type type)
1657 {
1658     dVAR;
1659
1660     ASSERT_CURPAD_ACTIVE("pad_tidy");
1661
1662     /* If this CV has had any 'eval-capable' ops planted in it:
1663      * i.e. it contains any of:
1664      *
1665      *     * eval '...',
1666      *     * //ee,
1667      *     * use re 'eval'; /$var/
1668      *     * /(?{..})/),
1669      *
1670      * Then any anon prototypes in the chain of CVs should be marked as
1671      * cloneable, so that for example the eval's CV in
1672      *
1673      *    sub { eval '$x' }
1674      *
1675      * gets the right CvOUTSIDE.  If running with -d, *any* sub may
1676      * potentially have an eval executed within it.
1677      */
1678
1679     if (PL_cv_has_eval || PL_perldb) {
1680         const CV *cv;
1681         for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1682             if (cv != PL_compcv && CvCOMPILED(cv))
1683                 break; /* no need to mark already-compiled code */
1684             if (CvANON(cv)) {
1685                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1686                     "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1687                 CvCLONE_on(cv);
1688             }
1689             CvHASEVAL_on(cv);
1690         }
1691     }
1692
1693     /* extend namepad to match curpad */
1694     if (PadnamelistMAX(PL_comppad_name) < AvFILLp(PL_comppad))
1695         padnamelist_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1696
1697     if (type == padtidy_SUBCLONE) {
1698         PADNAME ** const namep = PadnamelistARRAY(PL_comppad_name);
1699         PADOFFSET ix;
1700
1701         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1702             PADNAME *namesv;
1703             if (!namep[ix]) namep[ix] = &PL_padname_undef;
1704
1705             /*
1706              * The only things that a clonable function needs in its
1707              * pad are anonymous subs, constants and GVs.
1708              * The rest are created anew during cloning.
1709              */
1710             if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]))
1711                 continue;
1712             namesv = namep[ix];
1713             if (!(PadnamePV(namesv) &&
1714                    (!PadnameLEN(namesv) || *PadnamePV(namesv) == '&')))
1715             {
1716                 SvREFCNT_dec(PL_curpad[ix]);
1717                 PL_curpad[ix] = NULL;
1718             }
1719         }
1720     }
1721     else if (type == padtidy_SUB) {
1722         /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1723         AV * const av = newAV();                        /* Will be @_ */
1724         av_store(PL_comppad, 0, MUTABLE_SV(av));
1725         AvREIFY_only(av);
1726     }
1727
1728     if (type == padtidy_SUB || type == padtidy_FORMAT) {
1729         PADNAME ** const namep = PadnamelistARRAY(PL_comppad_name);
1730         PADOFFSET ix;
1731         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1732             if (!namep[ix]) namep[ix] = &PL_padname_undef;
1733             if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]))
1734                 continue;
1735             if (SvPADMY(PL_curpad[ix]) && !PadnameOUTER(namep[ix])) {
1736                 /* This is a work around for how the current implementation of
1737                    ?{ } blocks in regexps interacts with lexicals.
1738
1739                    One of our lexicals.
1740                    Can't do this on all lexicals, otherwise sub baz() won't
1741                    compile in
1742
1743                    my $foo;
1744
1745                    sub bar { ++$foo; }
1746
1747                    sub baz { ++$foo; }
1748
1749                    because completion of compiling &bar calling pad_tidy()
1750                    would cause (top level) $foo to be marked as stale, and
1751                    "no longer available".  */
1752                 SvPADSTALE_on(PL_curpad[ix]);
1753             }
1754         }
1755     }
1756     PL_curpad = AvARRAY(PL_comppad);
1757 }
1758
1759 /*
1760 =for apidoc m|void|pad_free|PADOFFSET po
1761
1762 Free the SV at offset po in the current pad.
1763
1764 =cut
1765 */
1766
1767 /* XXX DAPM integrate with pad_swipe ???? */
1768 void
1769 Perl_pad_free(pTHX_ PADOFFSET po)
1770 {
1771 #ifndef USE_PAD_RESET
1772     SV *sv;
1773 #endif
1774     ASSERT_CURPAD_LEGAL("pad_free");
1775     if (!PL_curpad)
1776         return;
1777     if (AvARRAY(PL_comppad) != PL_curpad)
1778         Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
1779                    AvARRAY(PL_comppad), PL_curpad);
1780     if (!po)
1781         Perl_croak(aTHX_ "panic: pad_free po");
1782
1783     DEBUG_X(PerlIO_printf(Perl_debug_log,
1784             "Pad 0x%"UVxf"[0x%"UVxf"] free:    %ld\n",
1785             PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1786     );
1787
1788 #ifndef USE_PAD_RESET
1789     sv = PL_curpad[po];
1790     if (sv && sv != &PL_sv_undef && !SvPADMY(sv))
1791         SvFLAGS(sv) &= ~SVs_PADTMP;
1792
1793     if ((I32)po < PL_padix)
1794         PL_padix = po - 1;
1795 #endif
1796 }
1797
1798 /*
1799 =for apidoc m|void|do_dump_pad|I32 level|PerlIO *file|PADLIST *padlist|int full
1800
1801 Dump the contents of a padlist
1802
1803 =cut
1804 */
1805
1806 void
1807 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1808 {
1809     const PADNAMELIST *pad_name;
1810     const AV *pad;
1811     PADNAME **pname;
1812     SV **ppad;
1813     I32 ix;
1814
1815     PERL_ARGS_ASSERT_DO_DUMP_PAD;
1816
1817     if (!padlist) {
1818         return;
1819     }
1820     pad_name = PadlistNAMES(padlist);
1821     pad = PadlistARRAY(padlist)[1];
1822     pname = PadnamelistARRAY(pad_name);
1823     ppad = AvARRAY(pad);
1824     Perl_dump_indent(aTHX_ level, file,
1825             "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1826             PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1827     );
1828
1829     for (ix = 1; ix <= PadnamelistMAX(pad_name); ix++) {
1830         const PADNAME *namesv = pname[ix];
1831         if (namesv && !PadnameLEN(namesv)) {
1832             namesv = NULL;
1833         }
1834         if (namesv) {
1835             if (PadnameOUTER(namesv))
1836                 Perl_dump_indent(aTHX_ level+1, file,
1837                     "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1838                     (int) ix,
1839                     PTR2UV(ppad[ix]),
1840                     (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1841                     PadnamePV(namesv),
1842                     (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1843                     (unsigned long)PARENT_PAD_INDEX(namesv)
1844
1845                 );
1846             else
1847                 Perl_dump_indent(aTHX_ level+1, file,
1848                     "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
1849                     (int) ix,
1850                     PTR2UV(ppad[ix]),
1851                     (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1852                     (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1853                     (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1854                     PadnamePV(namesv)
1855                 );
1856         }
1857         else if (full) {
1858             Perl_dump_indent(aTHX_ level+1, file,
1859                 "%2d. 0x%"UVxf"<%lu>\n",
1860                 (int) ix,
1861                 PTR2UV(ppad[ix]),
1862                 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1863             );
1864         }
1865     }
1866 }
1867
1868 #ifdef DEBUGGING
1869
1870 /*
1871 =for apidoc m|void|cv_dump|CV *cv|const char *title
1872
1873 dump the contents of a CV
1874
1875 =cut
1876 */
1877
1878 STATIC void
1879 S_cv_dump(pTHX_ const CV *cv, const char *title)
1880 {
1881     const CV * const outside = CvOUTSIDE(cv);
1882     PADLIST* const padlist = CvPADLIST(cv);
1883
1884     PERL_ARGS_ASSERT_CV_DUMP;
1885
1886     PerlIO_printf(Perl_debug_log,
1887                   "  %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1888                   title,
1889                   PTR2UV(cv),
1890                   (CvANON(cv) ? "ANON"
1891                    : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1892                    : (cv == PL_main_cv) ? "MAIN"
1893                    : CvUNIQUE(cv) ? "UNIQUE"
1894                    : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1895                   PTR2UV(outside),
1896                   (!outside ? "null"
1897                    : CvANON(outside) ? "ANON"
1898                    : (outside == PL_main_cv) ? "MAIN"
1899                    : CvUNIQUE(outside) ? "UNIQUE"
1900                    : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1901
1902     PerlIO_printf(Perl_debug_log,
1903                     "    PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1904     do_dump_pad(1, Perl_debug_log, padlist, 1);
1905 }
1906
1907 #endif /* DEBUGGING */
1908
1909 /*
1910 =for apidoc Am|CV *|cv_clone|CV *proto
1911
1912 Clone a CV, making a lexical closure.  C<proto> supplies the prototype
1913 of the function: its code, pad structure, and other attributes.
1914 The prototype is combined with a capture of outer lexicals to which the
1915 code refers, which are taken from the currently-executing instance of
1916 the immediately surrounding code.
1917
1918 =cut
1919 */
1920
1921 static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned);
1922
1923 static CV *
1924 S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned,
1925                      bool newcv)
1926 {
1927     I32 ix;
1928     PADLIST* const protopadlist = CvPADLIST(proto);
1929     PADNAMELIST *const protopad_name = PadlistNAMES(protopadlist);
1930     const PAD *const protopad = PadlistARRAY(protopadlist)[1];
1931     PADNAME** const pname = PadnamelistARRAY(protopad_name);
1932     SV** const ppad = AvARRAY(protopad);
1933     const I32 fname = PadnamelistMAX(protopad_name);
1934     const I32 fpad = AvFILLp(protopad);
1935     SV** outpad;
1936     long depth;
1937     U32 subclones = 0;
1938     bool trouble = FALSE;
1939
1940     assert(!CvUNIQUE(proto));
1941
1942     /* Anonymous subs have a weak CvOUTSIDE pointer, so its value is not
1943      * reliable.  The currently-running sub is always the one we need to
1944      * close over.
1945      * For my subs, the currently-running sub may not be the one we want.
1946      * We have to check whether it is a clone of CvOUTSIDE.
1947      * Note that in general for formats, CvOUTSIDE != find_runcv.
1948      * Since formats may be nested inside closures, CvOUTSIDE may point
1949      * to a prototype; we instead want the cloned parent who called us.
1950      */
1951
1952     if (!outside) {
1953       if (CvWEAKOUTSIDE(proto))
1954         outside = find_runcv(NULL);
1955       else {
1956         outside = CvOUTSIDE(proto);
1957         if ((CvCLONE(outside) && ! CvCLONED(outside))
1958             || !CvPADLIST(outside)
1959             || CvPADLIST(outside)->xpadl_id != protopadlist->xpadl_outid) {
1960             outside = find_runcv_where(
1961                 FIND_RUNCV_padid_eq, PTR2IV(protopadlist->xpadl_outid), NULL
1962             );
1963             /* outside could be null */
1964         }
1965       }
1966     }
1967     depth = outside ? CvDEPTH(outside) : 0;
1968     if (!depth)
1969         depth = 1;
1970
1971     ENTER;
1972     SAVESPTR(PL_compcv);
1973     PL_compcv = cv;
1974     if (newcv) SAVEFREESV(cv); /* in case of fatal warnings */
1975
1976     if (CvHASEVAL(cv))
1977         CvOUTSIDE(cv)   = MUTABLE_CV(SvREFCNT_inc_simple(outside));
1978
1979     SAVESPTR(PL_comppad_name);
1980     PL_comppad_name = protopad_name;
1981     CvPADLIST_set(cv, pad_new(padnew_CLONE|padnew_SAVE));
1982     CvPADLIST(cv)->xpadl_id = protopadlist->xpadl_id;
1983
1984     av_fill(PL_comppad, fpad);
1985
1986     PL_curpad = AvARRAY(PL_comppad);
1987
1988     outpad = outside && CvPADLIST(outside)
1989         ? AvARRAY(PadlistARRAY(CvPADLIST(outside))[depth])
1990         : NULL;
1991     if (outpad) CvPADLIST(cv)->xpadl_outid = CvPADLIST(outside)->xpadl_id;
1992
1993     for (ix = fpad; ix > 0; ix--) {
1994         PADNAME* const namesv = (ix <= fname) ? pname[ix] : NULL;
1995         SV *sv = NULL;
1996         if (namesv && PadnameLEN(namesv)) { /* lexical */
1997           if (PadnameIsOUR(namesv)) { /* or maybe not so lexical */
1998                 NOOP;
1999           }
2000           else {
2001             if (PadnameOUTER(namesv)) {   /* lexical from outside? */
2002                 /* formats may have an inactive, or even undefined, parent;
2003                    but state vars are always available. */
2004                 if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
2005                  || (  SvPADSTALE(sv) && !SvPAD_STATE(namesv)
2006                     && (!outside || !CvDEPTH(outside)))  ) {
2007                     S_unavailable(aTHX_ namesv);
2008                     sv = NULL;
2009                 }
2010                 else 
2011                     SvREFCNT_inc_simple_void_NN(sv);
2012             }
2013             if (!sv) {
2014                 const char sigil = PadnamePV(namesv)[0];
2015                 if (sigil == '&')
2016                     /* If there are state subs, we need to clone them, too.
2017                        But they may need to close over variables we have
2018                        not cloned yet.  So we will have to do a second
2019                        pass.  Furthermore, there may be state subs clos-
2020                        ing over other state subs’ entries, so we have
2021                        to put a stub here and then clone into it on the
2022                        second pass. */
2023                     if (SvPAD_STATE(namesv) && !CvCLONED(ppad[ix])) {
2024                         assert(SvTYPE(ppad[ix]) == SVt_PVCV);
2025                         subclones ++;
2026                         if (CvOUTSIDE(ppad[ix]) != proto)
2027                              trouble = TRUE;
2028                         sv = newSV_type(SVt_PVCV);
2029                         CvLEXICAL_on(sv);
2030                     }
2031                     else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv))
2032                     {
2033                         /* my sub */
2034                         /* Just provide a stub, but name it.  It will be
2035                            upgrade to the real thing on scope entry. */
2036                         dVAR;
2037                         U32 hash;
2038                         PERL_HASH(hash, PadnamePV(namesv)+1,
2039                                   PadnameLEN(namesv) - 1);
2040                         sv = newSV_type(SVt_PVCV);
2041                         CvNAME_HEK_set(
2042                             sv,
2043                             share_hek(PadnamePV(namesv)+1,
2044                                       1 - PadnameLEN(namesv),
2045                                       hash)
2046                         );
2047                         CvLEXICAL_on(sv);
2048                     }
2049                     else sv = SvREFCNT_inc(ppad[ix]);
2050                 else if (sigil == '@')
2051                     sv = MUTABLE_SV(newAV());
2052                 else if (sigil == '%')
2053                     sv = MUTABLE_SV(newHV());
2054                 else
2055                     sv = newSV(0);
2056                 /* reset the 'assign only once' flag on each state var */
2057                 if (sigil != '&' && SvPAD_STATE(namesv))
2058                     SvPADSTALE_on(sv);
2059             }
2060           }
2061         }
2062         else if (namesv && PadnamePV(namesv)) {
2063             sv = SvREFCNT_inc_NN(ppad[ix]);
2064         }
2065         else {
2066             sv = newSV(0);
2067             SvPADTMP_on(sv);
2068         }
2069         PL_curpad[ix] = sv;
2070     }
2071
2072     if (subclones)
2073     {
2074         if (trouble || cloned) {
2075             /* Uh-oh, we have trouble!  At least one of the state subs here
2076                has its CvOUTSIDE pointer pointing somewhere unexpected.  It
2077                could be pointing to another state protosub that we are
2078                about to clone.  So we have to track which sub clones come
2079                from which protosubs.  If the CvOUTSIDE pointer for a parti-
2080                cular sub points to something we have not cloned yet, we
2081                delay cloning it.  We must loop through the pad entries,
2082                until we get a full pass with no cloning.  If any uncloned
2083                subs remain (probably nested inside anonymous or ‘my’ subs),
2084                then they get cloned in a final pass.
2085              */
2086             bool cloned_in_this_pass;
2087             if (!cloned)
2088                 cloned = (HV *)sv_2mortal((SV *)newHV());
2089             do {
2090                 cloned_in_this_pass = FALSE;
2091                 for (ix = fpad; ix > 0; ix--) {
2092                     PADNAME * const name =
2093                         (ix <= fname) ? pname[ix] : NULL;
2094                     if (name && name != &PL_padname_undef
2095                      && !PadnameOUTER(name) && PadnamePV(name)[0] == '&'
2096                      && PadnameIsSTATE(name) && !CvCLONED(PL_curpad[ix]))
2097                     {
2098                         CV * const protokey = CvOUTSIDE(ppad[ix]);
2099                         CV ** const cvp = protokey == proto
2100                             ? &cv
2101                             : (CV **)hv_fetch(cloned, (char *)&protokey,
2102                                               sizeof(CV *), 0);
2103                         if (cvp && *cvp) {
2104                             S_cv_clone(aTHX_ (CV *)ppad[ix],
2105                                              (CV *)PL_curpad[ix],
2106                                              *cvp, cloned);
2107                             (void)hv_store(cloned, (char *)&ppad[ix],
2108                                      sizeof(CV *),
2109                                      SvREFCNT_inc_simple_NN(PL_curpad[ix]),
2110                                      0);
2111                             subclones--;
2112                             cloned_in_this_pass = TRUE;
2113                         }
2114                     }
2115                 }
2116             } while (cloned_in_this_pass);
2117             if (subclones)
2118                 for (ix = fpad; ix > 0; ix--) {
2119                     PADNAME * const name =
2120                         (ix <= fname) ? pname[ix] : NULL;
2121                     if (name && name != &PL_padname_undef
2122                      && !PadnameOUTER(name) && PadnamePV(name)[0] == '&'
2123                      && PadnameIsSTATE(name) && !CvCLONED(PL_curpad[ix]))
2124                         S_cv_clone(aTHX_ (CV *)ppad[ix],
2125                                          (CV *)PL_curpad[ix],
2126                                          CvOUTSIDE(ppad[ix]), cloned);
2127                 }
2128         }
2129         else for (ix = fpad; ix > 0; ix--) {
2130             PADNAME * const name = (ix <= fname) ? pname[ix] : NULL;
2131             if (name && name != &PL_padname_undef && !PadnameOUTER(name)
2132              && PadnamePV(name)[0] == '&' && PadnameIsSTATE(name))
2133                 S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv,
2134                                  NULL);
2135         }
2136     }
2137
2138     if (newcv) SvREFCNT_inc_simple_void_NN(cv);
2139     LEAVE;
2140
2141     if (CvCONST(cv)) {
2142         /* Constant sub () { $x } closing over $x:
2143          * The prototype was marked as a candiate for const-ization,
2144          * so try to grab the current const value, and if successful,
2145          * turn into a const sub:
2146          */
2147         SV* const_sv;
2148         OP *o = CvSTART(cv);
2149         assert(newcv);
2150         for (; o; o = o->op_next)
2151             if (o->op_type == OP_PADSV)
2152                 break;
2153         ASSUME(o->op_type == OP_PADSV);
2154         const_sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
2155         /* the candidate should have 1 ref from this pad and 1 ref
2156          * from the parent */
2157         if (const_sv && SvREFCNT(const_sv) == 2) {
2158             const bool was_method = cBOOL(CvMETHOD(cv));
2159             bool copied = FALSE;
2160             if (outside) {
2161                 PADNAME * const pn =
2162                     PadlistNAMESARRAY(CvPADLIST(outside))
2163                         [PARENT_PAD_INDEX(PadlistNAMESARRAY(
2164                             CvPADLIST(cv))[o->op_targ])];
2165                 assert(PadnameOUTER(PadlistNAMESARRAY(CvPADLIST(cv))
2166                                         [o->op_targ]));
2167                 if (PadnameLVALUE(pn)) {
2168                     /* We have a lexical that is potentially modifiable
2169                        elsewhere, so making a constant will break clo-
2170                        sure behaviour.  If this is a ‘simple lexical
2171                        op tree’, i.e., sub(){$x}, emit a deprecation
2172                        warning, but continue to exhibit the old behav-
2173                        iour of making it a constant based on the ref-
2174                        count of the candidate variable.
2175
2176                        A simple lexical op tree looks like this:
2177
2178                          leavesub
2179                            lineseq
2180                              nextstate
2181                              padsv
2182                      */
2183                     if (OpSIBLING(
2184                          cUNOPx(cUNOPx(CvROOT(cv))->op_first)->op_first
2185                         ) == o
2186                      && !OpSIBLING(o))
2187                     {
2188                         Perl_ck_warner_d(aTHX_
2189                                           packWARN(WARN_DEPRECATED),
2190                                          "Constants from lexical "
2191                                          "variables potentially "
2192                                          "modified elsewhere are "
2193                                          "deprecated");
2194                         /* We *copy* the lexical variable, and donate the
2195                            copy to newCONSTSUB.  Yes, this is ugly, and
2196                            should be killed.  We need to do this for the
2197                            time being, however, because turning on SvPADTMP
2198                            on a lexical will have observable effects
2199                            elsewhere.  */
2200                         const_sv = newSVsv(const_sv);
2201                         copied = TRUE;
2202                     }
2203                     else
2204                         goto constoff;
2205                 }
2206             }
2207             if (!copied)
2208                 SvREFCNT_inc_simple_void_NN(const_sv);
2209             /* If the lexical is not used elsewhere, it is safe to turn on
2210                SvPADTMP, since it is only when it is used in lvalue con-
2211                text that the difference is observable.  */
2212             SvREADONLY_on(const_sv);
2213             SvPADTMP_on(const_sv);
2214             SvREFCNT_dec_NN(cv);
2215             cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
2216             if (was_method)
2217                 CvMETHOD_on(cv);
2218         }
2219         else {
2220           constoff:
2221             CvCONST_off(cv);
2222         }
2223     }
2224
2225     return cv;
2226 }
2227
2228 static CV *
2229 S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned)
2230 {
2231 #ifdef USE_ITHREADS
2232     dVAR;
2233 #endif
2234     const bool newcv = !cv;
2235
2236     assert(!CvUNIQUE(proto));
2237
2238     if (!cv) cv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
2239     CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
2240                                     |CVf_SLABBED);
2241     CvCLONED_on(cv);
2242
2243     CvFILE(cv)          = CvDYNFILE(proto) ? savepv(CvFILE(proto))
2244                                            : CvFILE(proto);
2245     if (CvNAMED(proto))
2246          CvNAME_HEK_set(cv, share_hek_hek(CvNAME_HEK(proto)));
2247     else CvGV_set(cv,CvGV(proto));
2248     CvSTASH_set(cv, CvSTASH(proto));
2249     OP_REFCNT_LOCK;
2250     CvROOT(cv)          = OpREFCNT_inc(CvROOT(proto));
2251     OP_REFCNT_UNLOCK;
2252     CvSTART(cv)         = CvSTART(proto);
2253     CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
2254
2255     if (SvPOK(proto)) {
2256         sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
2257         if (SvUTF8(proto))
2258            SvUTF8_on(MUTABLE_SV(cv));
2259     }
2260     if (SvMAGIC(proto))
2261         mg_copy((SV *)proto, (SV *)cv, 0, 0);
2262
2263     if (CvPADLIST(proto))
2264         cv = S_cv_clone_pad(aTHX_ proto, cv, outside, cloned, newcv);
2265
2266     DEBUG_Xv(
2267         PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
2268         if (CvOUTSIDE(cv)) cv_dump(CvOUTSIDE(cv), "Outside");
2269         cv_dump(proto,   "Proto");
2270         cv_dump(cv,      "To");
2271     );
2272
2273     return cv;
2274 }
2275
2276 CV *
2277 Perl_cv_clone(pTHX_ CV *proto)
2278 {
2279     PERL_ARGS_ASSERT_CV_CLONE;
2280
2281     if (!CvPADLIST(proto)) Perl_croak(aTHX_ "panic: no pad in cv_clone");
2282     return S_cv_clone(aTHX_ proto, NULL, NULL, NULL);
2283 }
2284
2285 /* Called only by pp_clonecv */
2286 CV *
2287 Perl_cv_clone_into(pTHX_ CV *proto, CV *target)
2288 {
2289     PERL_ARGS_ASSERT_CV_CLONE_INTO;
2290     cv_undef(target);
2291     return S_cv_clone(aTHX_ proto, target, NULL, NULL);
2292 }
2293
2294 /*
2295 =for apidoc cv_name
2296
2297 Returns an SV containing the name of the CV, mainly for use in error
2298 reporting.  The CV may actually be a GV instead, in which case the returned
2299 SV holds the GV's name.  Anything other than a GV or CV is treated as a
2300 string already holding the sub name, but this could change in the future.
2301
2302 An SV may be passed as a second argument.  If so, the name will be assigned
2303 to it and it will be returned.  Otherwise the returned SV will be a new
2304 mortal.
2305
2306 If C<flags> has the C<CV_NAME_NOTQUAL> bit set, then the package name will not be
2307 included.  If the first argument is neither a CV nor a GV, this flag is
2308 ignored (subject to change).
2309
2310 =cut
2311 */
2312
2313 SV *
2314 Perl_cv_name(pTHX_ CV *cv, SV *sv, U32 flags)
2315 {
2316     PERL_ARGS_ASSERT_CV_NAME;
2317     if (!isGV_with_GP(cv) && SvTYPE(cv) != SVt_PVCV) {
2318         if (sv) sv_setsv(sv,(SV *)cv);
2319         return sv ? (sv) : (SV *)cv;
2320     }
2321     {
2322         SV * const retsv = sv ? (sv) : sv_newmortal();
2323         if (SvTYPE(cv) == SVt_PVCV) {
2324             if (CvNAMED(cv)) {
2325                 if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL)
2326                     sv_sethek(retsv, CvNAME_HEK(cv));
2327                 else {
2328                     sv_sethek(retsv, HvNAME_HEK(CvSTASH(cv)));
2329                     sv_catpvs(retsv, "::");
2330                     sv_cathek(retsv, CvNAME_HEK(cv));
2331                 }
2332             }
2333             else if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL)
2334                 sv_sethek(retsv, GvNAME_HEK(GvEGV(CvGV(cv))));
2335             else gv_efullname3(retsv, CvGV(cv), NULL);
2336         }
2337         else if (flags & CV_NAME_NOTQUAL) sv_sethek(retsv, GvNAME_HEK(cv));
2338         else gv_efullname3(retsv,(GV *)cv,NULL);
2339         return retsv;
2340     }
2341 }
2342
2343 /*
2344 =for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
2345
2346 For any anon CVs in the pad, change C<CvOUTSIDE> of that CV from
2347 C<old_cv> to C<new_cv> if necessary.  Needed when a newly-compiled CV has to be
2348 moved to a pre-existing CV struct.
2349
2350 =cut
2351 */
2352
2353 void
2354 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
2355 {
2356     I32 ix;
2357     PADNAMELIST * const comppad_name = PadlistNAMES(padlist);
2358     AV * const comppad = PadlistARRAY(padlist)[1];
2359     PADNAME ** const namepad = PadnamelistARRAY(comppad_name);
2360     SV ** const curpad = AvARRAY(comppad);
2361
2362     PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
2363     PERL_UNUSED_ARG(old_cv);
2364
2365     for (ix = PadnamelistMAX(comppad_name); ix > 0; ix--) {
2366         const PADNAME *name = namepad[ix];
2367         if (name && name != &PL_padname_undef && !PadnameIsOUR(name)
2368             && *PadnamePV(name) == '&')
2369         {
2370           CV *innercv = MUTABLE_CV(curpad[ix]);
2371           if (UNLIKELY(PadnameOUTER(name))) {
2372             CV *cv = new_cv;
2373             PADNAME **names = namepad;
2374             PADOFFSET i = ix;
2375             while (PadnameOUTER(name)) {
2376                 cv = CvOUTSIDE(cv);
2377                 names = PadlistNAMESARRAY(CvPADLIST(cv));
2378                 i = PARENT_PAD_INDEX(name);
2379                 name = names[i];
2380             }
2381             innercv = (CV *)PadARRAY(PadlistARRAY(CvPADLIST(cv))[1])[i];
2382           }
2383           if (SvTYPE(innercv) == SVt_PVCV) {
2384             /* XXX 0afba48f added code here to check for a proto CV
2385                    attached to the pad entry by magic.  But shortly there-
2386                    after 81df9f6f95 moved the magic to the pad name.  The
2387                    code here was never updated, so it wasn’t doing anything
2388                    and got deleted when PADNAME became a distinct type.  Is
2389                    there any bug as a result?  */
2390             if (CvOUTSIDE(innercv) == old_cv) {
2391                 if (!CvWEAKOUTSIDE(innercv)) {
2392                     SvREFCNT_dec(old_cv);
2393                     SvREFCNT_inc_simple_void_NN(new_cv);
2394                 }
2395                 CvOUTSIDE(innercv) = new_cv;
2396             }
2397           }
2398           else { /* format reference */
2399             SV * const rv = curpad[ix];
2400             CV *innercv;
2401             if (!SvOK(rv)) continue;
2402             assert(SvROK(rv));
2403             assert(SvWEAKREF(rv));
2404             innercv = (CV *)SvRV(rv);
2405             assert(!CvWEAKOUTSIDE(innercv));
2406             SvREFCNT_dec(CvOUTSIDE(innercv));
2407             CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
2408           }
2409         }
2410     }
2411 }
2412
2413 /*
2414 =for apidoc m|void|pad_push|PADLIST *padlist|int depth
2415
2416 Push a new pad frame onto the padlist, unless there's already a pad at
2417 this depth, in which case don't bother creating a new one.  Then give
2418 the new pad an C<@_> in slot zero.
2419
2420 =cut
2421 */
2422
2423 void
2424 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
2425 {
2426     PERL_ARGS_ASSERT_PAD_PUSH;
2427
2428     if (depth > PadlistMAX(padlist) || !PadlistARRAY(padlist)[depth]) {
2429         PAD** const svp = PadlistARRAY(padlist);
2430         AV* const newpad = newAV();
2431         SV** const oldpad = AvARRAY(svp[depth-1]);
2432         I32 ix = AvFILLp((const AV *)svp[1]);
2433         const I32 names_fill = PadnamelistMAX((PADNAMELIST *)svp[0]);
2434         PADNAME ** const names = PadnamelistARRAY((PADNAMELIST *)svp[0]);
2435         AV *av;
2436
2437         for ( ;ix > 0; ix--) {
2438             if (names_fill >= ix && PadnameLEN(names[ix])) {
2439                 const char sigil = PadnamePV(names[ix])[0];
2440                 if (PadnameOUTER(names[ix])
2441                         || PadnameIsSTATE(names[ix])
2442                         || sigil == '&')
2443                 {
2444                     /* outer lexical or anon code */
2445                     av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2446                 }
2447                 else {          /* our own lexical */
2448                     SV *sv; 
2449                     if (sigil == '@')
2450                         sv = MUTABLE_SV(newAV());
2451                     else if (sigil == '%')
2452                         sv = MUTABLE_SV(newHV());
2453                     else
2454                         sv = newSV(0);
2455                     av_store(newpad, ix, sv);
2456                 }
2457             }
2458             else if (PadnamePV(names[ix])) {
2459                 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
2460             }
2461             else {
2462                 /* save temporaries on recursion? */
2463                 SV * const sv = newSV(0);
2464                 av_store(newpad, ix, sv);
2465                 SvPADTMP_on(sv);
2466             }
2467         }
2468         av = newAV();
2469         av_store(newpad, 0, MUTABLE_SV(av));
2470         AvREIFY_only(av);
2471
2472         padlist_store(padlist, depth, newpad);
2473     }
2474 }
2475
2476 #if defined(USE_ITHREADS)
2477
2478 #  define av_dup_inc(s,t)       MUTABLE_AV(sv_dup_inc((const SV *)s,t))
2479
2480 /*
2481 =for apidoc padlist_dup
2482
2483 Duplicates a pad.
2484
2485 =cut
2486 */
2487
2488 PADLIST *
2489 Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
2490 {
2491     PADLIST *dstpad;
2492     bool cloneall;
2493     PADOFFSET max;
2494
2495     PERL_ARGS_ASSERT_PADLIST_DUP;
2496
2497     cloneall = cBOOL(param->flags & CLONEf_COPY_STACKS);
2498     assert (SvREFCNT(PadlistARRAY(srcpad)[1]) == 1);
2499
2500     max = cloneall ? PadlistMAX(srcpad) : 1;
2501
2502     Newx(dstpad, 1, PADLIST);
2503     ptr_table_store(PL_ptr_table, srcpad, dstpad);
2504     PadlistMAX(dstpad) = max;
2505     Newx(PadlistARRAY(dstpad), max + 1, PAD *);
2506
2507     PadlistARRAY(dstpad)[0] = (PAD *)
2508             padnamelist_dup(PadlistNAMES(srcpad), param);
2509     PadnamelistREFCNT(PadlistNAMES(dstpad))++;
2510     if (cloneall) {
2511         PADOFFSET depth;
2512         for (depth = 1; depth <= max; ++depth)
2513             PadlistARRAY(dstpad)[depth] =
2514                 av_dup_inc(PadlistARRAY(srcpad)[depth], param);
2515     } else {
2516         /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2517            to build anything other than the first level of pads.  */
2518         I32 ix = AvFILLp(PadlistARRAY(srcpad)[1]);
2519         AV *pad1;
2520         const I32 names_fill = PadnamelistMAX(PadlistNAMES(srcpad));
2521         const PAD *const srcpad1 = PadlistARRAY(srcpad)[1];
2522         SV **oldpad = AvARRAY(srcpad1);
2523         PADNAME ** const names = PadnamelistARRAY(PadlistNAMES(dstpad));
2524         SV **pad1a;
2525         AV *args;
2526
2527         pad1 = newAV();
2528
2529         av_extend(pad1, ix);
2530         PadlistARRAY(dstpad)[1] = pad1;
2531         pad1a = AvARRAY(pad1);
2532
2533         if (ix > -1) {
2534             AvFILLp(pad1) = ix;
2535
2536             for ( ;ix > 0; ix--) {
2537                 if (!oldpad[ix]) {
2538                     pad1a[ix] = NULL;
2539                 } else if (names_fill >= ix && names[ix] &&
2540                            PadnameLEN(names[ix])) {
2541                     const char sigil = PadnamePV(names[ix])[0];
2542                     if (PadnameOUTER(names[ix])
2543                         || PadnameIsSTATE(names[ix])
2544                         || sigil == '&')
2545                         {
2546                             /* outer lexical or anon code */
2547                             pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2548                         }
2549                     else {              /* our own lexical */
2550                         if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2551                             /* This is a work around for how the current
2552                                implementation of ?{ } blocks in regexps
2553                                interacts with lexicals.  */
2554                             pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2555                         } else {
2556                             SV *sv; 
2557                             
2558                             if (sigil == '@')
2559                                 sv = MUTABLE_SV(newAV());
2560                             else if (sigil == '%')
2561                                 sv = MUTABLE_SV(newHV());
2562                             else
2563                                 sv = newSV(0);
2564                             pad1a[ix] = sv;
2565                         }
2566                     }
2567                 }
2568                 else if ((  names_fill >= ix && names[ix]
2569                          && PadnamePV(names[ix])  )) {
2570                     pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2571                 }
2572                 else {
2573                     /* save temporaries on recursion? */
2574                     SV * const sv = newSV(0);
2575                     pad1a[ix] = sv;
2576
2577                     /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2578                        FIXTHAT before merging this branch.
2579                        (And I know how to) */
2580                     if (SvPADTMP(oldpad[ix]))
2581                         SvPADTMP_on(sv);
2582                 }
2583             }
2584
2585             if (oldpad[0]) {
2586                 args = newAV();                 /* Will be @_ */
2587                 AvREIFY_only(args);
2588                 pad1a[0] = (SV *)args;
2589             }
2590         }
2591     }
2592
2593     return dstpad;
2594 }
2595
2596 #endif /* USE_ITHREADS */
2597
2598 PAD **
2599 Perl_padlist_store(pTHX_ PADLIST *padlist, I32 key, PAD *val)
2600 {
2601     PAD **ary;
2602     SSize_t const oldmax = PadlistMAX(padlist);
2603
2604     PERL_ARGS_ASSERT_PADLIST_STORE;
2605
2606     assert(key >= 0);
2607
2608     if (key > PadlistMAX(padlist)) {
2609         av_extend_guts(NULL,key,&PadlistMAX(padlist),
2610                        (SV ***)&PadlistARRAY(padlist),
2611                        (SV ***)&PadlistARRAY(padlist));
2612         Zero(PadlistARRAY(padlist)+oldmax+1, PadlistMAX(padlist)-oldmax,
2613              PAD *);
2614     }
2615     ary = PadlistARRAY(padlist);
2616     SvREFCNT_dec(ary[key]);
2617     ary[key] = val;
2618     return &ary[key];
2619 }
2620
2621 /*
2622 =for apidoc newPADNAMELIST
2623
2624 Creates a new pad name list.  C<max> is the highest index for which space
2625 is allocated.
2626
2627 =cut
2628 */
2629
2630 PADNAMELIST *
2631 Perl_newPADNAMELIST(size_t max)
2632 {
2633     PADNAMELIST *pnl;
2634     Newx(pnl, 1, PADNAMELIST);
2635     Newxz(PadnamelistARRAY(pnl), max+1, PADNAME *);
2636     PadnamelistMAX(pnl) = -1;
2637     PadnamelistREFCNT(pnl) = 1;
2638     PadnamelistMAXNAMED(pnl) = 0;
2639     pnl->xpadnl_max = max;
2640     return pnl;
2641 }
2642
2643 /*
2644 =for apidoc padnamelist_store
2645
2646 Stores the pad name (which may be null) at the given index, freeing any
2647 existing pad name in that slot.
2648
2649 =cut
2650 */
2651
2652 PADNAME **
2653 Perl_padnamelist_store(pTHX_ PADNAMELIST *pnl, SSize_t key, PADNAME *val)
2654 {
2655     PADNAME **ary;
2656
2657     PERL_ARGS_ASSERT_PADNAMELIST_STORE;
2658
2659     assert(key >= 0);
2660
2661     if (key > pnl->xpadnl_max)
2662         av_extend_guts(NULL,key,&pnl->xpadnl_max,
2663                        (SV ***)&PadnamelistARRAY(pnl),
2664                        (SV ***)&PadnamelistARRAY(pnl));
2665     if (PadnamelistMAX(pnl) < key) {
2666         Zero(PadnamelistARRAY(pnl)+PadnamelistMAX(pnl)+1,
2667              key-PadnamelistMAX(pnl), PADNAME *);
2668         PadnamelistMAX(pnl) = key;
2669     }
2670     ary = PadnamelistARRAY(pnl);
2671     if (ary[key])
2672         PadnameREFCNT_dec(ary[key]);
2673     ary[key] = val;
2674     return &ary[key];
2675 }
2676
2677 /*
2678 =for apidoc padnamelist_fetch
2679
2680 Fetches the pad name from the given index.
2681
2682 =cut
2683 */
2684
2685 PADNAME *
2686 Perl_padnamelist_fetch(PADNAMELIST *pnl, SSize_t key)
2687 {
2688     PERL_ARGS_ASSERT_PADNAMELIST_FETCH;
2689     ASSUME(key >= 0);
2690
2691     return key > PadnamelistMAX(pnl) ? NULL : PadnamelistARRAY(pnl)[key];
2692 }
2693
2694 void
2695 Perl_padnamelist_free(pTHX_ PADNAMELIST *pnl)
2696 {
2697     PERL_ARGS_ASSERT_PADNAMELIST_FREE;
2698     if (!--PadnamelistREFCNT(pnl)) {
2699         while(PadnamelistMAX(pnl) >= 0)
2700         {
2701             PADNAME * const pn =
2702                 PadnamelistARRAY(pnl)[PadnamelistMAX(pnl)--];
2703             if (pn)
2704                 PadnameREFCNT_dec(pn);
2705         }
2706         Safefree(PadnamelistARRAY(pnl));
2707         Safefree(pnl);
2708     }
2709 }
2710
2711 #if defined(USE_ITHREADS)
2712
2713 /*
2714 =for apidoc padnamelist_dup
2715
2716 Duplicates a pad name list.
2717
2718 =cut
2719 */
2720
2721 PADNAMELIST *
2722 Perl_padnamelist_dup(pTHX_ PADNAMELIST *srcpad, CLONE_PARAMS *param)
2723 {
2724     PADNAMELIST *dstpad;
2725     SSize_t max = PadnamelistMAX(srcpad);
2726
2727     PERL_ARGS_ASSERT_PADNAMELIST_DUP;
2728
2729     /* look for it in the table first */
2730     dstpad = (PADNAMELIST *)ptr_table_fetch(PL_ptr_table, srcpad);
2731     if (dstpad)
2732         return dstpad;
2733
2734     dstpad = newPADNAMELIST(max);
2735     PadnamelistREFCNT(dstpad) = 0; /* The caller will increment it.  */
2736     PadnamelistMAXNAMED(dstpad) = PadnamelistMAXNAMED(srcpad);
2737     PadnamelistMAX(dstpad) = max;
2738
2739     ptr_table_store(PL_ptr_table, srcpad, dstpad);
2740     for (; max >= 0; max--)
2741       if (PadnamelistARRAY(srcpad)[max]) {
2742         PadnamelistARRAY(dstpad)[max] =
2743             padname_dup(PadnamelistARRAY(srcpad)[max], param);
2744         PadnameREFCNT(PadnamelistARRAY(dstpad)[max])++;
2745       }
2746
2747     return dstpad;
2748 }
2749
2750 #endif /* USE_ITHREADS */
2751
2752 /*
2753 =for apidoc newPADNAMEpvn
2754
2755 Constructs and returns a new pad name.  C<s> must be a UTF-8 string.  Do not
2756 use this for pad names that point to outer lexicals.  See
2757 C<L</newPADNAMEouter>>.
2758
2759 =cut
2760 */
2761
2762 PADNAME *
2763 Perl_newPADNAMEpvn(const char *s, STRLEN len)
2764 {
2765     struct padname_with_str *alloc;
2766     char *alloc2; /* for Newxz */
2767     PADNAME *pn;
2768     PERL_ARGS_ASSERT_NEWPADNAMEPVN;
2769     Newxz(alloc2,
2770           STRUCT_OFFSET(struct padname_with_str, xpadn_str[0]) + len + 1,
2771           char);
2772     alloc = (struct padname_with_str *)alloc2;
2773     pn = (PADNAME *)alloc;
2774     PadnameREFCNT(pn) = 1;
2775     PadnamePV(pn) = alloc->xpadn_str;
2776     Copy(s, PadnamePV(pn), len, char);
2777     *(PadnamePV(pn) + len) = '\0';
2778     PadnameLEN(pn) = len;
2779     return pn;
2780 }
2781
2782 /*
2783 =for apidoc newPADNAMEouter
2784
2785 Constructs and returns a new pad name.  Only use this function for names
2786 that refer to outer lexicals.  (See also L</newPADNAMEpvn>.)  C<outer> is
2787 the outer pad name that this one mirrors.  The returned pad name has the
2788 C<PADNAMEt_OUTER> flag already set.
2789
2790 =cut
2791 */
2792
2793 PADNAME *
2794 Perl_newPADNAMEouter(PADNAME *outer)
2795 {
2796     PADNAME *pn;
2797     PERL_ARGS_ASSERT_NEWPADNAMEOUTER;
2798     Newxz(pn, 1, PADNAME);
2799     PadnameREFCNT(pn) = 1;
2800     PadnamePV(pn) = PadnamePV(outer);
2801     /* Not PadnameREFCNT(outer), because ‘outer’ may itself close over
2802        another entry.  The original pad name owns the buffer.  */
2803     PadnameREFCNT(PADNAME_FROM_PV(PadnamePV(outer)))++;
2804     PadnameFLAGS(pn) = PADNAMEt_OUTER;
2805     PadnameLEN(pn) = PadnameLEN(outer);
2806     return pn;
2807 }
2808
2809 void
2810 Perl_padname_free(pTHX_ PADNAME *pn)
2811 {
2812     PERL_ARGS_ASSERT_PADNAME_FREE;
2813     if (!--PadnameREFCNT(pn)) {
2814         if (UNLIKELY(pn == &PL_padname_undef || pn == &PL_padname_const)) {
2815             PadnameREFCNT(pn) = SvREFCNT_IMMORTAL;
2816             return;
2817         }
2818         SvREFCNT_dec(PadnameTYPE(pn)); /* Takes care of protocv, too.  */
2819         SvREFCNT_dec(PadnameOURSTASH(pn));
2820         if (PadnameOUTER(pn))
2821             PadnameREFCNT_dec(PADNAME_FROM_PV(PadnamePV(pn)));
2822         Safefree(pn);
2823     }
2824 }
2825
2826 #if defined(USE_ITHREADS)
2827
2828 /*
2829 =for apidoc padname_dup
2830
2831 Duplicates a pad name.
2832
2833 =cut
2834 */
2835
2836 PADNAME *
2837 Perl_padname_dup(pTHX_ PADNAME *src, CLONE_PARAMS *param)
2838 {
2839     PADNAME *dst;
2840
2841     PERL_ARGS_ASSERT_PADNAME_DUP;
2842
2843     /* look for it in the table first */
2844     dst = (PADNAME *)ptr_table_fetch(PL_ptr_table, src);
2845     if (dst)
2846         return dst;
2847
2848     if (!PadnamePV(src)) {
2849         dst = &PL_padname_undef;
2850         ptr_table_store(PL_ptr_table, src, dst);
2851         return dst;
2852     }
2853
2854     dst = PadnameOUTER(src)
2855      ? newPADNAMEouter(padname_dup(PADNAME_FROM_PV(PadnamePV(src)), param))
2856      : newPADNAMEpvn(PadnamePV(src), PadnameLEN(src));
2857     ptr_table_store(PL_ptr_table, src, dst);
2858     PadnameLEN(dst) = PadnameLEN(src);
2859     PadnameFLAGS(dst) = PadnameFLAGS(src);
2860     PadnameREFCNT(dst) = 0; /* The caller will increment it.  */
2861     PadnameTYPE   (dst) = (HV *)sv_dup_inc((SV *)PadnameTYPE(src), param);
2862     PadnameOURSTASH(dst) = (HV *)sv_dup_inc((SV *)PadnameOURSTASH(src),
2863                                             param);
2864     dst->xpadn_low  = src->xpadn_low;
2865     dst->xpadn_high = src->xpadn_high;
2866     dst->xpadn_gen  = src->xpadn_gen;
2867     return dst;
2868 }
2869
2870 #endif /* USE_ITHREADS */
2871
2872 /*
2873  * ex: set ts=8 sts=4 sw=4 et:
2874  */