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