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