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