File Coverage

pad.c
Criterion Covered Total %
statement 673 743 90.6
branch 599 856 70.0
condition n/a
subroutine n/a
total 1272 1599 79.5


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