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