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