This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Remove context param from set_padlist
[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 (IN_ENCODING) {
171               SV* svrecode = NULL;
172               if (SvUTF8(sv)) {
173                    svrecode = newSVpvn(pv2, cur2);
174                    sv_recode_to_utf8(svrecode, _get_encoding());
175                    pv2      = SvPV_const(svrecode, cur2);
176               }
177               else {
178                    svrecode = newSVpvn(pv1, cur1);
179                    sv_recode_to_utf8(svrecode, _get_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(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             SvREADONLY_on(const_sv);
2243             SvPADTMP_on(const_sv);
2244             SvREFCNT_dec_NN(cv);
2245             cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
2246             if (was_method)
2247                 CvMETHOD_on(cv);
2248         }
2249         else {
2250           constoff:
2251             CvCONST_off(cv);
2252         }
2253     }
2254
2255     return cv;
2256 }
2257
2258 static CV *
2259 S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside)
2260 {
2261 #ifdef USE_ITHREADS
2262     dVAR;
2263 #endif
2264     const bool newcv = !cv;
2265
2266     assert(!CvUNIQUE(proto));
2267
2268     if (!cv) cv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
2269     CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
2270                                     |CVf_SLABBED);
2271     CvCLONED_on(cv);
2272
2273     CvFILE(cv)          = CvDYNFILE(proto) ? savepv(CvFILE(proto))
2274                                            : CvFILE(proto);
2275     if (CvNAMED(proto))
2276          CvNAME_HEK_set(cv, share_hek_hek(CvNAME_HEK(proto)));
2277     else CvGV_set(cv,CvGV(proto));
2278     CvSTASH_set(cv, CvSTASH(proto));
2279     OP_REFCNT_LOCK;
2280     CvROOT(cv)          = OpREFCNT_inc(CvROOT(proto));
2281     OP_REFCNT_UNLOCK;
2282     CvSTART(cv)         = CvSTART(proto);
2283     CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
2284
2285     if (SvPOK(proto)) {
2286         sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
2287         if (SvUTF8(proto))
2288            SvUTF8_on(MUTABLE_SV(cv));
2289     }
2290     if (SvMAGIC(proto))
2291         mg_copy((SV *)proto, (SV *)cv, 0, 0);
2292
2293     if (CvPADLIST(proto))
2294         cv = S_cv_clone_pad(aTHX_ proto, cv, outside, newcv);
2295
2296     DEBUG_Xv(
2297         PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
2298         if (CvOUTSIDE(cv)) cv_dump(CvOUTSIDE(cv), "Outside");
2299         cv_dump(proto,   "Proto");
2300         cv_dump(cv,      "To");
2301     );
2302
2303     return cv;
2304 }
2305
2306 CV *
2307 Perl_cv_clone(pTHX_ CV *proto)
2308 {
2309     PERL_ARGS_ASSERT_CV_CLONE;
2310
2311     if (!CvPADLIST(proto)) Perl_croak(aTHX_ "panic: no pad in cv_clone");
2312     return S_cv_clone(aTHX_ proto, NULL, NULL);
2313 }
2314
2315 /* Called only by pp_clonecv */
2316 CV *
2317 Perl_cv_clone_into(pTHX_ CV *proto, CV *target)
2318 {
2319     PERL_ARGS_ASSERT_CV_CLONE_INTO;
2320     cv_undef(target);
2321     return S_cv_clone(aTHX_ proto, target, NULL);
2322 }
2323
2324 /*
2325 =for apidoc cv_name
2326
2327 Returns an SV containing the name of the CV, mainly for use in error
2328 reporting.  The CV may actually be a GV instead, in which case the returned
2329 SV holds the GV's name.  Anything other than a GV or CV is treated as a
2330 string already holding the sub name, but this could change in the future.
2331
2332 An SV may be passed as a second argument.  If so, the name will be assigned
2333 to it and it will be returned.  Otherwise the returned SV will be a new
2334 mortal.
2335
2336 If the I<flags> include CV_NAME_NOTQUAL, then the package name will not be
2337 included.  If the first argument is neither a CV nor a GV, this flag is
2338 ignored (subject to change).
2339
2340 =cut
2341 */
2342
2343 SV *
2344 Perl_cv_name(pTHX_ CV *cv, SV *sv, U32 flags)
2345 {
2346     PERL_ARGS_ASSERT_CV_NAME;
2347     if (!isGV_with_GP(cv) && SvTYPE(cv) != SVt_PVCV) {
2348         if (sv) sv_setsv(sv,(SV *)cv);
2349         return sv ? (sv) : (SV *)cv;
2350     }
2351     {
2352         SV * const retsv = sv ? (sv) : sv_newmortal();
2353         if (SvTYPE(cv) == SVt_PVCV) {
2354             if (CvNAMED(cv)) {
2355                 if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL)
2356                     sv_sethek(retsv, CvNAME_HEK(cv));
2357                 else {
2358                     sv_sethek(retsv, HvNAME_HEK(CvSTASH(cv)));
2359                     sv_catpvs(retsv, "::");
2360                     sv_cathek(retsv, CvNAME_HEK(cv));
2361                 }
2362             }
2363             else if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL)
2364                 sv_sethek(retsv, GvNAME_HEK(GvEGV(CvGV(cv))));
2365             else gv_efullname3(retsv, CvGV(cv), NULL);
2366         }
2367         else if (flags & CV_NAME_NOTQUAL) sv_sethek(retsv, GvNAME_HEK(cv));
2368         else gv_efullname3(retsv,(GV *)cv,NULL);
2369         return retsv;
2370     }
2371 }
2372
2373 /*
2374 =for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
2375
2376 For any anon CVs in the pad, change CvOUTSIDE of that CV from
2377 old_cv to new_cv if necessary.  Needed when a newly-compiled CV has to be
2378 moved to a pre-existing CV struct.
2379
2380 =cut
2381 */
2382
2383 void
2384 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
2385 {
2386     I32 ix;
2387     AV * const comppad_name = PadlistARRAY(padlist)[0];
2388     AV * const comppad = PadlistARRAY(padlist)[1];
2389     SV ** const namepad = AvARRAY(comppad_name);
2390     SV ** const curpad = AvARRAY(comppad);
2391
2392     PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
2393     PERL_UNUSED_ARG(old_cv);
2394
2395     for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
2396         const SV * const namesv = namepad[ix];
2397         if (namesv && namesv != &PL_sv_undef && !SvPAD_STATE(namesv)
2398             && *SvPVX_const(namesv) == '&')
2399         {
2400           if (SvTYPE(curpad[ix]) == SVt_PVCV) {
2401             MAGIC * const mg =
2402                 SvMAGICAL(curpad[ix])
2403                     ? mg_find(curpad[ix], PERL_MAGIC_proto)
2404                     : NULL;
2405             CV * const innercv = MUTABLE_CV(mg ? mg->mg_obj : curpad[ix]);
2406             if (CvOUTSIDE(innercv) == old_cv) {
2407                 if (!CvWEAKOUTSIDE(innercv)) {
2408                     SvREFCNT_dec(old_cv);
2409                     SvREFCNT_inc_simple_void_NN(new_cv);
2410                 }
2411                 CvOUTSIDE(innercv) = new_cv;
2412             }
2413           }
2414           else { /* format reference */
2415             SV * const rv = curpad[ix];
2416             CV *innercv;
2417             if (!SvOK(rv)) continue;
2418             assert(SvROK(rv));
2419             assert(SvWEAKREF(rv));
2420             innercv = (CV *)SvRV(rv);
2421             assert(!CvWEAKOUTSIDE(innercv));
2422             SvREFCNT_dec(CvOUTSIDE(innercv));
2423             CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
2424           }
2425         }
2426     }
2427 }
2428
2429 /*
2430 =for apidoc m|void|pad_push|PADLIST *padlist|int depth
2431
2432 Push a new pad frame onto the padlist, unless there's already a pad at
2433 this depth, in which case don't bother creating a new one.  Then give
2434 the new pad an @_ in slot zero.
2435
2436 =cut
2437 */
2438
2439 void
2440 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
2441 {
2442     PERL_ARGS_ASSERT_PAD_PUSH;
2443
2444     if (depth > PadlistMAX(padlist) || !PadlistARRAY(padlist)[depth]) {
2445         PAD** const svp = PadlistARRAY(padlist);
2446         AV* const newpad = newAV();
2447         SV** const oldpad = AvARRAY(svp[depth-1]);
2448         I32 ix = AvFILLp((const AV *)svp[1]);
2449         const I32 names_fill = AvFILLp((const AV *)svp[0]);
2450         SV** const names = AvARRAY(svp[0]);
2451         AV *av;
2452
2453         for ( ;ix > 0; ix--) {
2454             if (names_fill >= ix && PadnameLEN(names[ix])) {
2455                 const char sigil = SvPVX_const(names[ix])[0];
2456                 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2457                         || (SvFLAGS(names[ix]) & SVpad_STATE)
2458                         || sigil == '&')
2459                 {
2460                     /* outer lexical or anon code */
2461                     av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2462                 }
2463                 else {          /* our own lexical */
2464                     SV *sv; 
2465                     if (sigil == '@')
2466                         sv = MUTABLE_SV(newAV());
2467                     else if (sigil == '%')
2468                         sv = MUTABLE_SV(newHV());
2469                     else
2470                         sv = newSV(0);
2471                     av_store(newpad, ix, sv);
2472                 }
2473             }
2474             else if (PadnamePV(names[ix])) {
2475                 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
2476             }
2477             else {
2478                 /* save temporaries on recursion? */
2479                 SV * const sv = newSV(0);
2480                 av_store(newpad, ix, sv);
2481                 SvPADTMP_on(sv);
2482             }
2483         }
2484         av = newAV();
2485         av_store(newpad, 0, MUTABLE_SV(av));
2486         AvREIFY_only(av);
2487
2488         padlist_store(padlist, depth, newpad);
2489     }
2490 }
2491
2492 /*
2493 =for apidoc Am|HV *|pad_compname_type|PADOFFSET po
2494
2495 Looks up the type of the lexical variable at position I<po> in the
2496 currently-compiling pad.  If the variable is typed, the stash of the
2497 class to which it is typed is returned.  If not, C<NULL> is returned.
2498
2499 =cut
2500 */
2501
2502 HV *
2503 Perl_pad_compname_type(pTHX_ const PADOFFSET po)
2504 {
2505     SV* const av = PAD_COMPNAME_SV(po);
2506     if ( SvPAD_TYPED(av) ) {
2507         return SvSTASH(av);
2508     }
2509     return NULL;
2510 }
2511
2512 #if defined(USE_ITHREADS)
2513
2514 #  define av_dup_inc(s,t)       MUTABLE_AV(sv_dup_inc((const SV *)s,t))
2515
2516 /*
2517 =for apidoc padlist_dup
2518
2519 Duplicates a pad.
2520
2521 =cut
2522 */
2523
2524 PADLIST *
2525 Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
2526 {
2527     PADLIST *dstpad;
2528     bool cloneall;
2529     PADOFFSET max;
2530
2531     PERL_ARGS_ASSERT_PADLIST_DUP;
2532
2533     cloneall = param->flags & CLONEf_COPY_STACKS
2534         || SvREFCNT(PadlistARRAY(srcpad)[1]) > 1;
2535     assert (SvREFCNT(PadlistARRAY(srcpad)[1]) == 1);
2536
2537     max = cloneall ? PadlistMAX(srcpad) : 1;
2538
2539     Newx(dstpad, 1, PADLIST);
2540     ptr_table_store(PL_ptr_table, srcpad, dstpad);
2541     PadlistMAX(dstpad) = max;
2542     Newx(PadlistARRAY(dstpad), max + 1, PAD *);
2543
2544     if (cloneall) {
2545         PADOFFSET depth;
2546         for (depth = 0; depth <= max; ++depth)
2547             PadlistARRAY(dstpad)[depth] =
2548                 av_dup_inc(PadlistARRAY(srcpad)[depth], param);
2549     } else {
2550         /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2551            to build anything other than the first level of pads.  */
2552         I32 ix = AvFILLp(PadlistARRAY(srcpad)[1]);
2553         AV *pad1;
2554         const I32 names_fill = AvFILLp(PadlistARRAY(srcpad)[0]);
2555         const PAD *const srcpad1 = PadlistARRAY(srcpad)[1];
2556         SV **oldpad = AvARRAY(srcpad1);
2557         SV **names;
2558         SV **pad1a;
2559         AV *args;
2560
2561         PadlistARRAY(dstpad)[0] =
2562             av_dup_inc(PadlistARRAY(srcpad)[0], param);
2563         names = AvARRAY(PadlistARRAY(dstpad)[0]);
2564
2565         pad1 = newAV();
2566
2567         av_extend(pad1, ix);
2568         PadlistARRAY(dstpad)[1] = pad1;
2569         pad1a = AvARRAY(pad1);
2570
2571         if (ix > -1) {
2572             AvFILLp(pad1) = ix;
2573
2574             for ( ;ix > 0; ix--) {
2575                 if (!oldpad[ix]) {
2576                     pad1a[ix] = NULL;
2577                 } else if (names_fill >= ix && names[ix] &&
2578                            PadnameLEN(names[ix])) {
2579                     const char sigil = SvPVX_const(names[ix])[0];
2580                     if ((SvFLAGS(names[ix]) & SVf_FAKE)
2581                         || (SvFLAGS(names[ix]) & SVpad_STATE)
2582                         || sigil == '&')
2583                         {
2584                             /* outer lexical or anon code */
2585                             pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2586                         }
2587                     else {              /* our own lexical */
2588                         if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2589                             /* This is a work around for how the current
2590                                implementation of ?{ } blocks in regexps
2591                                interacts with lexicals.  */
2592                             pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2593                         } else {
2594                             SV *sv; 
2595                             
2596                             if (sigil == '@')
2597                                 sv = MUTABLE_SV(newAV());
2598                             else if (sigil == '%')
2599                                 sv = MUTABLE_SV(newHV());
2600                             else
2601                                 sv = newSV(0);
2602                             pad1a[ix] = sv;
2603                         }
2604                     }
2605                 }
2606                 else if ((  names_fill >= ix && names[ix]
2607                          && PadnamePV(names[ix])  )) {
2608                     pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2609                 }
2610                 else {
2611                     /* save temporaries on recursion? */
2612                     SV * const sv = newSV(0);
2613                     pad1a[ix] = sv;
2614
2615                     /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2616                        FIXTHAT before merging this branch.
2617                        (And I know how to) */
2618                     if (SvPADTMP(oldpad[ix]))
2619                         SvPADTMP_on(sv);
2620                 }
2621             }
2622
2623             if (oldpad[0]) {
2624                 args = newAV();                 /* Will be @_ */
2625                 AvREIFY_only(args);
2626                 pad1a[0] = (SV *)args;
2627             }
2628         }
2629     }
2630
2631     return dstpad;
2632 }
2633
2634 #endif /* USE_ITHREADS */
2635
2636 PAD **
2637 Perl_padlist_store(pTHX_ PADLIST *padlist, I32 key, PAD *val)
2638 {
2639     PAD **ary;
2640     SSize_t const oldmax = PadlistMAX(padlist);
2641
2642     PERL_ARGS_ASSERT_PADLIST_STORE;
2643
2644     assert(key >= 0);
2645
2646     if (key > PadlistMAX(padlist)) {
2647         av_extend_guts(NULL,key,&PadlistMAX(padlist),
2648                        (SV ***)&PadlistARRAY(padlist),
2649                        (SV ***)&PadlistARRAY(padlist));
2650         Zero(PadlistARRAY(padlist)+oldmax+1, PadlistMAX(padlist)-oldmax,
2651              PAD *);
2652     }
2653     ary = PadlistARRAY(padlist);
2654     SvREFCNT_dec(ary[key]);
2655     ary[key] = val;
2656     return &ary[key];
2657 }
2658
2659 /*
2660  * Local variables:
2661  * c-indentation-style: bsd
2662  * c-basic-offset: 4
2663  * indent-tabs-mode: nil
2664  * End:
2665  *
2666  * ex: set ts=8 sts=4 sw=4 et:
2667  */