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