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