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