This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Put PL_cop_seqmax++ code in one spot
[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     COP_SEQMAX_INC;
1575     PL_min_intro_pending = 0;
1576     PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1577     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1578                 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));
1579
1580     return seq;
1581 }
1582
1583 /*
1584 =for apidoc m|void|pad_leavemy
1585
1586 Cleanup at end of scope during compilation: set the max seq number for
1587 lexicals in this scope and warn of any lexicals that never got introduced.
1588
1589 =cut
1590 */
1591
1592 OP *
1593 Perl_pad_leavemy(pTHX)
1594 {
1595     I32 off;
1596     OP *o = NULL;
1597     SV * const * const svp = AvARRAY(PL_comppad_name);
1598
1599     PL_pad_reset_pending = FALSE;
1600
1601     ASSERT_CURPAD_ACTIVE("pad_leavemy");
1602     if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1603         for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1604             const SV * const sv = svp[off];
1605             if (sv && PadnameLEN(sv) && !SvFAKE(sv))
1606                 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1607                                  "%"SVf" never introduced",
1608                                  SVfARG(sv));
1609         }
1610     }
1611     /* "Deintroduce" my variables that are leaving with this scope. */
1612     for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
1613         SV * const sv = svp[off];
1614         if (sv && PadnameLEN(sv) && !SvFAKE(sv)
1615             && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
1616         {
1617             COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
1618             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1619                 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1620                 (long)off, SvPVX_const(sv),
1621                 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1622                 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1623             );
1624             if (!PadnameIsSTATE(sv) && !PadnameIsOUR(sv)
1625              && *PadnamePV(sv) == '&' && PadnameLEN(sv) > 1) {
1626                 OP *kid = newOP(OP_INTROCV, 0);
1627                 kid->op_targ = off;
1628                 o = op_prepend_elem(OP_LINESEQ, kid, o);
1629             }
1630         }
1631     }
1632     COP_SEQMAX_INC;
1633     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1634             "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1635     return o;
1636 }
1637
1638 /*
1639 =for apidoc m|void|pad_swipe|PADOFFSET po|bool refadjust
1640
1641 Abandon the tmp in the current pad at offset po and replace with a
1642 new one.
1643
1644 =cut
1645 */
1646
1647 void
1648 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1649 {
1650     ASSERT_CURPAD_LEGAL("pad_swipe");
1651     if (!PL_curpad)
1652         return;
1653     if (AvARRAY(PL_comppad) != PL_curpad)
1654         Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
1655                    AvARRAY(PL_comppad), PL_curpad);
1656     if (!po || ((SSize_t)po) > AvFILLp(PL_comppad))
1657         Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld",
1658                    (long)po, (long)AvFILLp(PL_comppad));
1659
1660     DEBUG_X(PerlIO_printf(Perl_debug_log,
1661                 "Pad 0x%"UVxf"[0x%"UVxf"] swipe:   %ld\n",
1662                 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1663
1664     if (refadjust)
1665         SvREFCNT_dec(PL_curpad[po]);
1666
1667
1668     /* if pad tmps aren't shared between ops, then there's no need to
1669      * create a new tmp when an existing op is freed */
1670 #ifdef USE_PAD_RESET
1671     PL_curpad[po] = newSV(0);
1672     SvPADTMP_on(PL_curpad[po]);
1673 #else
1674     PL_curpad[po] = NULL;
1675 #endif
1676     if (PadnamelistMAX(PL_comppad_name) != -1
1677      && (PADOFFSET)PadnamelistMAX(PL_comppad_name) >= po) {
1678         if (PadnamelistARRAY(PL_comppad_name)[po]) {
1679             assert(!PadnameLEN(PadnamelistARRAY(PL_comppad_name)[po]));
1680         }
1681         PadnamelistARRAY(PL_comppad_name)[po] = &PL_sv_undef;
1682     }
1683     /* Use PL_constpadix here, not PL_padix.  The latter may have been
1684        reset by pad_reset.  We don’t want pad_alloc to have to scan the
1685        whole pad when allocating a constant. */
1686     if ((I32)po < PL_constpadix)
1687         PL_constpadix = po - 1;
1688 }
1689
1690 /*
1691 =for apidoc m|void|pad_reset
1692
1693 Mark all the current temporaries for reuse
1694
1695 =cut
1696 */
1697
1698 /* pad_reset() causes pad temp TARGs (operator targets) to be shared
1699  * between OPs from different statements.  During compilation, at the start
1700  * of each statement pad_reset resets PL_padix back to its previous value.
1701  * When allocating a target, pad_alloc begins its scan through the pad at
1702  * PL_padix+1.  */
1703 static void
1704 S_pad_reset(pTHX)
1705 {
1706 #ifdef USE_PAD_RESET
1707     if (AvARRAY(PL_comppad) != PL_curpad)
1708         Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
1709                    AvARRAY(PL_comppad), PL_curpad);
1710
1711     DEBUG_X(PerlIO_printf(Perl_debug_log,
1712             "Pad 0x%"UVxf"[0x%"UVxf"] reset:     padix %ld -> %ld",
1713             PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1714                 (long)PL_padix, (long)PL_padix_floor
1715             )
1716     );
1717
1718     if (!TAINTING_get) {        /* Can't mix tainted and non-tainted temporaries. */
1719         PL_padix = PL_padix_floor;
1720     }
1721 #endif
1722     PL_pad_reset_pending = FALSE;
1723 }
1724
1725 /*
1726 =for apidoc Amx|void|pad_tidy|padtidy_type type
1727
1728 Tidy up a pad at the end of compilation of the code to which it belongs.
1729 Jobs performed here are: remove most stuff from the pads of anonsub
1730 prototypes; give it a @_; mark temporaries as such.  I<type> indicates
1731 the kind of subroutine:
1732
1733     padtidy_SUB        ordinary subroutine
1734     padtidy_SUBCLONE   prototype for lexical closure
1735     padtidy_FORMAT     format
1736
1737 =cut
1738 */
1739
1740 /* XXX DAPM surely most of this stuff should be done properly
1741  * at the right time beforehand, rather than going around afterwards
1742  * cleaning up our mistakes ???
1743  */
1744
1745 void
1746 Perl_pad_tidy(pTHX_ padtidy_type type)
1747 {
1748     dVAR;
1749
1750     ASSERT_CURPAD_ACTIVE("pad_tidy");
1751
1752     /* If this CV has had any 'eval-capable' ops planted in it:
1753      * i.e. it contains any of:
1754      *
1755      *     * eval '...',
1756      *     * //ee,
1757      *     * use re 'eval'; /$var/
1758      *     * /(?{..})/),
1759      *
1760      * Then any anon prototypes in the chain of CVs should be marked as
1761      * cloneable, so that for example the eval's CV in
1762      *
1763      *    sub { eval '$x' }
1764      *
1765      * gets the right CvOUTSIDE.  If running with -d, *any* sub may
1766      * potentially have an eval executed within it.
1767      */
1768
1769     if (PL_cv_has_eval || PL_perldb) {
1770         const CV *cv;
1771         for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1772             if (cv != PL_compcv && CvCOMPILED(cv))
1773                 break; /* no need to mark already-compiled code */
1774             if (CvANON(cv)) {
1775                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1776                     "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1777                 CvCLONE_on(cv);
1778             }
1779             CvHASEVAL_on(cv);
1780         }
1781     }
1782
1783     /* extend namepad to match curpad */
1784     if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1785         av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1786
1787     if (type == padtidy_SUBCLONE) {
1788         SV ** const namep = AvARRAY(PL_comppad_name);
1789         PADOFFSET ix;
1790
1791         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1792             SV *namesv;
1793             if (!namep[ix]) namep[ix] = &PL_sv_undef;
1794
1795             /*
1796              * The only things that a clonable function needs in its
1797              * pad are anonymous subs, constants and GVs.
1798              * The rest are created anew during cloning.
1799              */
1800             if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]))
1801                 continue;
1802             namesv = namep[ix];
1803             if (!(PadnamePV(namesv) &&
1804                    (!PadnameLEN(namesv) || *SvPVX_const(namesv) == '&')))
1805             {
1806                 SvREFCNT_dec(PL_curpad[ix]);
1807                 PL_curpad[ix] = NULL;
1808             }
1809         }
1810     }
1811     else if (type == padtidy_SUB) {
1812         /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1813         AV * const av = newAV();                        /* Will be @_ */
1814         av_store(PL_comppad, 0, MUTABLE_SV(av));
1815         AvREIFY_only(av);
1816     }
1817
1818     if (type == padtidy_SUB || type == padtidy_FORMAT) {
1819         SV ** const namep = AvARRAY(PL_comppad_name);
1820         PADOFFSET ix;
1821         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1822             if (!namep[ix]) namep[ix] = &PL_sv_undef;
1823             if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]))
1824                 continue;
1825             if (SvPADMY(PL_curpad[ix]) && !SvFAKE(namep[ix])) {
1826                 /* This is a work around for how the current implementation of
1827                    ?{ } blocks in regexps interacts with lexicals.
1828
1829                    One of our lexicals.
1830                    Can't do this on all lexicals, otherwise sub baz() won't
1831                    compile in
1832
1833                    my $foo;
1834
1835                    sub bar { ++$foo; }
1836
1837                    sub baz { ++$foo; }
1838
1839                    because completion of compiling &bar calling pad_tidy()
1840                    would cause (top level) $foo to be marked as stale, and
1841                    "no longer available".  */
1842                 SvPADSTALE_on(PL_curpad[ix]);
1843             }
1844         }
1845     }
1846     PL_curpad = AvARRAY(PL_comppad);
1847 }
1848
1849 /*
1850 =for apidoc m|void|pad_free|PADOFFSET po
1851
1852 Free the SV at offset po in the current pad.
1853
1854 =cut
1855 */
1856
1857 /* XXX DAPM integrate with pad_swipe ???? */
1858 void
1859 Perl_pad_free(pTHX_ PADOFFSET po)
1860 {
1861 #ifndef USE_PAD_RESET
1862     SV *sv;
1863 #endif
1864     ASSERT_CURPAD_LEGAL("pad_free");
1865     if (!PL_curpad)
1866         return;
1867     if (AvARRAY(PL_comppad) != PL_curpad)
1868         Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
1869                    AvARRAY(PL_comppad), PL_curpad);
1870     if (!po)
1871         Perl_croak(aTHX_ "panic: pad_free po");
1872
1873     DEBUG_X(PerlIO_printf(Perl_debug_log,
1874             "Pad 0x%"UVxf"[0x%"UVxf"] free:    %ld\n",
1875             PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1876     );
1877
1878 #ifndef USE_PAD_RESET
1879     sv = PL_curpad[po];
1880     if (sv && sv != &PL_sv_undef && !SvPADMY(sv))
1881         SvFLAGS(sv) &= ~SVs_PADTMP;
1882
1883     if ((I32)po < PL_padix)
1884         PL_padix = po - 1;
1885 #endif
1886 }
1887
1888 /*
1889 =for apidoc m|void|do_dump_pad|I32 level|PerlIO *file|PADLIST *padlist|int full
1890
1891 Dump the contents of a padlist
1892
1893 =cut
1894 */
1895
1896 void
1897 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1898 {
1899     const AV *pad_name;
1900     const AV *pad;
1901     SV **pname;
1902     SV **ppad;
1903     I32 ix;
1904
1905     PERL_ARGS_ASSERT_DO_DUMP_PAD;
1906
1907     if (!padlist) {
1908         return;
1909     }
1910     pad_name = *PadlistARRAY(padlist);
1911     pad = PadlistARRAY(padlist)[1];
1912     pname = AvARRAY(pad_name);
1913     ppad = AvARRAY(pad);
1914     Perl_dump_indent(aTHX_ level, file,
1915             "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1916             PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1917     );
1918
1919     for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1920         const SV *namesv = pname[ix];
1921         if (namesv && !PadnameLEN(namesv)) {
1922             namesv = NULL;
1923         }
1924         if (namesv) {
1925             if (SvFAKE(namesv))
1926                 Perl_dump_indent(aTHX_ level+1, file,
1927                     "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1928                     (int) ix,
1929                     PTR2UV(ppad[ix]),
1930                     (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1931                     SvPVX_const(namesv),
1932                     (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1933                     (unsigned long)PARENT_PAD_INDEX(namesv)
1934
1935                 );
1936             else
1937                 Perl_dump_indent(aTHX_ level+1, file,
1938                     "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
1939                     (int) ix,
1940                     PTR2UV(ppad[ix]),
1941                     (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1942                     (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1943                     (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1944                     SvPVX_const(namesv)
1945                 );
1946         }
1947         else if (full) {
1948             Perl_dump_indent(aTHX_ level+1, file,
1949                 "%2d. 0x%"UVxf"<%lu>\n",
1950                 (int) ix,
1951                 PTR2UV(ppad[ix]),
1952                 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1953             );
1954         }
1955     }
1956 }
1957
1958 #ifdef DEBUGGING
1959
1960 /*
1961 =for apidoc m|void|cv_dump|CV *cv|const char *title
1962
1963 dump the contents of a CV
1964
1965 =cut
1966 */
1967
1968 STATIC void
1969 S_cv_dump(pTHX_ const CV *cv, const char *title)
1970 {
1971     const CV * const outside = CvOUTSIDE(cv);
1972     PADLIST* const padlist = CvPADLIST(cv);
1973
1974     PERL_ARGS_ASSERT_CV_DUMP;
1975
1976     PerlIO_printf(Perl_debug_log,
1977                   "  %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1978                   title,
1979                   PTR2UV(cv),
1980                   (CvANON(cv) ? "ANON"
1981                    : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1982                    : (cv == PL_main_cv) ? "MAIN"
1983                    : CvUNIQUE(cv) ? "UNIQUE"
1984                    : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1985                   PTR2UV(outside),
1986                   (!outside ? "null"
1987                    : CvANON(outside) ? "ANON"
1988                    : (outside == PL_main_cv) ? "MAIN"
1989                    : CvUNIQUE(outside) ? "UNIQUE"
1990                    : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1991
1992     PerlIO_printf(Perl_debug_log,
1993                     "    PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1994     do_dump_pad(1, Perl_debug_log, padlist, 1);
1995 }
1996
1997 #endif /* DEBUGGING */
1998
1999 /*
2000 =for apidoc Am|CV *|cv_clone|CV *proto
2001
2002 Clone a CV, making a lexical closure.  I<proto> supplies the prototype
2003 of the function: its code, pad structure, and other attributes.
2004 The prototype is combined with a capture of outer lexicals to which the
2005 code refers, which are taken from the currently-executing instance of
2006 the immediately surrounding code.
2007
2008 =cut
2009 */
2010
2011 static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside);
2012
2013 static CV *
2014 S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv)
2015 {
2016     I32 ix;
2017     PADLIST* const protopadlist = CvPADLIST(proto);
2018     PAD *const protopad_name = *PadlistARRAY(protopadlist);
2019     const PAD *const protopad = PadlistARRAY(protopadlist)[1];
2020     SV** const pname = AvARRAY(protopad_name);
2021     SV** const ppad = AvARRAY(protopad);
2022     const I32 fname = AvFILLp(protopad_name);
2023     const I32 fpad = AvFILLp(protopad);
2024     SV** outpad;
2025     long depth;
2026     bool subclones = FALSE;
2027
2028     assert(!CvUNIQUE(proto));
2029
2030     /* Anonymous subs have a weak CvOUTSIDE pointer, so its value is not
2031      * reliable.  The currently-running sub is always the one we need to
2032      * close over.
2033      * For my subs, the currently-running sub may not be the one we want.
2034      * We have to check whether it is a clone of CvOUTSIDE.
2035      * Note that in general for formats, CvOUTSIDE != find_runcv.
2036      * Since formats may be nested inside closures, CvOUTSIDE may point
2037      * to a prototype; we instead want the cloned parent who called us.
2038      */
2039
2040     if (!outside) {
2041       if (CvWEAKOUTSIDE(proto))
2042         outside = find_runcv(NULL);
2043       else {
2044         outside = CvOUTSIDE(proto);
2045         if ((CvCLONE(outside) && ! CvCLONED(outside))
2046             || !CvPADLIST(outside)
2047             || PadlistNAMES(CvPADLIST(outside))
2048                  != protopadlist->xpadl_outid) {
2049             outside = find_runcv_where(
2050                 FIND_RUNCV_padid_eq, PTR2IV(protopadlist->xpadl_outid), NULL
2051             );
2052             /* outside could be null */
2053         }
2054       }
2055     }
2056     depth = outside ? CvDEPTH(outside) : 0;
2057     if (!depth)
2058         depth = 1;
2059
2060     ENTER;
2061     SAVESPTR(PL_compcv);
2062     PL_compcv = cv;
2063     if (newcv) SAVEFREESV(cv); /* in case of fatal warnings */
2064
2065     if (CvHASEVAL(cv))
2066         CvOUTSIDE(cv)   = MUTABLE_CV(SvREFCNT_inc_simple(outside));
2067
2068     SAVESPTR(PL_comppad_name);
2069     PL_comppad_name = protopad_name;
2070     CvPADLIST_set(cv, pad_new(padnew_CLONE|padnew_SAVE));
2071
2072     av_fill(PL_comppad, fpad);
2073
2074     PL_curpad = AvARRAY(PL_comppad);
2075
2076     outpad = outside && CvPADLIST(outside)
2077         ? AvARRAY(PadlistARRAY(CvPADLIST(outside))[depth])
2078         : NULL;
2079     if (outpad)
2080         CvPADLIST(cv)->xpadl_outid = PadlistNAMES(CvPADLIST(outside));
2081
2082     for (ix = fpad; ix > 0; ix--) {
2083         SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
2084         SV *sv = NULL;
2085         if (namesv && PadnameLEN(namesv)) { /* lexical */
2086           if (PadnameIsOUR(namesv)) { /* or maybe not so lexical */
2087                 NOOP;
2088           }
2089           else {
2090             if (SvFAKE(namesv)) {   /* lexical from outside? */
2091                 /* formats may have an inactive, or even undefined, parent;
2092                    but state vars are always available. */
2093                 if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
2094                  || (  SvPADSTALE(sv) && !SvPAD_STATE(namesv)
2095                     && (!outside || !CvDEPTH(outside)))  ) {
2096                     S_unavailable(aTHX_ namesv);
2097                     sv = NULL;
2098                 }
2099                 else 
2100                     SvREFCNT_inc_simple_void_NN(sv);
2101             }
2102             if (!sv) {
2103                 const char sigil = SvPVX_const(namesv)[0];
2104                 if (sigil == '&')
2105                     /* If there are state subs, we need to clone them, too.
2106                        But they may need to close over variables we have
2107                        not cloned yet.  So we will have to do a second
2108                        pass.  Furthermore, there may be state subs clos-
2109                        ing over other state subs’ entries, so we have
2110                        to put a stub here and then clone into it on the
2111                        second pass. */
2112                     if (SvPAD_STATE(namesv) && !CvCLONED(ppad[ix])) {
2113                         assert(SvTYPE(ppad[ix]) == SVt_PVCV);
2114                         subclones = 1;
2115                         sv = newSV_type(SVt_PVCV);
2116                         CvLEXICAL_on(sv);
2117                     }
2118                     else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv))
2119                     {
2120                         /* my sub */
2121                         /* Just provide a stub, but name it.  It will be
2122                            upgrade to the real thing on scope entry. */
2123                         dVAR;
2124                         U32 hash;
2125                         PERL_HASH(hash, SvPVX_const(namesv)+1,
2126                                   SvCUR(namesv) - 1);
2127                         sv = newSV_type(SVt_PVCV);
2128                         CvNAME_HEK_set(
2129                             sv,
2130                             share_hek(SvPVX_const(namesv)+1,
2131                                       SvCUR(namesv) - 1
2132                                          * (SvUTF8(namesv) ? -1 : 1),
2133                                       hash)
2134                         );
2135                         CvLEXICAL_on(sv);
2136                     }
2137                     else sv = SvREFCNT_inc(ppad[ix]);
2138                 else if (sigil == '@')
2139                     sv = MUTABLE_SV(newAV());
2140                 else if (sigil == '%')
2141                     sv = MUTABLE_SV(newHV());
2142                 else
2143                     sv = newSV(0);
2144                 /* reset the 'assign only once' flag on each state var */
2145                 if (sigil != '&' && SvPAD_STATE(namesv))
2146                     SvPADSTALE_on(sv);
2147             }
2148           }
2149         }
2150         else if (namesv && PadnamePV(namesv)) {
2151             sv = SvREFCNT_inc_NN(ppad[ix]);
2152         }
2153         else {
2154             sv = newSV(0);
2155             SvPADTMP_on(sv);
2156         }
2157         PL_curpad[ix] = sv;
2158     }
2159
2160     if (subclones)
2161         for (ix = fpad; ix > 0; ix--) {
2162             SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
2163             if (namesv && namesv != &PL_sv_undef && !SvFAKE(namesv)
2164              && SvPVX_const(namesv)[0] == '&' && SvPAD_STATE(namesv))
2165                 S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv);
2166         }
2167
2168     if (newcv) SvREFCNT_inc_simple_void_NN(cv);
2169     LEAVE;
2170
2171     if (CvCONST(cv)) {
2172         /* Constant sub () { $x } closing over $x:
2173          * The prototype was marked as a candiate for const-ization,
2174          * so try to grab the current const value, and if successful,
2175          * turn into a const sub:
2176          */
2177         SV* const_sv;
2178         OP *o = CvSTART(cv);
2179         assert(newcv);
2180         for (; o; o = o->op_next)
2181             if (o->op_type == OP_PADSV)
2182                 break;
2183         ASSUME(o->op_type == OP_PADSV);
2184         const_sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
2185         /* the candidate should have 1 ref from this pad and 1 ref
2186          * from the parent */
2187         if (const_sv && SvREFCNT(const_sv) == 2) {
2188             const bool was_method = cBOOL(CvMETHOD(cv));
2189             bool copied = FALSE;
2190             if (outside) {
2191                 PADNAME * const pn =
2192                     PadlistNAMESARRAY(CvPADLIST(outside))
2193                         [PARENT_PAD_INDEX(PadlistNAMESARRAY(
2194                             CvPADLIST(cv))[o->op_targ])];
2195                 assert(PadnameOUTER(PadlistNAMESARRAY(CvPADLIST(cv))
2196                                         [o->op_targ]));
2197                 if (PadnameLVALUE(pn)) {
2198                     /* We have a lexical that is potentially modifiable
2199                        elsewhere, so making a constant will break clo-
2200                        sure behaviour.  If this is a ‘simple lexical
2201                        op tree’, i.e., sub(){$x}, emit a deprecation
2202                        warning, but continue to exhibit the old behav-
2203                        iour of making it a constant based on the ref-
2204                        count of the candidate variable.
2205
2206                        A simple lexical op tree looks like this:
2207
2208                          leavesub
2209                            lineseq
2210                              nextstate
2211                              padsv
2212                      */
2213                     if (OP_SIBLING(
2214                          cUNOPx(cUNOPx(CvROOT(cv))->op_first)->op_first
2215                         ) == o
2216                      && !OP_SIBLING(o))
2217                     {
2218                         Perl_ck_warner_d(aTHX_
2219                                           packWARN(WARN_DEPRECATED),
2220                                          "Constants from lexical "
2221                                          "variables potentially "
2222                                          "modified elsewhere are "
2223                                          "deprecated");
2224                         /* We *copy* the lexical variable, and donate the
2225                            copy to newCONSTSUB.  Yes, this is ugly, and
2226                            should be killed.  We need to do this for the
2227                            time being, however, because turning on SvPADTMP
2228                            on a lexical will have observable effects
2229                            elsewhere.  */
2230                         const_sv = newSVsv(const_sv);
2231                         copied = TRUE;
2232                     }
2233                     else
2234                         goto constoff;
2235                 }
2236             }
2237             if (!copied)
2238                 SvREFCNT_inc_simple_void_NN(const_sv);
2239             /* If the lexical is not used elsewhere, it is safe to turn on
2240                SvPADTMP, since it is only when it is used in lvalue con-
2241                text that the difference is observable.  */
2242             SvPADTMP_on(const_sv);
2243             SvREFCNT_dec_NN(cv);
2244             cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
2245             if (was_method)
2246                 CvMETHOD_on(cv);
2247         }
2248         else {
2249           constoff:
2250             CvCONST_off(cv);
2251         }
2252     }
2253
2254     return cv;
2255 }
2256
2257 static CV *
2258 S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside)
2259 {
2260 #ifdef USE_ITHREADS
2261     dVAR;
2262 #endif
2263     const bool newcv = !cv;
2264
2265     assert(!CvUNIQUE(proto));
2266
2267     if (!cv) cv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
2268     CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
2269                                     |CVf_SLABBED);
2270     CvCLONED_on(cv);
2271
2272     CvFILE(cv)          = CvDYNFILE(proto) ? savepv(CvFILE(proto))
2273                                            : CvFILE(proto);
2274     if (CvNAMED(proto))
2275          CvNAME_HEK_set(cv, share_hek_hek(CvNAME_HEK(proto)));
2276     else CvGV_set(cv,CvGV(proto));
2277     CvSTASH_set(cv, CvSTASH(proto));
2278     OP_REFCNT_LOCK;
2279     CvROOT(cv)          = OpREFCNT_inc(CvROOT(proto));
2280     OP_REFCNT_UNLOCK;
2281     CvSTART(cv)         = CvSTART(proto);
2282     CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
2283
2284     if (SvPOK(proto)) {
2285         sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
2286         if (SvUTF8(proto))
2287            SvUTF8_on(MUTABLE_SV(cv));
2288     }
2289     if (SvMAGIC(proto))
2290         mg_copy((SV *)proto, (SV *)cv, 0, 0);
2291
2292     if (CvPADLIST(proto))
2293         cv = S_cv_clone_pad(aTHX_ proto, cv, outside, newcv);
2294
2295     DEBUG_Xv(
2296         PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
2297         if (CvOUTSIDE(cv)) cv_dump(CvOUTSIDE(cv), "Outside");
2298         cv_dump(proto,   "Proto");
2299         cv_dump(cv,      "To");
2300     );
2301
2302     return cv;
2303 }
2304
2305 CV *
2306 Perl_cv_clone(pTHX_ CV *proto)
2307 {
2308     PERL_ARGS_ASSERT_CV_CLONE;
2309
2310     if (!CvPADLIST(proto)) Perl_croak(aTHX_ "panic: no pad in cv_clone");
2311     return S_cv_clone(aTHX_ proto, NULL, NULL);
2312 }
2313
2314 /* Called only by pp_clonecv */
2315 CV *
2316 Perl_cv_clone_into(pTHX_ CV *proto, CV *target)
2317 {
2318     PERL_ARGS_ASSERT_CV_CLONE_INTO;
2319     cv_undef(target);
2320     return S_cv_clone(aTHX_ proto, target, NULL);
2321 }
2322
2323 /*
2324 =for apidoc cv_name
2325
2326 Returns an SV containing the name of the CV, mainly for use in error
2327 reporting.  The CV may actually be a GV instead, in which case the returned
2328 SV holds the GV's name.  Anything other than a GV or CV is treated as a
2329 string already holding the sub name, but this could change in the future.
2330
2331 An SV may be passed as a second argument.  If so, the name will be assigned
2332 to it and it will be returned.  Otherwise the returned SV will be a new
2333 mortal.
2334
2335 If the I<flags> include CV_NAME_NOTQUAL, then the package name will not be
2336 included.  If the first argument is neither a CV nor a GV, this flag is
2337 ignored (subject to change).
2338
2339 =cut
2340 */
2341
2342 SV *
2343 Perl_cv_name(pTHX_ CV *cv, SV *sv, U32 flags)
2344 {
2345     PERL_ARGS_ASSERT_CV_NAME;
2346     if (!isGV_with_GP(cv) && SvTYPE(cv) != SVt_PVCV) {
2347         if (sv) sv_setsv(sv,(SV *)cv);
2348         return sv ? (sv) : (SV *)cv;
2349     }
2350     {
2351         SV * const retsv = sv ? (sv) : sv_newmortal();
2352         if (SvTYPE(cv) == SVt_PVCV) {
2353             if (CvNAMED(cv)) {
2354                 if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL)
2355                     sv_sethek(retsv, CvNAME_HEK(cv));
2356                 else {
2357                     sv_sethek(retsv, HvNAME_HEK(CvSTASH(cv)));
2358                     sv_catpvs(retsv, "::");
2359                     sv_cathek(retsv, CvNAME_HEK(cv));
2360                 }
2361             }
2362             else if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL)
2363                 sv_sethek(retsv, GvNAME_HEK(GvEGV(CvGV(cv))));
2364             else gv_efullname3(retsv, CvGV(cv), NULL);
2365         }
2366         else if (flags & CV_NAME_NOTQUAL) sv_sethek(retsv, GvNAME_HEK(cv));
2367         else gv_efullname3(retsv,(GV *)cv,NULL);
2368         return retsv;
2369     }
2370 }
2371
2372 /*
2373 =for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
2374
2375 For any anon CVs in the pad, change CvOUTSIDE of that CV from
2376 old_cv to new_cv if necessary.  Needed when a newly-compiled CV has to be
2377 moved to a pre-existing CV struct.
2378
2379 =cut
2380 */
2381
2382 void
2383 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
2384 {
2385     I32 ix;
2386     AV * const comppad_name = PadlistARRAY(padlist)[0];
2387     AV * const comppad = PadlistARRAY(padlist)[1];
2388     SV ** const namepad = AvARRAY(comppad_name);
2389     SV ** const curpad = AvARRAY(comppad);
2390
2391     PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
2392     PERL_UNUSED_ARG(old_cv);
2393
2394     for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
2395         const SV * const namesv = namepad[ix];
2396         if (namesv && namesv != &PL_sv_undef && !SvPAD_STATE(namesv)
2397             && *SvPVX_const(namesv) == '&')
2398         {
2399           if (SvTYPE(curpad[ix]) == SVt_PVCV) {
2400             MAGIC * const mg =
2401                 SvMAGICAL(curpad[ix])
2402                     ? mg_find(curpad[ix], PERL_MAGIC_proto)
2403                     : NULL;
2404             CV * const innercv = MUTABLE_CV(mg ? mg->mg_obj : curpad[ix]);
2405             if (CvOUTSIDE(innercv) == old_cv) {
2406                 if (!CvWEAKOUTSIDE(innercv)) {
2407                     SvREFCNT_dec(old_cv);
2408                     SvREFCNT_inc_simple_void_NN(new_cv);
2409                 }
2410                 CvOUTSIDE(innercv) = new_cv;
2411             }
2412           }
2413           else { /* format reference */
2414             SV * const rv = curpad[ix];
2415             CV *innercv;
2416             if (!SvOK(rv)) continue;
2417             assert(SvROK(rv));
2418             assert(SvWEAKREF(rv));
2419             innercv = (CV *)SvRV(rv);
2420             assert(!CvWEAKOUTSIDE(innercv));
2421             SvREFCNT_dec(CvOUTSIDE(innercv));
2422             CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
2423           }
2424         }
2425     }
2426 }
2427
2428 /*
2429 =for apidoc m|void|pad_push|PADLIST *padlist|int depth
2430
2431 Push a new pad frame onto the padlist, unless there's already a pad at
2432 this depth, in which case don't bother creating a new one.  Then give
2433 the new pad an @_ in slot zero.
2434
2435 =cut
2436 */
2437
2438 void
2439 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
2440 {
2441     PERL_ARGS_ASSERT_PAD_PUSH;
2442
2443     if (depth > PadlistMAX(padlist) || !PadlistARRAY(padlist)[depth]) {
2444         PAD** const svp = PadlistARRAY(padlist);
2445         AV* const newpad = newAV();
2446         SV** const oldpad = AvARRAY(svp[depth-1]);
2447         I32 ix = AvFILLp((const AV *)svp[1]);
2448         const I32 names_fill = AvFILLp((const AV *)svp[0]);
2449         SV** const names = AvARRAY(svp[0]);
2450         AV *av;
2451
2452         for ( ;ix > 0; ix--) {
2453             if (names_fill >= ix && PadnameLEN(names[ix])) {
2454                 const char sigil = SvPVX_const(names[ix])[0];
2455                 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2456                         || (SvFLAGS(names[ix]) & SVpad_STATE)
2457                         || sigil == '&')
2458                 {
2459                     /* outer lexical or anon code */
2460                     av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2461                 }
2462                 else {          /* our own lexical */
2463                     SV *sv; 
2464                     if (sigil == '@')
2465                         sv = MUTABLE_SV(newAV());
2466                     else if (sigil == '%')
2467                         sv = MUTABLE_SV(newHV());
2468                     else
2469                         sv = newSV(0);
2470                     av_store(newpad, ix, sv);
2471                 }
2472             }
2473             else if (PadnamePV(names[ix])) {
2474                 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
2475             }
2476             else {
2477                 /* save temporaries on recursion? */
2478                 SV * const sv = newSV(0);
2479                 av_store(newpad, ix, sv);
2480                 SvPADTMP_on(sv);
2481             }
2482         }
2483         av = newAV();
2484         av_store(newpad, 0, MUTABLE_SV(av));
2485         AvREIFY_only(av);
2486
2487         padlist_store(padlist, depth, newpad);
2488     }
2489 }
2490
2491 /*
2492 =for apidoc Am|HV *|pad_compname_type|PADOFFSET po
2493
2494 Looks up the type of the lexical variable at position I<po> in the
2495 currently-compiling pad.  If the variable is typed, the stash of the
2496 class to which it is typed is returned.  If not, C<NULL> is returned.
2497
2498 =cut
2499 */
2500
2501 HV *
2502 Perl_pad_compname_type(pTHX_ const PADOFFSET po)
2503 {
2504     SV* const av = PAD_COMPNAME_SV(po);
2505     if ( SvPAD_TYPED(av) ) {
2506         return SvSTASH(av);
2507     }
2508     return NULL;
2509 }
2510
2511 #if defined(USE_ITHREADS)
2512
2513 #  define av_dup_inc(s,t)       MUTABLE_AV(sv_dup_inc((const SV *)s,t))
2514
2515 /*
2516 =for apidoc padlist_dup
2517
2518 Duplicates a pad.
2519
2520 =cut
2521 */
2522
2523 PADLIST *
2524 Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
2525 {
2526     PADLIST *dstpad;
2527     bool cloneall;
2528     PADOFFSET max;
2529
2530     PERL_ARGS_ASSERT_PADLIST_DUP;
2531
2532     cloneall = param->flags & CLONEf_COPY_STACKS
2533         || SvREFCNT(PadlistARRAY(srcpad)[1]) > 1;
2534     assert (SvREFCNT(PadlistARRAY(srcpad)[1]) == 1);
2535
2536     max = cloneall ? PadlistMAX(srcpad) : 1;
2537
2538     Newx(dstpad, 1, PADLIST);
2539     ptr_table_store(PL_ptr_table, srcpad, dstpad);
2540     PadlistMAX(dstpad) = max;
2541     Newx(PadlistARRAY(dstpad), max + 1, PAD *);
2542
2543     if (cloneall) {
2544         PADOFFSET depth;
2545         for (depth = 0; depth <= max; ++depth)
2546             PadlistARRAY(dstpad)[depth] =
2547                 av_dup_inc(PadlistARRAY(srcpad)[depth], param);
2548     } else {
2549         /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2550            to build anything other than the first level of pads.  */
2551         I32 ix = AvFILLp(PadlistARRAY(srcpad)[1]);
2552         AV *pad1;
2553         const I32 names_fill = AvFILLp(PadlistARRAY(srcpad)[0]);
2554         const PAD *const srcpad1 = PadlistARRAY(srcpad)[1];
2555         SV **oldpad = AvARRAY(srcpad1);
2556         SV **names;
2557         SV **pad1a;
2558         AV *args;
2559
2560         PadlistARRAY(dstpad)[0] =
2561             av_dup_inc(PadlistARRAY(srcpad)[0], param);
2562         names = AvARRAY(PadlistARRAY(dstpad)[0]);
2563
2564         pad1 = newAV();
2565
2566         av_extend(pad1, ix);
2567         PadlistARRAY(dstpad)[1] = pad1;
2568         pad1a = AvARRAY(pad1);
2569
2570         if (ix > -1) {
2571             AvFILLp(pad1) = ix;
2572
2573             for ( ;ix > 0; ix--) {
2574                 if (!oldpad[ix]) {
2575                     pad1a[ix] = NULL;
2576                 } else if (names_fill >= ix && names[ix] &&
2577                            PadnameLEN(names[ix])) {
2578                     const char sigil = SvPVX_const(names[ix])[0];
2579                     if ((SvFLAGS(names[ix]) & SVf_FAKE)
2580                         || (SvFLAGS(names[ix]) & SVpad_STATE)
2581                         || sigil == '&')
2582                         {
2583                             /* outer lexical or anon code */
2584                             pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2585                         }
2586                     else {              /* our own lexical */
2587                         if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2588                             /* This is a work around for how the current
2589                                implementation of ?{ } blocks in regexps
2590                                interacts with lexicals.  */
2591                             pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2592                         } else {
2593                             SV *sv; 
2594                             
2595                             if (sigil == '@')
2596                                 sv = MUTABLE_SV(newAV());
2597                             else if (sigil == '%')
2598                                 sv = MUTABLE_SV(newHV());
2599                             else
2600                                 sv = newSV(0);
2601                             pad1a[ix] = sv;
2602                         }
2603                     }
2604                 }
2605                 else if ((  names_fill >= ix && names[ix]
2606                          && PadnamePV(names[ix])  )) {
2607                     pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2608                 }
2609                 else {
2610                     /* save temporaries on recursion? */
2611                     SV * const sv = newSV(0);
2612                     pad1a[ix] = sv;
2613
2614                     /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2615                        FIXTHAT before merging this branch.
2616                        (And I know how to) */
2617                     if (SvPADTMP(oldpad[ix]))
2618                         SvPADTMP_on(sv);
2619                 }
2620             }
2621
2622             if (oldpad[0]) {
2623                 args = newAV();                 /* Will be @_ */
2624                 AvREIFY_only(args);
2625                 pad1a[0] = (SV *)args;
2626             }
2627         }
2628     }
2629
2630     return dstpad;
2631 }
2632
2633 #endif /* USE_ITHREADS */
2634
2635 PAD **
2636 Perl_padlist_store(pTHX_ PADLIST *padlist, I32 key, PAD *val)
2637 {
2638     PAD **ary;
2639     SSize_t const oldmax = PadlistMAX(padlist);
2640
2641     PERL_ARGS_ASSERT_PADLIST_STORE;
2642
2643     assert(key >= 0);
2644
2645     if (key > PadlistMAX(padlist)) {
2646         av_extend_guts(NULL,key,&PadlistMAX(padlist),
2647                        (SV ***)&PadlistARRAY(padlist),
2648                        (SV ***)&PadlistARRAY(padlist));
2649         Zero(PadlistARRAY(padlist)+oldmax+1, PadlistMAX(padlist)-oldmax,
2650              PAD *);
2651     }
2652     ary = PadlistARRAY(padlist);
2653     SvREFCNT_dec(ary[key]);
2654     ary[key] = val;
2655     return &ary[key];
2656 }
2657
2658 /*
2659  * Local variables:
2660  * c-indentation-style: bsd
2661  * c-basic-offset: 4
2662  * indent-tabs-mode: nil
2663  * End:
2664  *
2665  * ex: set ts=8 sts=4 sw=4 et:
2666  */