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