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