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 /* XXX DAPM 22 * As of Sept 2002, this file is new and may be in a state of flux for 23 * a while. I've marked things I intent to come back and look at further 24 * with an 'XXX DAPM' comment. 25 */ 26 27 /* 28 =head1 Pad Data Structures 29 30 =for apidoc Amx|PADLIST *|CvPADLIST|CV *cv 31 32 CV's can have CvPADLIST(cv) set to point to a PADLIST. This is the CV's 33 scratchpad, which stores lexical variables and opcode temporary and 34 per-thread values. 35 36 For these purposes "formats" are a kind-of CV; eval""s are too (except they're 37 not callable at will and are always thrown away after the eval"" is done 38 executing). Require'd files are simply evals without any outer lexical 39 scope. 40 41 XSUBs don't have CvPADLIST set - dXSTARG fetches values from PL_curpad, 42 but that is really the callers pad (a slot of which is allocated by 43 every entersub). 44 45 The PADLIST has a C array where pads are stored. 46 47 The 0th entry of the PADLIST is a PADNAMELIST (which is actually just an 48 AV, but that may change) which represents the "names" or rather 49 the "static type information" for lexicals. The individual elements of a 50 PADNAMELIST are PADNAMEs (just SVs; but, again, that may change). Future 51 refactorings might stop the PADNAMELIST from being stored in the PADLIST's 52 array, so don't rely on it. See L</PadlistNAMES>. 53 54 The CvDEPTH'th entry of a PADLIST is a PAD (an AV) which is the stack frame 55 at that depth of recursion into the CV. The 0th slot of a frame AV is an 56 AV which is @_. Other entries are storage for variables and op targets. 57 58 Iterating over the PADNAMELIST iterates over all possible pad 59 items. Pad slots that are SVs_PADTMP (targets/GVs/constants) end up having 60 &PL_sv_undef "names" (see pad_alloc()). 61 62 Only my/our variable (SvPADMY/PADNAME_isOUR) slots get valid names. 63 The rest are op targets/GVs/constants which are statically allocated 64 or resolved at compile time. These don't have names by which they 65 can be looked up from Perl code at run time through eval"" the way 66 my/our variables can be. Since they can't be looked up by "name" 67 but only by their index allocated at compile time (which is usually 68 in PL_op->op_targ), wasting a name SV for them doesn't make sense. 69 70 The SVs in the names AV have their PV being the name of the variable. 71 xlow+1..xhigh inclusive in the NV union is a range of cop_seq numbers for 72 which the name is valid (accessed through the macros COP_SEQ_RANGE_LOW and 73 _HIGH). During compilation, these fields may hold the special value 74 PERL_PADSEQ_INTRO to indicate various stages: 75 76 COP_SEQ_RANGE_LOW _HIGH 77 ----------------- ----- 78 PERL_PADSEQ_INTRO 0 variable not yet introduced: { my ($x 79 valid-seq# PERL_PADSEQ_INTRO variable in scope: { my ($x) 80 valid-seq# valid-seq# compilation of scope complete: { my ($x) } 81 82 For typed lexicals name SV is SVt_PVMG and SvSTASH 83 points at the type. For C<our> lexicals, the type is also SVt_PVMG, with the 84 SvOURSTASH slot pointing at the stash of the associated global (so that 85 duplicate C<our> declarations in the same package can be detected). SvUVX is 86 sometimes hijacked to store the generation number during compilation. 87 88 If PADNAME_OUTER (SvFAKE) is set on the 89 name SV, then that slot in the frame AV is 90 a REFCNT'ed reference to a lexical from "outside". In this case, 91 the name SV does not use xlow and xhigh to store a cop_seq range, since it is 92 in scope throughout. Instead xhigh stores some flags containing info about 93 the real lexical (is it declared in an anon, and is it capable of being 94 instantiated multiple times?), and for fake ANONs, xlow contains the index 95 within the parent's pad where the lexical's value is stored, to make 96 cloning quicker. 97 98 If the 'name' is '&' the corresponding entry in the PAD 99 is a CV representing a possible closure. 100 (PADNAME_OUTER and name of '&' is not a 101 meaningful combination currently but could 102 become so if C<my sub foo {}> is implemented.) 103 104 Note that formats are treated as anon subs, and are cloned each time 105 write is called (if necessary). 106 107 The flag SVs_PADSTALE is cleared on lexicals each time the my() is executed, 108 and set on scope exit. This allows the 109 'Variable $x is not available' warning 110 to be generated in evals, such as 111 112 { my $x = 1; sub f { eval '$x'} } f(); 113 114 For state vars, SVs_PADSTALE is overloaded to mean 'not yet initialised'. 115 116 =for apidoc AmxU|PADNAMELIST *|PL_comppad_name 117 118 During compilation, this points to the array containing the names part 119 of the pad for the currently-compiling code. 120 121 =for apidoc AmxU|PAD *|PL_comppad 122 123 During compilation, this points to the array containing the values 124 part of the pad for the currently-compiling code. (At runtime a CV may 125 have many such value arrays; at compile time just one is constructed.) 126 At runtime, this points to the array containing the currently-relevant 127 values for the pad for the currently-executing code. 128 129 =for apidoc AmxU|SV **|PL_curpad 130 131 Points directly to the body of the L</PL_comppad> array. 132 (I.e., this is C<PAD_ARRAY(PL_comppad)>.) 133 134 =cut 135 */ 136 137 138 #include "EXTERN.h" 139 #define PERL_IN_PAD_C 140 #include "perl.h" 141 #include "keywords.h" 142 143 #define COP_SEQ_RANGE_LOW_set(sv,val) \ 144 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END 145 #define COP_SEQ_RANGE_HIGH_set(sv,val) \ 146 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END 147 148 #define PARENT_PAD_INDEX_set(sv,val) \ 149 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END 150 #define PARENT_FAKELEX_FLAGS_set(sv,val) \ 151 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END 152 153 /* 154 =for apidoc mx|void|pad_peg|const char *s 155 156 When PERL_MAD is enabled, this is a small no-op function that gets called 157 at the start of each pad-related function. It can be breakpointed to 158 track all pad operations. The parameter is a string indicating the type 159 of pad operation being performed. 160 161 =cut 162 */ 163 164 #ifdef PERL_MAD 165 void pad_peg(const char* s) { 166 static int pegcnt; /* XXX not threadsafe */ 167 PERL_UNUSED_ARG(s); 168 169 PERL_ARGS_ASSERT_PAD_PEG; 170 171 pegcnt++; 172 } 173 #endif 174 175 /* 176 This is basically sv_eq_flags() in sv.c, but we avoid the magic 177 and bytes checking. 178 */ 179 180 static bool 181 sv_eq_pvn_flags(pTHX_ const SV *sv, const char* pv, const STRLEN pvlen, const U32 flags) { 182 if ( (SvUTF8(sv) & SVf_UTF8 ) != (flags & SVf_UTF8) ) { 183 const char *pv1 = SvPVX_const(sv); 184 STRLEN cur1 = SvCUR(sv); 185 const char *pv2 = pv; 186 STRLEN cur2 = pvlen; 187 if (PL_encoding) { 188 SV* svrecode = NULL; 189 if (SvUTF8(sv)) { 190 svrecode = newSVpvn(pv2, cur2); 191 sv_recode_to_utf8(svrecode, PL_encoding); 192 pv2 = SvPV_const(svrecode, cur2); 193 } 194 else { 195 svrecode = newSVpvn(pv1, cur1); 196 sv_recode_to_utf8(svrecode, PL_encoding); 197 pv1 = SvPV_const(svrecode, cur1); 198 } 199 SvREFCNT_dec_NN(svrecode); 200 } 201 if (flags & SVf_UTF8) 202 return (bytes_cmp_utf8( 203 (const U8*)pv1, cur1, 204 (const U8*)pv2, cur2) == 0); 205 else 206 return (bytes_cmp_utf8( 207 (const U8*)pv2, cur2, 208 (const U8*)pv1, cur1) == 0); 209 } 210 else 211 return ((SvPVX_const(sv) == pv) 212 || memEQ(SvPVX_const(sv), pv, pvlen)); 213 } 214 215 216 /* 217 =for apidoc Am|PADLIST *|pad_new|int flags 218 219 Create a new padlist, updating the global variables for the 220 currently-compiling padlist to point to the new padlist. The following 221 flags can be OR'ed together: 222 223 padnew_CLONE this pad is for a cloned CV 224 padnew_SAVE save old globals on the save stack 225 padnew_SAVESUB also save extra stuff for start of sub 226 227 =cut 228 */ 229 230 PADLIST * 231 Perl_pad_new(pTHX_ int flags) 232 { 233 dVAR; 234 PADLIST *padlist; 235 PAD *padname, *pad; 236 PAD **ary; 237 238 ASSERT_CURPAD_LEGAL("pad_new"); 239 240 /* XXX DAPM really need a new SAVEt_PAD which restores all or most 241 * vars (based on flags) rather than storing vals + addresses for 242 * each individually. Also see pad_block_start. 243 * XXX DAPM Try to see whether all these conditionals are required 244 */ 245 246 /* save existing state, ... */ 247 248 if (flags & padnew_SAVE) { 249 SAVECOMPPAD(); 250 if (! (flags & padnew_CLONE)) { 251 SAVESPTR(PL_comppad_name); 252 SAVEI32(PL_padix); 253 SAVEI32(PL_comppad_name_fill); 254 SAVEI32(PL_min_intro_pending); 255 SAVEI32(PL_max_intro_pending); 256 SAVEBOOL(PL_cv_has_eval); 257 if (flags & padnew_SAVESUB) { 258 SAVEBOOL(PL_pad_reset_pending); 259 } 260 } 261 } 262 /* XXX DAPM interestingly, PL_comppad_name_floor never seems to be 263 * saved - check at some pt that this is okay */ 264 265 /* ... create new pad ... */ 266 267 Newxz(padlist, 1, PADLIST); 268 pad = newAV(); 269 270 if (flags & padnew_CLONE) { 271 /* XXX DAPM I dont know why cv_clone needs it 272 * doing differently yet - perhaps this separate branch can be 273 * dispensed with eventually ??? 274 */ 275 276 AV * const a0 = newAV(); /* will be @_ */ 277 av_store(pad, 0, MUTABLE_SV(a0)); 278 AvREIFY_only(a0); 279 280 padname = (PAD *)SvREFCNT_inc_simple_NN(PL_comppad_name); 281 } 282 else { 283 av_store(pad, 0, NULL); 284 padname = newAV(); 285 } 286 287 /* Most subroutines never recurse, hence only need 2 entries in the padlist 288 array - names, and depth=1. The default for av_store() is to allocate 289 0..3, and even an explicit call to av_extend() with <3 will be rounded 290 up, so we inline the allocation of the array here. */ 291 Newx(ary, 2, PAD *); 292 PadlistMAX(padlist) = 1; 293 PadlistARRAY(padlist) = ary; 294 ary[0] = padname; 295 ary[1] = pad; 296 297 /* ... then update state variables */ 298 299 PL_comppad = pad; 300 PL_curpad = AvARRAY(pad); 301 302 if (! (flags & padnew_CLONE)) { 303 PL_comppad_name = padname; 304 PL_comppad_name_fill = 0; 305 PL_min_intro_pending = 0; 306 PL_padix = 0; 307 PL_cv_has_eval = 0; 308 } 309 310 DEBUG_X(PerlIO_printf(Perl_debug_log, 311 "Pad 0x%"UVxf"[0x%"UVxf"] new: compcv=0x%"UVxf 312 " name=0x%"UVxf" flags=0x%"UVxf"\n", 313 PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(PL_compcv), 314 PTR2UV(padname), (UV)flags 315 ) 316 ); 317 318 return (PADLIST*)padlist; 319 } 320 321 322 /* 323 =head1 Embedding Functions 324 325 =for apidoc cv_undef 326 327 Clear out all the active components of a CV. This can happen either 328 by an explicit C<undef &foo>, or by the reference count going to zero. 329 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous 330 children can still follow the full lexical scope chain. 331 332 =cut 333 */ 334 335 void 336 Perl_cv_undef(pTHX_ CV *cv) 337 { 338 dVAR; 339 const PADLIST *padlist = CvPADLIST(cv); 340 bool const slabbed = !!CvSLABBED(cv); 341 342 PERL_ARGS_ASSERT_CV_UNDEF; 343 344 DEBUG_X(PerlIO_printf(Perl_debug_log, 345 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n", 346 PTR2UV(cv), PTR2UV(PL_comppad)) 347 ); 348 349 if (CvFILE(cv) && CvDYNFILE(cv)) { 350 Safefree(CvFILE(cv)); 351 } 352 CvFILE(cv) = NULL; 353 354 CvSLABBED_off(cv); 355 if (!CvISXSUB(cv) && CvROOT(cv)) { 356 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv)) 357 Perl_croak(aTHX_ "Can't undef active subroutine"); 358 ENTER; 359 360 PAD_SAVE_SETNULLPAD(); 361 362 if (slabbed) OpslabREFCNT_dec_padok(OpSLAB(CvROOT(cv))); 363 op_free(CvROOT(cv)); 364 CvROOT(cv) = NULL; 365 CvSTART(cv) = NULL; 366 LEAVE; 367 } 368 else if (slabbed && CvSTART(cv)) { 369 ENTER; 370 PAD_SAVE_SETNULLPAD(); 371 372 /* discard any leaked ops */ 373 if (PL_parser) 374 parser_free_nexttoke_ops(PL_parser, (OPSLAB *)CvSTART(cv)); 375 opslab_force_free((OPSLAB *)CvSTART(cv)); 376 CvSTART(cv) = NULL; 377 378 LEAVE; 379 } 380 #ifdef DEBUGGING 381 else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", cv); 382 #endif 383 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */ 384 sv_unmagic((SV *)cv, PERL_MAGIC_checkcall); 385 if (CvNAMED(cv)) CvNAME_HEK_set(cv, NULL); 386 else CvGV_set(cv, NULL); 387 388 /* This statement and the subsequence if block was pad_undef(). */ 389 pad_peg("pad_undef"); 390 391 if (padlist) { 392 I32 ix; 393 394 /* Free the padlist associated with a CV. 395 If parts of it happen to be current, we null the relevant PL_*pad* 396 global vars so that we don't have any dangling references left. 397 We also repoint the CvOUTSIDE of any about-to-be-orphaned inner 398 subs to the outer of this cv. */ 399 400 DEBUG_X(PerlIO_printf(Perl_debug_log, 401 "Pad undef: cv=0x%"UVxf" padlist=0x%"UVxf" comppad=0x%"UVxf"\n", 402 PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad)) 403 ); 404 405 /* detach any '&' anon children in the pad; if afterwards they 406 * are still live, fix up their CvOUTSIDEs to point to our outside, 407 * bypassing us. */ 408 /* XXX DAPM for efficiency, we should only do this if we know we have 409 * children, or integrate this loop with general cleanup */ 410 411 if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */ 412 CV * const outercv = CvOUTSIDE(cv); 413 const U32 seq = CvOUTSIDE_SEQ(cv); 414 PAD * const comppad_name = PadlistARRAY(padlist)[0]; 415 SV ** const namepad = AvARRAY(comppad_name); 416 PAD * const comppad = PadlistARRAY(padlist)[1]; 417 SV ** const curpad = AvARRAY(comppad); 418 for (ix = AvFILLp(comppad_name); ix > 0; ix--) { 419 SV * const namesv = namepad[ix]; 420 if (namesv && namesv != &PL_sv_undef 421 && *SvPVX_const(namesv) == '&') 422 { 423 CV * const innercv = MUTABLE_CV(curpad[ix]); 424 U32 inner_rc = SvREFCNT(innercv); 425 assert(inner_rc); 426 assert(SvTYPE(innercv) != SVt_PVFM); 427 428 if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */ 429 curpad[ix] = NULL; 430 SvREFCNT_dec_NN(innercv); 431 inner_rc--; 432 } 433 434 /* in use, not just a prototype */ 435 if (inner_rc && (CvOUTSIDE(innercv) == cv)) { 436 assert(CvWEAKOUTSIDE(innercv)); 437 /* don't relink to grandfather if he's being freed */ 438 if (outercv && SvREFCNT(outercv)) { 439 CvWEAKOUTSIDE_off(innercv); 440 CvOUTSIDE(innercv) = outercv; 441 CvOUTSIDE_SEQ(innercv) = seq; 442 SvREFCNT_inc_simple_void_NN(outercv); 443 } 444 else { 445 CvOUTSIDE(innercv) = NULL; 446 } 447 } 448 } 449 } 450 } 451 452 ix = PadlistMAX(padlist); 453 while (ix > 0) { 454 PAD * const sv = PadlistARRAY(padlist)[ix--]; 455 if (sv) { 456 if (sv == PL_comppad) { 457 PL_comppad = NULL; 458 PL_curpad = NULL; 459 } 460 SvREFCNT_dec_NN(sv); 461 } 462 } 463 { 464 PAD * const sv = PadlistARRAY(padlist)[0]; 465 if (sv == PL_comppad_name && SvREFCNT(sv) == 1) 466 PL_comppad_name = NULL; 467 SvREFCNT_dec(sv); 468 } 469 if (PadlistARRAY(padlist)) Safefree(PadlistARRAY(padlist)); 470 Safefree(padlist); 471 CvPADLIST(cv) = NULL; 472 } 473 474 475 /* remove CvOUTSIDE unless this is an undef rather than a free */ 476 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) { 477 if (!CvWEAKOUTSIDE(cv)) 478 SvREFCNT_dec(CvOUTSIDE(cv)); 479 CvOUTSIDE(cv) = NULL; 480 } 481 if (CvCONST(cv)) { 482 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr)); 483 CvCONST_off(cv); 484 } 485 if (CvISXSUB(cv) && CvXSUB(cv)) { 486 CvXSUB(cv) = NULL; 487 } 488 /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the 489 * ref status of CvOUTSIDE and CvGV, and ANON, which pp_entersub uses 490 * to choose an error message */ 491 CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON); 492 } 493 494 /* 495 =for apidoc cv_forget_slab 496 497 When a CV has a reference count on its slab (CvSLABBED), it is responsible 498 for making sure it is freed. (Hence, no two CVs should ever have a 499 reference count on the same slab.) The CV only needs to reference the slab 500 during compilation. Once it is compiled and CvROOT attached, it has 501 finished its job, so it can forget the slab. 502 503 =cut 504 */ 505 506 void 507 Perl_cv_forget_slab(pTHX_ CV *cv) 508 { 509 const bool slabbed = !!CvSLABBED(cv); 510 OPSLAB *slab = NULL; 511 512 PERL_ARGS_ASSERT_CV_FORGET_SLAB; 513 514 if (!slabbed) return; 515 516 CvSLABBED_off(cv); 517 518 if (CvROOT(cv)) slab = OpSLAB(CvROOT(cv)); 519 else if (CvSTART(cv)) slab = (OPSLAB *)CvSTART(cv); 520 #ifdef DEBUGGING 521 else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", cv); 522 #endif 523 524 if (slab) { 525 #ifdef PERL_DEBUG_READONLY_OPS 526 const size_t refcnt = slab->opslab_refcnt; 527 #endif 528 OpslabREFCNT_dec(slab); 529 #ifdef PERL_DEBUG_READONLY_OPS 530 if (refcnt > 1) Slab_to_ro(slab); 531 #endif 532 } 533 } 534 535 /* 536 =for apidoc m|PADOFFSET|pad_alloc_name|SV *namesv|U32 flags|HV *typestash|HV *ourstash 537 538 Allocates a place in the currently-compiling 539 pad (via L<perlapi/pad_alloc>) and 540 then stores a name for that entry. I<namesv> is adopted and becomes the 541 name entry; it must already contain the name string and be sufficiently 542 upgraded. I<typestash> and I<ourstash> and the C<padadd_STATE> flag get 543 added to I<namesv>. None of the other 544 processing of L<perlapi/pad_add_name_pvn> 545 is done. Returns the offset of the allocated pad slot. 546 547 =cut 548 */ 549 550 static PADOFFSET 551 S_pad_alloc_name(pTHX_ SV *namesv, U32 flags, HV *typestash, HV *ourstash) 552 { 553 dVAR; 554 const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY); 555 556 PERL_ARGS_ASSERT_PAD_ALLOC_NAME; 557 558 ASSERT_CURPAD_ACTIVE("pad_alloc_name"); 559 560 if (typestash) { 561 assert(SvTYPE(namesv) == SVt_PVMG); 562 SvPAD_TYPED_on(namesv); 563 SvSTASH_set(namesv, MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash)))); 564 } 565 if (ourstash) { 566 SvPAD_OUR_on(namesv); 567 SvOURSTASH_set(namesv, ourstash); 568 SvREFCNT_inc_simple_void_NN(ourstash); 569 } 570 else if (flags & padadd_STATE) { 571 SvPAD_STATE_on(namesv); 572 } 573 574 av_store(PL_comppad_name, offset, namesv); 575 return offset; 576 } 577 578 /* 579 =for apidoc Am|PADOFFSET|pad_add_name_pvn|const char *namepv|STRLEN namelen|U32 flags|HV *typestash|HV *ourstash 580 581 Allocates a place in the currently-compiling pad for a named lexical 582 variable. Stores the name and other metadata in the name part of the 583 pad, and makes preparations to manage the variable's lexical scoping. 584 Returns the offset of the allocated pad slot. 585 586 I<namepv>/I<namelen> specify the variable's name, including leading sigil. 587 If I<typestash> is non-null, the name is for a typed lexical, and this 588 identifies the type. If I<ourstash> is non-null, it's a lexical reference 589 to a package variable, and this identifies the package. The following 590 flags can be OR'ed together: 591 592 padadd_OUR redundantly specifies if it's a package var 593 padadd_STATE variable will retain value persistently 594 padadd_NO_DUP_CHECK skip check for lexical shadowing 595 596 =cut 597 */ 598 599 PADOFFSET 600 Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen, 601 U32 flags, HV *typestash, HV *ourstash) 602 { 603 dVAR; 604 PADOFFSET offset; 605 SV *namesv; 606 bool is_utf8; 607 608 PERL_ARGS_ASSERT_PAD_ADD_NAME_PVN; 609 610 if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK|padadd_UTF8_NAME)) 611 Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf, 612 (UV)flags); 613 614 namesv = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV); 615 616 if ((is_utf8 = ((flags & padadd_UTF8_NAME) != 0))) { 617 namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8); 618 } 619 620 sv_setpvn(namesv, namepv, namelen); 621 622 if (is_utf8) { 623 flags |= padadd_UTF8_NAME; 624 SvUTF8_on(namesv); 625 } 626 else 627 flags &= ~padadd_UTF8_NAME; 628 629 if ((flags & padadd_NO_DUP_CHECK) == 0) { 630 ENTER; 631 SAVEFREESV(namesv); /* in case of fatal warnings */ 632 /* check for duplicate declaration */ 633 pad_check_dup(namesv, flags & padadd_OUR, ourstash); 634 SvREFCNT_inc_simple_void_NN(namesv); 635 LEAVE; 636 } 637 638 offset = pad_alloc_name(namesv, flags & ~padadd_UTF8_NAME, typestash, ourstash); 639 640 /* not yet introduced */ 641 COP_SEQ_RANGE_LOW_set(namesv, PERL_PADSEQ_INTRO); 642 COP_SEQ_RANGE_HIGH_set(namesv, 0); 643 644 if (!PL_min_intro_pending) 645 PL_min_intro_pending = offset; 646 PL_max_intro_pending = offset; 647 /* if it's not a simple scalar, replace with an AV or HV */ 648 assert(SvTYPE(PL_curpad[offset]) == SVt_NULL); 649 assert(SvREFCNT(PL_curpad[offset]) == 1); 650 if (namelen != 0 && *namepv == '@') 651 sv_upgrade(PL_curpad[offset], SVt_PVAV); 652 else if (namelen != 0 && *namepv == '%') 653 sv_upgrade(PL_curpad[offset], SVt_PVHV); 654 else if (namelen != 0 && *namepv == '&') 655 sv_upgrade(PL_curpad[offset], SVt_PVCV); 656 assert(SvPADMY(PL_curpad[offset])); 657 DEBUG_Xv(PerlIO_printf(Perl_debug_log, 658 "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n", 659 (long)offset, SvPVX(namesv), 660 PTR2UV(PL_curpad[offset]))); 661 662 return offset; 663 } 664 665 /* 666 =for apidoc Am|PADOFFSET|pad_add_name_pv|const char *name|U32 flags|HV *typestash|HV *ourstash 667 668 Exactly like L</pad_add_name_pvn>, but takes a nul-terminated string 669 instead of a string/length pair. 670 671 =cut 672 */ 673 674 PADOFFSET 675 Perl_pad_add_name_pv(pTHX_ const char *name, 676 const U32 flags, HV *typestash, HV *ourstash) 677 { 678 PERL_ARGS_ASSERT_PAD_ADD_NAME_PV; 679 return pad_add_name_pvn(name, strlen(name), flags, typestash, ourstash); 680 } 681 682 /* 683 =for apidoc Am|PADOFFSET|pad_add_name_sv|SV *name|U32 flags|HV *typestash|HV *ourstash 684 685 Exactly like L</pad_add_name_pvn>, but takes the name string in the form 686 of an SV instead of a string/length pair. 687 688 =cut 689 */ 690 691 PADOFFSET 692 Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash) 693 { 694 char *namepv; 695 STRLEN namelen; 696 PERL_ARGS_ASSERT_PAD_ADD_NAME_SV; 697 namepv = SvPV(name, namelen); 698 if (SvUTF8(name)) 699 flags |= padadd_UTF8_NAME; 700 return pad_add_name_pvn(namepv, namelen, flags, typestash, ourstash); 701 } 702 703 /* 704 =for apidoc Amx|PADOFFSET|pad_alloc|I32 optype|U32 tmptype 705 706 Allocates a place in the currently-compiling pad, 707 returning the offset of the allocated pad slot. 708 No name is initially attached to the pad slot. 709 I<tmptype> is a set of flags indicating the kind of pad entry required, 710 which will be set in the value SV for the allocated pad entry: 711 712 SVs_PADMY named lexical variable ("my", "our", "state") 713 SVs_PADTMP unnamed temporary store 714 715 I<optype> should be an opcode indicating the type of operation that the 716 pad entry is to support. This doesn't affect operational semantics, 717 but is used for debugging. 718 719 =cut 720 */ 721 722 /* XXX DAPM integrate alloc(), add_name() and add_anon(), 723 * or at least rationalise ??? */ 724 725 PADOFFSET 726 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype) 727 { 728 dVAR; 729 SV *sv; 730 I32 retval; 731 732 PERL_UNUSED_ARG(optype); 733 ASSERT_CURPAD_ACTIVE("pad_alloc"); 734 735 if (AvARRAY(PL_comppad) != PL_curpad) 736 Perl_croak(aTHX_ "panic: pad_alloc, %p!=%p", 737 AvARRAY(PL_comppad), PL_curpad); 738 if (PL_pad_reset_pending) 739 pad_reset(); 740 if (tmptype & SVs_PADMY) { 741 /* For a my, simply push a null SV onto the end of PL_comppad. */ 742 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE); 743 retval = AvFILLp(PL_comppad); 744 } 745 else { 746 /* For a tmp, scan the pad from PL_padix upwards 747 * for a slot which has no name and no active value. 748 */ 749 SV * const * const names = AvARRAY(PL_comppad_name); 750 const SSize_t names_fill = AvFILLp(PL_comppad_name); 751 for (;;) { 752 /* 753 * "foreach" index vars temporarily become aliases to non-"my" 754 * values. Thus we must skip, not just pad values that are 755 * marked as current pad values, but also those with names. 756 */ 757 /* HVDS why copy to sv here? we don't seem to use it */ 758 if (++PL_padix <= names_fill && 759 (sv = names[PL_padix]) && sv != &PL_sv_undef) 760 continue; 761 sv = *av_fetch(PL_comppad, PL_padix, TRUE); 762 if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) && 763 !IS_PADGV(sv) && !IS_PADCONST(sv)) 764 break; 765 } 766 retval = PL_padix; 767 } 768 SvFLAGS(sv) |= tmptype; 769 PL_curpad = AvARRAY(PL_comppad); 770 771 DEBUG_X(PerlIO_printf(Perl_debug_log, 772 "Pad 0x%"UVxf"[0x%"UVxf"] alloc: %ld for %s\n", 773 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval, 774 PL_op_name[optype])); 775 #ifdef DEBUG_LEAKING_SCALARS 776 sv->sv_debug_optype = optype; 777 sv->sv_debug_inpad = 1; 778 #endif 779 return (PADOFFSET)retval; 780 } 781 782 /* 783 =for apidoc Am|PADOFFSET|pad_add_anon|CV *func|I32 optype 784 785 Allocates a place in the currently-compiling pad (via L</pad_alloc>) 786 for an anonymous function that is lexically scoped inside the 787 currently-compiling function. 788 The function I<func> is linked into the pad, and its C<CvOUTSIDE> link 789 to the outer scope is weakened to avoid a reference loop. 790 791 One reference count is stolen, so you may need to do C<SvREFCNT_inc(func)>. 792 793 I<optype> should be an opcode indicating the type of operation that the 794 pad entry is to support. This doesn't affect operational semantics, 795 but is used for debugging. 796 797 =cut 798 */ 799 800 PADOFFSET 801 Perl_pad_add_anon(pTHX_ CV* func, I32 optype) 802 { 803 dVAR; 804 PADOFFSET ix; 805 SV* const name = newSV_type(SVt_PVNV); 806 807 PERL_ARGS_ASSERT_PAD_ADD_ANON; 808 809 pad_peg("add_anon"); 810 sv_setpvs(name, "&"); 811 /* These two aren't used; just make sure they're not equal to 812 * PERL_PADSEQ_INTRO */ 813 COP_SEQ_RANGE_LOW_set(name, 0); 814 COP_SEQ_RANGE_HIGH_set(name, 0); 815 ix = pad_alloc(optype, SVs_PADMY); 816 av_store(PL_comppad_name, ix, name); 817 /* XXX DAPM use PL_curpad[] ? */ 818 if (SvTYPE(func) == SVt_PVCV || !CvOUTSIDE(func)) 819 av_store(PL_comppad, ix, (SV*)func); 820 else { 821 SV *rv = newRV_noinc((SV *)func); 822 sv_rvweaken(rv); 823 assert (SvTYPE(func) == SVt_PVFM); 824 av_store(PL_comppad, ix, rv); 825 } 826 SvPADMY_on((SV*)func); 827 828 /* to avoid ref loops, we never have parent + child referencing each 829 * other simultaneously */ 830 if (CvOUTSIDE(func) && SvTYPE(func) == SVt_PVCV) { 831 assert(!CvWEAKOUTSIDE(func)); 832 CvWEAKOUTSIDE_on(func); 833 SvREFCNT_dec_NN(CvOUTSIDE(func)); 834 } 835 return ix; 836 } 837 838 /* 839 =for apidoc pad_check_dup 840 841 Check for duplicate declarations: report any of: 842 843 * a my in the current scope with the same name; 844 * an our (anywhere in the pad) with the same name and the 845 same stash as C<ourstash> 846 847 C<is_our> indicates that the name to check is an 'our' declaration. 848 849 =cut 850 */ 851 852 STATIC void 853 S_pad_check_dup(pTHX_ SV *name, U32 flags, const HV *ourstash) 854 { 855 dVAR; 856 SV **svp; 857 PADOFFSET top, off; 858 const U32 is_our = flags & padadd_OUR; 859 860 PERL_ARGS_ASSERT_PAD_CHECK_DUP; 861 862 ASSERT_CURPAD_ACTIVE("pad_check_dup"); 863 864 assert((flags & ~padadd_OUR) == 0); 865 866 if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC)) 867 return; /* nothing to check */ 868 869 svp = AvARRAY(PL_comppad_name); 870 top = AvFILLp(PL_comppad_name); 871 /* check the current scope */ 872 /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same 873 * type ? */ 874 for (off = top; (I32)off > PL_comppad_name_floor; off--) { 875 SV * const sv = svp[off]; 876 if (sv 877 && sv != &PL_sv_undef 878 && !SvFAKE(sv) 879 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO 880 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO) 881 && sv_eq(name, sv)) 882 { 883 if (is_our && (SvPAD_OUR(sv))) 884 break; /* "our" masking "our" */ 885 /* diag_listed_as: "%s" variable %s masks earlier declaration in same %s */ 886 Perl_warner(aTHX_ packWARN(WARN_MISC), 887 "\"%s\" %s %"SVf" masks earlier declaration in same %s", 888 (is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"), 889 *SvPVX(sv) == '&' ? "subroutine" : "variable", 890 sv, 891 (COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO 892 ? "scope" : "statement")); 893 --off; 894 break; 895 } 896 } 897 /* check the rest of the pad */ 898 if (is_our) { 899 while (off > 0) { 900 SV * const sv = svp[off]; 901 if (sv 902 && sv != &PL_sv_undef 903 && !SvFAKE(sv) 904 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO 905 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO) 906 && SvOURSTASH(sv) == ourstash 907 && sv_eq(name, sv)) 908 { 909 Perl_warner(aTHX_ packWARN(WARN_MISC), 910 "\"our\" variable %"SVf" redeclared", sv); 911 if ((I32)off <= PL_comppad_name_floor) 912 Perl_warner(aTHX_ packWARN(WARN_MISC), 913 "\t(Did you mean \"local\" instead of \"our\"?)\n"); 914 break; 915 } 916 --off; 917 } 918 } 919 } 920 921 922 /* 923 =for apidoc Am|PADOFFSET|pad_findmy_pvn|const char *namepv|STRLEN namelen|U32 flags 924 925 Given the name of a lexical variable, find its position in the 926 currently-compiling pad. 927 I<namepv>/I<namelen> specify the variable's name, including leading sigil. 928 I<flags> is reserved and must be zero. 929 If it is not in the current pad but appears in the pad of any lexically 930 enclosing scope, then a pseudo-entry for it is added in the current pad. 931 Returns the offset in the current pad, 932 or C<NOT_IN_PAD> if no such lexical is in scope. 933 934 =cut 935 */ 936 937 PADOFFSET 938 Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags) 939 { 940 dVAR; 941 SV *out_sv; 942 int out_flags; 943 I32 offset; 944 const AV *nameav; 945 SV **name_svp; 946 947 PERL_ARGS_ASSERT_PAD_FINDMY_PVN; 948 949 pad_peg("pad_findmy_pvn"); 950 951 if (flags & ~padadd_UTF8_NAME) 952 Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf, 953 (UV)flags); 954 955 if (flags & padadd_UTF8_NAME) { 956 bool is_utf8 = TRUE; 957 namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8); 958 959 if (is_utf8) 960 flags |= padadd_UTF8_NAME; 961 else 962 flags &= ~padadd_UTF8_NAME; 963 } 964 965 offset = pad_findlex(namepv, namelen, flags, 966 PL_compcv, PL_cop_seqmax, 1, NULL, &out_sv, &out_flags); 967 if ((PADOFFSET)offset != NOT_IN_PAD) 968 return offset; 969 970 /* look for an our that's being introduced; this allows 971 * our $foo = 0 unless defined $foo; 972 * to not give a warning. (Yes, this is a hack) */ 973 974 nameav = PadlistARRAY(CvPADLIST(PL_compcv))[0]; 975 name_svp = AvARRAY(nameav); 976 for (offset = AvFILLp(nameav); offset > 0; offset--) { 977 const SV * const namesv = name_svp[offset]; 978 if (namesv && namesv != &PL_sv_undef 979 && !SvFAKE(namesv) 980 && (SvPAD_OUR(namesv)) 981 && SvCUR(namesv) == namelen 982 && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen, 983 flags & padadd_UTF8_NAME ? SVf_UTF8 : 0 ) 984 && COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO 985 ) 986 return offset; 987 } 988 return NOT_IN_PAD; 989 } 990 991 /* 992 =for apidoc Am|PADOFFSET|pad_findmy_pv|const char *name|U32 flags 993 994 Exactly like L</pad_findmy_pvn>, but takes a nul-terminated string 995 instead of a string/length pair. 996 997 =cut 998 */ 999 1000 PADOFFSET 1001 Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags) 1002 { 1003 PERL_ARGS_ASSERT_PAD_FINDMY_PV; 1004 return pad_findmy_pvn(name, strlen(name), flags); 1005 } 1006 1007 /* 1008 =for apidoc Am|PADOFFSET|pad_findmy_sv|SV *name|U32 flags 1009 1010 Exactly like L</pad_findmy_pvn>, but takes the name string in the form 1011 of an SV instead of a string/length pair. 1012 1013 =cut 1014 */ 1015 1016 PADOFFSET 1017 Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags) 1018 { 1019 char *namepv; 1020 STRLEN namelen; 1021 PERL_ARGS_ASSERT_PAD_FINDMY_SV; 1022 namepv = SvPV(name, namelen); 1023 if (SvUTF8(name)) 1024 flags |= padadd_UTF8_NAME; 1025 return pad_findmy_pvn(namepv, namelen, flags); 1026 } 1027 1028 /* 1029 =for apidoc Amp|PADOFFSET|find_rundefsvoffset 1030 1031 Find the position of the lexical C<$_> in the pad of the 1032 currently-executing function. Returns the offset in the current pad, 1033 or C<NOT_IN_PAD> if there is no lexical C<$_> in scope (in which case 1034 the global one should be used instead). 1035 L</find_rundefsv> is likely to be more convenient. 1036 1037 =cut 1038 */ 1039 1040 PADOFFSET 1041 Perl_find_rundefsvoffset(pTHX) 1042 { 1043 dVAR; 1044 SV *out_sv; 1045 int out_flags; 1046 return pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1, 1047 NULL, &out_sv, &out_flags); 1048 } 1049 1050 /* 1051 =for apidoc Am|SV *|find_rundefsv 1052 1053 Find and return the variable that is named C<$_> in the lexical scope 1054 of the currently-executing function. This may be a lexical C<$_>, 1055 or will otherwise be the global one. 1056 1057 =cut 1058 */ 1059 1060 SV * 1061 Perl_find_rundefsv(pTHX) 1062 { 1063 SV *namesv; 1064 int flags; 1065 PADOFFSET po; 1066 1067 po = pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1, 1068 NULL, &namesv, &flags); 1069 1070 if (po == NOT_IN_PAD || SvPAD_OUR(namesv)) 1071 return DEFSV; 1072 1073 return PAD_SVl(po); 1074 } 1075 1076 SV * 1077 Perl_find_rundefsv2(pTHX_ CV *cv, U32 seq) 1078 { 1079 SV *namesv; 1080 int flags; 1081 PADOFFSET po; 1082 1083 PERL_ARGS_ASSERT_FIND_RUNDEFSV2; 1084 1085 po = pad_findlex("$_", 2, 0, cv, seq, 1, 1086 NULL, &namesv, &flags); 1087 1088 if (po == NOT_IN_PAD || SvPAD_OUR(namesv)) 1089 return DEFSV; 1090 1091 return AvARRAY(PadlistARRAY(CvPADLIST(cv))[CvDEPTH(cv)])[po]; 1092 } 1093 1094 /* 1095 =for apidoc m|PADOFFSET|pad_findlex|const char *namepv|STRLEN namelen|U32 flags|const CV* cv|U32 seq|int warn|SV** out_capture|SV** out_name_sv|int *out_flags 1096 1097 Find a named lexical anywhere in a chain of nested pads. Add fake entries 1098 in the inner pads if it's found in an outer one. 1099 1100 Returns the offset in the bottom pad of the lex or the fake lex. 1101 cv is the CV in which to start the search, and seq is the current cop_seq 1102 to match against. If warn is true, print appropriate warnings. The out_* 1103 vars return values, and so are pointers to where the returned values 1104 should be stored. out_capture, if non-null, requests that the innermost 1105 instance of the lexical is captured; out_name_sv is set to the innermost 1106 matched namesv or fake namesv; out_flags returns the flags normally 1107 associated with the IVX field of a fake namesv. 1108 1109 Note that pad_findlex() is recursive; it recurses up the chain of CVs, 1110 then comes back down, adding fake entries as it goes. It has to be this way 1111 because fake namesvs in anon protoypes have to store in xlow the index into 1112 the parent pad. 1113 1114 =cut 1115 */ 1116 1117 /* the CV has finished being compiled. This is not a sufficient test for 1118 * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */ 1119 #define CvCOMPILED(cv) CvROOT(cv) 1120 1121 /* the CV does late binding of its lexicals */ 1122 #define CvLATE(cv) (CvANON(cv) || CvCLONE(cv) || SvTYPE(cv) == SVt_PVFM) 1123 1124 static void 1125 S_unavailable(pTHX_ SV *namesv) 1126 { 1127 /* diag_listed_as: Variable "%s" is not available */ 1128 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE), 1129 "%se \"%"SVf"\" is not available", 1130 *SvPVX_const(namesv) == '&' 1131 ? "Subroutin" 1132 : "Variabl", 1133 namesv); 1134 } 1135 1136 STATIC PADOFFSET 1137 S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq, 1138 int warn, SV** out_capture, SV** out_name_sv, int *out_flags) 1139 { 1140 dVAR; 1141 I32 offset, new_offset; 1142 SV *new_capture; 1143 SV **new_capturep; 1144 const PADLIST * const padlist = CvPADLIST(cv); 1145 const bool staleok = !!(flags & padadd_STALEOK); 1146 1147 PERL_ARGS_ASSERT_PAD_FINDLEX; 1148 1149 if (flags & ~(padadd_UTF8_NAME|padadd_STALEOK)) 1150 Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf, 1151 (UV)flags); 1152 flags &= ~ padadd_STALEOK; /* one-shot flag */ 1153 1154 *out_flags = 0; 1155 1156 DEBUG_Xv(PerlIO_printf(Perl_debug_log, 1157 "Pad findlex cv=0x%"UVxf" searching \"%.*s\" seq=%d%s\n", 1158 PTR2UV(cv), (int)namelen, namepv, (int)seq, 1159 out_capture ? " capturing" : "" )); 1160 1161 /* first, search this pad */ 1162 1163 if (padlist) { /* not an undef CV */ 1164 I32 fake_offset = 0; 1165 const AV * const nameav = PadlistARRAY(padlist)[0]; 1166 SV * const * const name_svp = AvARRAY(nameav); 1167 1168 for (offset = AvFILLp(nameav); offset > 0; offset--) { 1169 const SV * const namesv = name_svp[offset]; 1170 if (namesv && namesv != &PL_sv_undef 1171 && SvCUR(namesv) == namelen 1172 && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen, 1173 flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)) 1174 { 1175 if (SvFAKE(namesv)) { 1176 fake_offset = offset; /* in case we don't find a real one */ 1177 continue; 1178 } 1179 /* is seq within the range _LOW to _HIGH ? 1180 * This is complicated by the fact that PL_cop_seqmax 1181 * may have wrapped around at some point */ 1182 if (COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO) 1183 continue; /* not yet introduced */ 1184 1185 if (COP_SEQ_RANGE_HIGH(namesv) == PERL_PADSEQ_INTRO) { 1186 /* in compiling scope */ 1187 if ( 1188 (seq > COP_SEQ_RANGE_LOW(namesv)) 1189 ? (seq - COP_SEQ_RANGE_LOW(namesv) < (U32_MAX >> 1)) 1190 : (COP_SEQ_RANGE_LOW(namesv) - seq > (U32_MAX >> 1)) 1191 ) 1192 break; 1193 } 1194 else if ( 1195 (COP_SEQ_RANGE_LOW(namesv) > COP_SEQ_RANGE_HIGH(namesv)) 1196 ? 1197 ( seq > COP_SEQ_RANGE_LOW(namesv) 1198 || seq <= COP_SEQ_RANGE_HIGH(namesv)) 1199 1200 : ( seq > COP_SEQ_RANGE_LOW(namesv) 1201 && seq <= COP_SEQ_RANGE_HIGH(namesv)) 1202 ) 1203 break; 1204 } 1205 } 1206 1207 if (offset > 0 || fake_offset > 0 ) { /* a match! */ 1208 if (offset > 0) { /* not fake */ 1209 fake_offset = 0; 1210 *out_name_sv = name_svp[offset]; /* return the namesv */ 1211 1212 /* set PAD_FAKELEX_MULTI if this lex can have multiple 1213 * instances. For now, we just test !CvUNIQUE(cv), but 1214 * ideally, we should detect my's declared within loops 1215 * etc - this would allow a wider range of 'not stayed 1216 * shared' warnings. We also treated already-compiled 1217 * lexes as not multi as viewed from evals. */ 1218 1219 *out_flags = CvANON(cv) ? 1220 PAD_FAKELEX_ANON : 1221 (!CvUNIQUE(cv) && ! CvCOMPILED(cv)) 1222 ? PAD_FAKELEX_MULTI : 0; 1223 1224 DEBUG_Xv(PerlIO_printf(Perl_debug_log, 1225 "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n", 1226 PTR2UV(cv), (long)offset, 1227 (unsigned long)COP_SEQ_RANGE_LOW(*out_name_sv), 1228 (unsigned long)COP_SEQ_RANGE_HIGH(*out_name_sv))); 1229 } 1230 else { /* fake match */ 1231 offset = fake_offset; 1232 *out_name_sv = name_svp[offset]; /* return the namesv */ 1233 *out_flags = PARENT_FAKELEX_FLAGS(*out_name_sv); 1234 DEBUG_Xv(PerlIO_printf(Perl_debug_log, 1235 "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n", 1236 PTR2UV(cv), (long)offset, (unsigned long)*out_flags, 1237 (unsigned long) PARENT_PAD_INDEX(*out_name_sv) 1238 )); 1239 } 1240 1241 /* return the lex? */ 1242 1243 if (out_capture) { 1244 1245 /* our ? */ 1246 if (SvPAD_OUR(*out_name_sv)) { 1247 *out_capture = NULL; 1248 return offset; 1249 } 1250 1251 /* trying to capture from an anon prototype? */ 1252 if (CvCOMPILED(cv) 1253 ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv) 1254 : *out_flags & PAD_FAKELEX_ANON) 1255 { 1256 if (warn) 1257 S_unavailable(aTHX_ 1258 newSVpvn_flags(namepv, namelen, 1259 SVs_TEMP | 1260 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))); 1261 1262 *out_capture = NULL; 1263 } 1264 1265 /* real value */ 1266 else { 1267 int newwarn = warn; 1268 if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI) 1269 && !SvPAD_STATE(name_svp[offset]) 1270 && warn && ckWARN(WARN_CLOSURE)) { 1271 newwarn = 0; 1272 Perl_warner(aTHX_ packWARN(WARN_CLOSURE), 1273 "Variable \"%"SVf"\" will not stay shared", 1274 newSVpvn_flags(namepv, namelen, 1275 SVs_TEMP | 1276 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))); 1277 } 1278 1279 if (fake_offset && CvANON(cv) 1280 && CvCLONE(cv) &&!CvCLONED(cv)) 1281 { 1282 SV *n; 1283 /* not yet caught - look further up */ 1284 DEBUG_Xv(PerlIO_printf(Perl_debug_log, 1285 "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n", 1286 PTR2UV(cv))); 1287 n = *out_name_sv; 1288 (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv), 1289 CvOUTSIDE_SEQ(cv), 1290 newwarn, out_capture, out_name_sv, out_flags); 1291 *out_name_sv = n; 1292 return offset; 1293 } 1294 1295 *out_capture = AvARRAY(PadlistARRAY(padlist)[ 1296 CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset]; 1297 DEBUG_Xv(PerlIO_printf(Perl_debug_log, 1298 "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n", 1299 PTR2UV(cv), PTR2UV(*out_capture))); 1300 1301 if (SvPADSTALE(*out_capture) 1302 && (!CvDEPTH(cv) || !staleok) 1303 && !SvPAD_STATE(name_svp[offset])) 1304 { 1305 S_unavailable(aTHX_ 1306 newSVpvn_flags(namepv, namelen, 1307 SVs_TEMP | 1308 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))); 1309 *out_capture = NULL; 1310 } 1311 } 1312 if (!*out_capture) { 1313 if (namelen != 0 && *namepv == '@') 1314 *out_capture = sv_2mortal(MUTABLE_SV(newAV())); 1315 else if (namelen != 0 && *namepv == '%') 1316 *out_capture = sv_2mortal(MUTABLE_SV(newHV())); 1317 else if (namelen != 0 && *namepv == '&') 1318 *out_capture = sv_2mortal(newSV_type(SVt_PVCV)); 1319 else 1320 *out_capture = sv_newmortal(); 1321 } 1322 } 1323 1324 return offset; 1325 } 1326 } 1327 1328 /* it's not in this pad - try above */ 1329 1330 if (!CvOUTSIDE(cv)) 1331 return NOT_IN_PAD; 1332 1333 /* out_capture non-null means caller wants us to capture lex; in 1334 * addition we capture ourselves unless it's an ANON/format */ 1335 new_capturep = out_capture ? out_capture : 1336 CvLATE(cv) ? NULL : &new_capture; 1337 1338 offset = pad_findlex(namepv, namelen, 1339 flags | padadd_STALEOK*(new_capturep == &new_capture), 1340 CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1, 1341 new_capturep, out_name_sv, out_flags); 1342 if ((PADOFFSET)offset == NOT_IN_PAD) 1343 return NOT_IN_PAD; 1344 1345 /* found in an outer CV. Add appropriate fake entry to this pad */ 1346 1347 /* don't add new fake entries (via eval) to CVs that we have already 1348 * finished compiling, or to undef CVs */ 1349 if (CvCOMPILED(cv) || !padlist) 1350 return 0; /* this dummy (and invalid) value isnt used by the caller */ 1351 1352 { 1353 /* This relies on sv_setsv_flags() upgrading the destination to the same 1354 type as the source, independent of the flags set, and on it being 1355 "good" and only copying flag bits and pointers that it understands. 1356 */ 1357 SV *new_namesv = newSVsv(*out_name_sv); 1358 AV * const ocomppad_name = PL_comppad_name; 1359 PAD * const ocomppad = PL_comppad; 1360 PL_comppad_name = PadlistARRAY(padlist)[0]; 1361 PL_comppad = PadlistARRAY(padlist)[1]; 1362 PL_curpad = AvARRAY(PL_comppad); 1363 1364 new_offset 1365 = pad_alloc_name(new_namesv, 1366 (SvPAD_STATE(*out_name_sv) ? padadd_STATE : 0), 1367 SvPAD_TYPED(*out_name_sv) 1368 ? SvSTASH(*out_name_sv) : NULL, 1369 SvOURSTASH(*out_name_sv) 1370 ); 1371 1372 SvFAKE_on(new_namesv); 1373 DEBUG_Xv(PerlIO_printf(Perl_debug_log, 1374 "Pad addname: %ld \"%.*s\" FAKE\n", 1375 (long)new_offset, 1376 (int) SvCUR(new_namesv), SvPVX(new_namesv))); 1377 PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags); 1378 1379 PARENT_PAD_INDEX_set(new_namesv, 0); 1380 if (SvPAD_OUR(new_namesv)) { 1381 NOOP; /* do nothing */ 1382 } 1383 else if (CvLATE(cv)) { 1384 /* delayed creation - just note the offset within parent pad */ 1385 PARENT_PAD_INDEX_set(new_namesv, offset); 1386 CvCLONE_on(cv); 1387 } 1388 else { 1389 /* immediate creation - capture outer value right now */ 1390 av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep)); 1391 /* But also note the offset, as newMYSUB needs it */ 1392 PARENT_PAD_INDEX_set(new_namesv, offset); 1393 DEBUG_Xv(PerlIO_printf(Perl_debug_log, 1394 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n", 1395 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset)); 1396 } 1397 *out_name_sv = new_namesv; 1398 *out_flags = PARENT_FAKELEX_FLAGS(new_namesv); 1399 1400 PL_comppad_name = ocomppad_name; 1401 PL_comppad = ocomppad; 1402 PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL; 1403 } 1404 return new_offset; 1405 } 1406 1407 #ifdef DEBUGGING 1408 1409 /* 1410 =for apidoc Am|SV *|pad_sv|PADOFFSET po 1411 1412 Get the value at offset I<po> in the current (compiling or executing) pad. 1413 Use macro PAD_SV instead of calling this function directly. 1414 1415 =cut 1416 */ 1417 1418 SV * 1419 Perl_pad_sv(pTHX_ PADOFFSET po) 1420 { 1421 dVAR; 1422 ASSERT_CURPAD_ACTIVE("pad_sv"); 1423 1424 if (!po) 1425 Perl_croak(aTHX_ "panic: pad_sv po"); 1426 DEBUG_X(PerlIO_printf(Perl_debug_log, 1427 "Pad 0x%"UVxf"[0x%"UVxf"] sv: %ld sv=0x%"UVxf"\n", 1428 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po])) 1429 ); 1430 return PL_curpad[po]; 1431 } 1432 1433 /* 1434 =for apidoc Am|void|pad_setsv|PADOFFSET po|SV *sv 1435 1436 Set the value at offset I<po> in the current (compiling or executing) pad. 1437 Use the macro PAD_SETSV() rather than calling this function directly. 1438 1439 =cut 1440 */ 1441 1442 void 1443 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv) 1444 { 1445 dVAR; 1446 1447 PERL_ARGS_ASSERT_PAD_SETSV; 1448 1449 ASSERT_CURPAD_ACTIVE("pad_setsv"); 1450 1451 DEBUG_X(PerlIO_printf(Perl_debug_log, 1452 "Pad 0x%"UVxf"[0x%"UVxf"] setsv: %ld sv=0x%"UVxf"\n", 1453 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv)) 1454 ); 1455 PL_curpad[po] = sv; 1456 } 1457 1458 #endif /* DEBUGGING */ 1459 1460 /* 1461 =for apidoc m|void|pad_block_start|int full 1462 1463 Update the pad compilation state variables on entry to a new block. 1464 1465 =cut 1466 */ 1467 1468 /* XXX DAPM perhaps: 1469 * - integrate this in general state-saving routine ??? 1470 * - combine with the state-saving going on in pad_new ??? 1471 * - introduce a new SAVE type that does all this in one go ? 1472 */ 1473 1474 void 1475 Perl_pad_block_start(pTHX_ int full) 1476 { 1477 dVAR; 1478 ASSERT_CURPAD_ACTIVE("pad_block_start"); 1479 SAVEI32(PL_comppad_name_floor); 1480 PL_comppad_name_floor = AvFILLp(PL_comppad_name); 1481 if (full) 1482 PL_comppad_name_fill = PL_comppad_name_floor; 1483 if (PL_comppad_name_floor < 0) 1484 PL_comppad_name_floor = 0; 1485 SAVEI32(PL_min_intro_pending); 1486 SAVEI32(PL_max_intro_pending); 1487 PL_min_intro_pending = 0; 1488 SAVEI32(PL_comppad_name_fill); 1489 SAVEI32(PL_padix_floor); 1490 PL_padix_floor = PL_padix; 1491 PL_pad_reset_pending = FALSE; 1492 } 1493 1494 /* 1495 =for apidoc m|U32|intro_my 1496 1497 "Introduce" my variables to visible status. This is called during parsing 1498 at the end of each statement to make lexical variables visible to 1499 subsequent statements. 1500 1501 =cut 1502 */ 1503 1504 U32 1505 Perl_intro_my(pTHX) 1506 { 1507 dVAR; 1508 SV **svp; 1509 I32 i; 1510 U32 seq; 1511 1512 ASSERT_CURPAD_ACTIVE("intro_my"); 1513 if (! PL_min_intro_pending) 1514 return PL_cop_seqmax; 1515 1516 svp = AvARRAY(PL_comppad_name); 1517 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) { 1518 SV * const sv = svp[i]; 1519 1520 if (sv && sv != &PL_sv_undef && !SvFAKE(sv) 1521 && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO) 1522 { 1523 COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */ 1524 COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax); 1525 DEBUG_Xv(PerlIO_printf(Perl_debug_log, 1526 "Pad intromy: %ld \"%s\", (%lu,%lu)\n", 1527 (long)i, SvPVX_const(sv), 1528 (unsigned long)COP_SEQ_RANGE_LOW(sv), 1529 (unsigned long)COP_SEQ_RANGE_HIGH(sv)) 1530 ); 1531 } 1532 } 1533 seq = PL_cop_seqmax; 1534 PL_cop_seqmax++; 1535 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */ 1536 PL_cop_seqmax++; 1537 PL_min_intro_pending = 0; 1538 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */ 1539 DEBUG_Xv(PerlIO_printf(Perl_debug_log, 1540 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax))); 1541 1542 return seq; 1543 } 1544 1545 /* 1546 =for apidoc m|void|pad_leavemy 1547 1548 Cleanup at end of scope during compilation: set the max seq number for 1549 lexicals in this scope and warn of any lexicals that never got introduced. 1550 1551 =cut 1552 */ 1553 1554 OP * 1555 Perl_pad_leavemy(pTHX) 1556 { 1557 dVAR; 1558 I32 off; 1559 OP *o = NULL; 1560 SV * const * const svp = AvARRAY(PL_comppad_name); 1561 1562 PL_pad_reset_pending = FALSE; 1563 1564 ASSERT_CURPAD_ACTIVE("pad_leavemy"); 1565 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) { 1566 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) { 1567 const SV * const sv = svp[off]; 1568 if (sv && sv != &PL_sv_undef && !SvFAKE(sv)) 1569 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), 1570 "%"SVf" never introduced", 1571 SVfARG(sv)); 1572 } 1573 } 1574 /* "Deintroduce" my variables that are leaving with this scope. */ 1575 for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) { 1576 SV * const sv = svp[off]; 1577 if (sv && sv != &PL_sv_undef && !SvFAKE(sv) 1578 && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO) 1579 { 1580 COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax); 1581 DEBUG_Xv(PerlIO_printf(Perl_debug_log, 1582 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n", 1583 (long)off, SvPVX_const(sv), 1584 (unsigned long)COP_SEQ_RANGE_LOW(sv), 1585 (unsigned long)COP_SEQ_RANGE_HIGH(sv)) 1586 ); 1587 if (!PadnameIsSTATE(sv) && !PadnameIsOUR(sv) 1588 && *PadnamePV(sv) == '&' && PadnameLEN(sv) > 1) { 1589 OP *kid = newOP(OP_INTROCV, 0); 1590 kid->op_targ = off; 1591 o = op_prepend_elem(OP_LINESEQ, kid, o); 1592 } 1593 } 1594 } 1595 PL_cop_seqmax++; 1596 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */ 1597 PL_cop_seqmax++; 1598 DEBUG_Xv(PerlIO_printf(Perl_debug_log, 1599 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax)); 1600 return o; 1601 } 1602 1603 /* 1604 =for apidoc m|void|pad_swipe|PADOFFSET po|bool refadjust 1605 1606 Abandon the tmp in the current pad at offset po and replace with a 1607 new one. 1608 1609 =cut 1610 */ 1611 1612 void 1613 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust) 1614 { 1615 dVAR; 1616 ASSERT_CURPAD_LEGAL("pad_swipe"); 1617 if (!PL_curpad) 1618 return; 1619 if (AvARRAY(PL_comppad) != PL_curpad) 1620 Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p", 1621 AvARRAY(PL_comppad), PL_curpad); 1622 if (!po || ((SSize_t)po) > AvFILLp(PL_comppad)) 1623 Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld", 1624 (long)po, (long)AvFILLp(PL_comppad)); 1625 1626 DEBUG_X(PerlIO_printf(Perl_debug_log, 1627 "Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n", 1628 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)); 1629 1630 if (PL_curpad[po]) 1631 SvPADTMP_off(PL_curpad[po]); 1632 if (refadjust) 1633 SvREFCNT_dec(PL_curpad[po]); 1634 1635 1636 /* if pad tmps aren't shared between ops, then there's no need to 1637 * create a new tmp when an existing op is freed */ 1638 #ifdef USE_BROKEN_PAD_RESET 1639 PL_curpad[po] = newSV(0); 1640 SvPADTMP_on(PL_curpad[po]); 1641 #else 1642 PL_curpad[po] = &PL_sv_undef; 1643 #endif 1644 if ((I32)po < PL_padix) 1645 PL_padix = po - 1; 1646 } 1647 1648 /* 1649 =for apidoc m|void|pad_reset 1650 1651 Mark all the current temporaries for reuse 1652 1653 =cut 1654 */ 1655 1656 /* XXX pad_reset() is currently disabled because it results in serious bugs. 1657 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed 1658 * on the stack by OPs that use them, there are several ways to get an alias 1659 * to a shared TARG. Such an alias will change randomly and unpredictably. 1660 * We avoid doing this until we can think of a Better Way. 1661 * GSAR 97-10-29 */ 1662 static void 1663 S_pad_reset(pTHX) 1664 { 1665 dVAR; 1666 #ifdef USE_BROKEN_PAD_RESET 1667 if (AvARRAY(PL_comppad) != PL_curpad) 1668 Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p", 1669 AvARRAY(PL_comppad), PL_curpad); 1670 1671 DEBUG_X(PerlIO_printf(Perl_debug_log, 1672 "Pad 0x%"UVxf"[0x%"UVxf"] reset: padix %ld -> %ld", 1673 PTR2UV(PL_comppad), PTR2UV(PL_curpad), 1674 (long)PL_padix, (long)PL_padix_floor 1675 ) 1676 ); 1677 1678 if (!TAINTING_get) { /* Can't mix tainted and non-tainted temporaries. */ 1679 I32 po; 1680 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) { 1681 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po])) 1682 SvPADTMP_off(PL_curpad[po]); 1683 } 1684 PL_padix = PL_padix_floor; 1685 } 1686 #endif 1687 PL_pad_reset_pending = FALSE; 1688 } 1689 1690 /* 1691 =for apidoc Amx|void|pad_tidy|padtidy_type type 1692 1693 Tidy up a pad at the end of compilation of the code to which it belongs. 1694 Jobs performed here are: remove most stuff from the pads of anonsub 1695 prototypes; give it a @_; mark temporaries as such. I<type> indicates 1696 the kind of subroutine: 1697 1698 padtidy_SUB ordinary subroutine 1699 padtidy_SUBCLONE prototype for lexical closure 1700 padtidy_FORMAT format 1701 1702 =cut 1703 */ 1704 1705 /* XXX DAPM surely most of this stuff should be done properly 1706 * at the right time beforehand, rather than going around afterwards 1707 * cleaning up our mistakes ??? 1708 */ 1709 1710 void 1711 Perl_pad_tidy(pTHX_ padtidy_type type) 1712 { 1713 dVAR; 1714 1715 ASSERT_CURPAD_ACTIVE("pad_tidy"); 1716 1717 /* If this CV has had any 'eval-capable' ops planted in it: 1718 * i.e. it contains any of: 1719 * 1720 * * eval '...', 1721 * * //ee, 1722 * * use re 'eval'; /$var/ 1723 * * /(?{..})/), 1724 * 1725 * Then any anon prototypes in the chain of CVs should be marked as 1726 * cloneable, so that for example the eval's CV in 1727 * 1728 * sub { eval '$x' } 1729 * 1730 * gets the right CvOUTSIDE. If running with -d, *any* sub may 1731 * potentially have an eval executed within it. 1732 */ 1733 1734 if (PL_cv_has_eval || PL_perldb) { 1735 const CV *cv; 1736 for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) { 1737 if (cv != PL_compcv && CvCOMPILED(cv)) 1738 break; /* no need to mark already-compiled code */ 1739 if (CvANON(cv)) { 1740 DEBUG_Xv(PerlIO_printf(Perl_debug_log, 1741 "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv))); 1742 CvCLONE_on(cv); 1743 } 1744 CvHASEVAL_on(cv); 1745 } 1746 } 1747 1748 /* extend curpad to match namepad */ 1749 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad)) 1750 av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL); 1751 1752 if (type == padtidy_SUBCLONE) { 1753 SV * const * const namep = AvARRAY(PL_comppad_name); 1754 PADOFFSET ix; 1755 1756 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) { 1757 SV *namesv; 1758 1759 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix])) 1760 continue; 1761 /* 1762 * The only things that a clonable function needs in its 1763 * pad are anonymous subs. 1764 * The rest are created anew during cloning. 1765 */ 1766 if (!((namesv = namep[ix]) != NULL && 1767 namesv != &PL_sv_undef && 1768 *SvPVX_const(namesv) == '&')) 1769 { 1770 SvREFCNT_dec(PL_curpad[ix]); 1771 PL_curpad[ix] = NULL; 1772 } 1773 } 1774 } 1775 else if (type == padtidy_SUB) { 1776 /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */ 1777 AV * const av = newAV(); /* Will be @_ */ 1778 av_store(PL_comppad, 0, MUTABLE_SV(av)); 1779 AvREIFY_only(av); 1780 } 1781 1782 if (type == padtidy_SUB || type == padtidy_FORMAT) { 1783 SV * const * const namep = AvARRAY(PL_comppad_name); 1784 PADOFFSET ix; 1785 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) { 1786 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix])) 1787 continue; 1788 if (!SvPADMY(PL_curpad[ix])) { 1789 SvPADTMP_on(PL_curpad[ix]); 1790 } else if (!SvFAKE(namep[ix])) { 1791 /* This is a work around for how the current implementation of 1792 ?{ } blocks in regexps interacts with lexicals. 1793 1794 One of our lexicals. 1795 Can't do this on all lexicals, otherwise sub baz() won't 1796 compile in 1797 1798 my $foo; 1799 1800 sub bar { ++$foo; } 1801 1802 sub baz { ++$foo; } 1803 1804 because completion of compiling &bar calling pad_tidy() 1805 would cause (top level) $foo to be marked as stale, and 1806 "no longer available". */ 1807 SvPADSTALE_on(PL_curpad[ix]); 1808 } 1809 } 1810 } 1811 PL_curpad = AvARRAY(PL_comppad); 1812 } 1813 1814 /* 1815 =for apidoc m|void|pad_free|PADOFFSET po 1816 1817 Free the SV at offset po in the current pad. 1818 1819 =cut 1820 */ 1821 1822 /* XXX DAPM integrate with pad_swipe ???? */ 1823 void 1824 Perl_pad_free(pTHX_ PADOFFSET po) 1825 { 1826 dVAR; 1827 SV *sv; 1828 ASSERT_CURPAD_LEGAL("pad_free"); 1829 if (!PL_curpad) 1830 return; 1831 if (AvARRAY(PL_comppad) != PL_curpad) 1832 Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p", 1833 AvARRAY(PL_comppad), PL_curpad); 1834 if (!po) 1835 Perl_croak(aTHX_ "panic: pad_free po"); 1836 1837 DEBUG_X(PerlIO_printf(Perl_debug_log, 1838 "Pad 0x%"UVxf"[0x%"UVxf"] free: %ld\n", 1839 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po) 1840 ); 1841 1842 1843 sv = PL_curpad[po]; 1844 if (sv && sv != &PL_sv_undef && !SvPADMY(sv)) 1845 SvFLAGS(sv) &= ~SVs_PADTMP; 1846 1847 if ((I32)po < PL_padix) 1848 PL_padix = po - 1; 1849 } 1850 1851 /* 1852 =for apidoc m|void|do_dump_pad|I32 level|PerlIO *file|PADLIST *padlist|int full 1853 1854 Dump the contents of a padlist 1855 1856 =cut 1857 */ 1858 1859 void 1860 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full) 1861 { 1862 dVAR; 1863 const AV *pad_name; 1864 const AV *pad; 1865 SV **pname; 1866 SV **ppad; 1867 I32 ix; 1868 1869 PERL_ARGS_ASSERT_DO_DUMP_PAD; 1870 1871 if (!padlist) { 1872 return; 1873 } 1874 pad_name = *PadlistARRAY(padlist); 1875 pad = PadlistARRAY(padlist)[1]; 1876 pname = AvARRAY(pad_name); 1877 ppad = AvARRAY(pad); 1878 Perl_dump_indent(aTHX_ level, file, 1879 "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n", 1880 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad) 1881 ); 1882 1883 for (ix = 1; ix <= AvFILLp(pad_name); ix++) { 1884 const SV *namesv = pname[ix]; 1885 if (namesv && namesv == &PL_sv_undef) { 1886 namesv = NULL; 1887 } 1888 if (namesv) { 1889 if (SvFAKE(namesv)) 1890 Perl_dump_indent(aTHX_ level+1, file, 1891 "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n", 1892 (int) ix, 1893 PTR2UV(ppad[ix]), 1894 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0), 1895 SvPVX_const(namesv), 1896 (unsigned long)PARENT_FAKELEX_FLAGS(namesv), 1897 (unsigned long)PARENT_PAD_INDEX(namesv) 1898 1899 ); 1900 else 1901 Perl_dump_indent(aTHX_ level+1, file, 1902 "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n", 1903 (int) ix, 1904 PTR2UV(ppad[ix]), 1905 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0), 1906 (unsigned long)COP_SEQ_RANGE_LOW(namesv), 1907 (unsigned long)COP_SEQ_RANGE_HIGH(namesv), 1908 SvPVX_const(namesv) 1909 ); 1910 } 1911 else if (full) { 1912 Perl_dump_indent(aTHX_ level+1, file, 1913 "%2d. 0x%"UVxf"<%lu>\n", 1914 (int) ix, 1915 PTR2UV(ppad[ix]), 1916 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0) 1917 ); 1918 } 1919 } 1920 } 1921 1922 #ifdef DEBUGGING 1923 1924 /* 1925 =for apidoc m|void|cv_dump|CV *cv|const char *title 1926 1927 dump the contents of a CV 1928 1929 =cut 1930 */ 1931 1932 STATIC void 1933 S_cv_dump(pTHX_ const CV *cv, const char *title) 1934 { 1935 dVAR; 1936 const CV * const outside = CvOUTSIDE(cv); 1937 PADLIST* const padlist = CvPADLIST(cv); 1938 1939 PERL_ARGS_ASSERT_CV_DUMP; 1940 1941 PerlIO_printf(Perl_debug_log, 1942 " %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n", 1943 title, 1944 PTR2UV(cv), 1945 (CvANON(cv) ? "ANON" 1946 : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT" 1947 : (cv == PL_main_cv) ? "MAIN" 1948 : CvUNIQUE(cv) ? "UNIQUE" 1949 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"), 1950 PTR2UV(outside), 1951 (!outside ? "null" 1952 : CvANON(outside) ? "ANON" 1953 : (outside == PL_main_cv) ? "MAIN" 1954 : CvUNIQUE(outside) ? "UNIQUE" 1955 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED")); 1956 1957 PerlIO_printf(Perl_debug_log, 1958 " PADLIST = 0x%"UVxf"\n", PTR2UV(padlist)); 1959 do_dump_pad(1, Perl_debug_log, padlist, 1); 1960 } 1961 1962 #endif /* DEBUGGING */ 1963 1964 /* 1965 =for apidoc Am|CV *|cv_clone|CV *proto 1966 1967 Clone a CV, making a lexical closure. I<proto> supplies the prototype 1968 of the function: its code, pad structure, and other attributes. 1969 The prototype is combined with a capture of outer lexicals to which the 1970 code refers, which are taken from the currently-executing instance of 1971 the immediately surrounding code. 1972 1973 =cut 1974 */ 1975 1976 static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside); 1977 1978 static void 1979 S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv) 1980 { 1981 dVAR; 1982 I32 ix; 1983 PADLIST* const protopadlist = CvPADLIST(proto); 1984 PAD *const protopad_name = *PadlistARRAY(protopadlist); 1985 const PAD *const protopad = PadlistARRAY(protopadlist)[1]; 1986 SV** const pname = AvARRAY(protopad_name); 1987 SV** const ppad = AvARRAY(protopad); 1988 const I32 fname = AvFILLp(protopad_name); 1989 const I32 fpad = AvFILLp(protopad); 1990 SV** outpad; 1991 long depth; 1992 bool subclones = FALSE; 1993 1994 assert(!CvUNIQUE(proto)); 1995 1996 /* Anonymous subs have a weak CvOUTSIDE pointer, so its value is not 1997 * reliable. The currently-running sub is always the one we need to 1998 * close over. 1999 * For my subs, the currently-running sub may not be the one we want. 2000 * We have to check whether it is a clone of CvOUTSIDE. 2001 * Note that in general for formats, CvOUTSIDE != find_runcv. 2002 * Since formats may be nested inside closures, CvOUTSIDE may point 2003 * to a prototype; we instead want the cloned parent who called us. 2004 */ 2005 2006 if (!outside) { 2007 if (CvWEAKOUTSIDE(proto)) 2008 outside = find_runcv(NULL); 2009 else { 2010 outside = CvOUTSIDE(proto); 2011 if ((CvCLONE(outside) && ! CvCLONED(outside)) 2012 || !CvPADLIST(outside) 2013 || PadlistNAMES(CvPADLIST(outside)) 2014 != protopadlist->xpadl_outid) { 2015 outside = find_runcv_where( 2016 FIND_RUNCV_padid_eq, PTR2IV(protopadlist->xpadl_outid), NULL 2017 ); 2018 /* outside could be null */ 2019 } 2020 } 2021 } 2022 depth = outside ? CvDEPTH(outside) : 0; 2023 if (!depth) 2024 depth = 1; 2025 2026 ENTER; 2027 SAVESPTR(PL_compcv); 2028 PL_compcv = cv; 2029 if (newcv) SAVEFREESV(cv); /* in case of fatal warnings */ 2030 2031 if (CvHASEVAL(cv)) 2032 CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside)); 2033 2034 SAVESPTR(PL_comppad_name); 2035 PL_comppad_name = protopad_name; 2036 CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE); 2037 2038 av_fill(PL_comppad, fpad); 2039 2040 PL_curpad = AvARRAY(PL_comppad); 2041 2042 outpad = outside && CvPADLIST(outside) 2043 ? AvARRAY(PadlistARRAY(CvPADLIST(outside))[depth]) 2044 : NULL; 2045 if (outpad) 2046 CvPADLIST(cv)->xpadl_outid = PadlistNAMES(CvPADLIST(outside)); 2047 2048 for (ix = fpad; ix > 0; ix--) { 2049 SV* const namesv = (ix <= fname) ? pname[ix] : NULL; 2050 SV *sv = NULL; 2051 if (namesv && namesv != &PL_sv_undef) { /* lexical */ 2052 if (SvFAKE(namesv)) { /* lexical from outside? */ 2053 /* formats may have an inactive, or even undefined, parent; 2054 but state vars are always available. */ 2055 if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)]) 2056 || ( SvPADSTALE(sv) && !SvPAD_STATE(namesv) 2057 && (!outside || !CvDEPTH(outside))) ) { 2058 S_unavailable(aTHX_ namesv); 2059 sv = NULL; 2060 } 2061 else 2062 SvREFCNT_inc_simple_void_NN(sv); 2063 } 2064 if (!sv) { 2065 const char sigil = SvPVX_const(namesv)[0]; 2066 if (sigil == '&') 2067 /* If there are state subs, we need to clone them, too. 2068 But they may need to close over variables we have 2069 not cloned yet. So we will have to do a second 2070 pass. Furthermore, there may be state subs clos- 2071 ing over other state subs’ entries, so we have 2072 to put a stub here and then clone into it on the 2073 second pass. */ 2074 if (SvPAD_STATE(namesv) && !CvCLONED(ppad[ix])) { 2075 assert(SvTYPE(ppad[ix]) == SVt_PVCV); 2076 subclones = 1; 2077 sv = newSV_type(SVt_PVCV); 2078 } 2079 else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv)) 2080 { 2081 /* my sub */ 2082 /* Just provide a stub, but name it. It will be 2083 upgrade to the real thing on scope entry. */ 2084 sv = newSV_type(SVt_PVCV); 2085 CvNAME_HEK_set( 2086 sv, 2087 share_hek(SvPVX_const(namesv)+1, 2088 SvCUR(namesv) - 1 2089 * (SvUTF8(namesv) ? -1 : 1), 2090 0) 2091 ); 2092 } 2093 else sv = SvREFCNT_inc(ppad[ix]); 2094 else if (sigil == '@') 2095 sv = MUTABLE_SV(newAV()); 2096 else if (sigil == '%') 2097 sv = MUTABLE_SV(newHV()); 2098 else 2099 sv = newSV(0); 2100 SvPADMY_on(sv); 2101 /* reset the 'assign only once' flag on each state var */ 2102 if (sigil != '&' && SvPAD_STATE(namesv)) 2103 SvPADSTALE_on(sv); 2104 } 2105 } 2106 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) { 2107 sv = SvREFCNT_inc_NN(ppad[ix]); 2108 } 2109 else { 2110 sv = newSV(0); 2111 SvPADTMP_on(sv); 2112 } 2113 PL_curpad[ix] = sv; 2114 } 2115 2116 if (subclones) 2117 for (ix = fpad; ix > 0; ix--) { 2118 SV* const namesv = (ix <= fname) ? pname[ix] : NULL; 2119 if (namesv && namesv != &PL_sv_undef && !SvFAKE(namesv) 2120 && SvPVX_const(namesv)[0] == '&' && SvPAD_STATE(namesv)) 2121 S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv); 2122 } 2123 2124 if (newcv) SvREFCNT_inc_simple_void_NN(cv); 2125 LEAVE; 2126 } 2127 2128 static CV * 2129 S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside) 2130 { 2131 dVAR; 2132 const bool newcv = !cv; 2133 2134 assert(!CvUNIQUE(proto)); 2135 2136 if (!cv) cv = MUTABLE_CV(newSV_type(SvTYPE(proto))); 2137 CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC 2138 |CVf_SLABBED); 2139 CvCLONED_on(cv); 2140 2141 CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto)) 2142 : CvFILE(proto); 2143 if (CvNAMED(proto)) 2144 CvNAME_HEK_set(cv, share_hek_hek(CvNAME_HEK(proto))); 2145 else CvGV_set(cv,CvGV(proto)); 2146 CvSTASH_set(cv, CvSTASH(proto)); 2147 OP_REFCNT_LOCK; 2148 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto)); 2149 OP_REFCNT_UNLOCK; 2150 CvSTART(cv) = CvSTART(proto); 2151 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto); 2152 2153 if (SvPOK(proto)) 2154 sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto)); 2155 if (SvMAGIC(proto)) 2156 mg_copy((SV *)proto, (SV *)cv, 0, 0); 2157 2158 if (CvPADLIST(proto)) S_cv_clone_pad(aTHX_ proto, cv, outside, newcv); 2159 2160 DEBUG_Xv( 2161 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n"); 2162 if (CvOUTSIDE(cv)) cv_dump(CvOUTSIDE(cv), "Outside"); 2163 cv_dump(proto, "Proto"); 2164 cv_dump(cv, "To"); 2165 ); 2166 2167 if (CvCONST(cv)) { 2168 /* Constant sub () { $x } closing over $x - see lib/constant.pm: 2169 * The prototype was marked as a candiate for const-ization, 2170 * so try to grab the current const value, and if successful, 2171 * turn into a const sub: 2172 */ 2173 SV* const const_sv = op_const_sv(CvSTART(cv), cv); 2174 if (const_sv) { 2175 SvREFCNT_dec_NN(cv); 2176 /* For this calling case, op_const_sv returns a *copy*, which we 2177 donate to newCONSTSUB. Yes, this is ugly, and should be killed. 2178 Need to fix how lib/constant.pm works to eliminate this. */ 2179 cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv); 2180 } 2181 else { 2182 CvCONST_off(cv); 2183 } 2184 } 2185 2186 return cv; 2187 } 2188 2189 CV * 2190 Perl_cv_clone(pTHX_ CV *proto) 2191 { 2192 PERL_ARGS_ASSERT_CV_CLONE; 2193 2194 if (!CvPADLIST(proto)) Perl_croak(aTHX_ "panic: no pad in cv_clone"); 2195 return S_cv_clone(aTHX_ proto, NULL, NULL); 2196 } 2197 2198 /* Called only by pp_clonecv */ 2199 CV * 2200 Perl_cv_clone_into(pTHX_ CV *proto, CV *target) 2201 { 2202 PERL_ARGS_ASSERT_CV_CLONE_INTO; 2203 cv_undef(target); 2204 return S_cv_clone(aTHX_ proto, target, NULL); 2205 } 2206 2207 /* 2208 =for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv 2209 2210 For any anon CVs in the pad, change CvOUTSIDE of that CV from 2211 old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be 2212 moved to a pre-existing CV struct. 2213 2214 =cut 2215 */ 2216 2217 void 2218 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv) 2219 { 2220 dVAR; 2221 I32 ix; 2222 AV * const comppad_name = PadlistARRAY(padlist)[0]; 2223 AV * const comppad = PadlistARRAY(padlist)[1]; 2224 SV ** const namepad = AvARRAY(comppad_name); 2225 SV ** const curpad = AvARRAY(comppad); 2226 2227 PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS; 2228 PERL_UNUSED_ARG(old_cv); 2229 2230 for (ix = AvFILLp(comppad_name); ix > 0; ix--) { 2231 const SV * const namesv = namepad[ix]; 2232 if (namesv && namesv != &PL_sv_undef && !SvPAD_STATE(namesv) 2233 && *SvPVX_const(namesv) == '&') 2234 { 2235 if (SvTYPE(curpad[ix]) == SVt_PVCV) { 2236 MAGIC * const mg = 2237 SvMAGICAL(curpad[ix]) 2238 ? mg_find(curpad[ix], PERL_MAGIC_proto) 2239 : NULL; 2240 CV * const innercv = MUTABLE_CV(mg ? mg->mg_obj : curpad[ix]); 2241 if (CvOUTSIDE(innercv) == old_cv) { 2242 if (!CvWEAKOUTSIDE(innercv)) { 2243 SvREFCNT_dec(old_cv); 2244 SvREFCNT_inc_simple_void_NN(new_cv); 2245 } 2246 CvOUTSIDE(innercv) = new_cv; 2247 } 2248 } 2249 else { /* format reference */ 2250 SV * const rv = curpad[ix]; 2251 CV *innercv; 2252 if (!SvOK(rv)) continue; 2253 assert(SvROK(rv)); 2254 assert(SvWEAKREF(rv)); 2255 innercv = (CV *)SvRV(rv); 2256 assert(!CvWEAKOUTSIDE(innercv)); 2257 SvREFCNT_dec(CvOUTSIDE(innercv)); 2258 CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv); 2259 } 2260 } 2261 } 2262 } 2263 2264 /* 2265 =for apidoc m|void|pad_push|PADLIST *padlist|int depth 2266 2267 Push a new pad frame onto the padlist, unless there's already a pad at 2268 this depth, in which case don't bother creating a new one. Then give 2269 the new pad an @_ in slot zero. 2270 2271 =cut 2272 */ 2273 2274 void 2275 Perl_pad_push(pTHX_ PADLIST *padlist, int depth) 2276 { 2277 dVAR; 2278 2279 PERL_ARGS_ASSERT_PAD_PUSH; 2280 2281 if (depth > PadlistMAX(padlist) || !PadlistARRAY(padlist)[depth]) { 2282 PAD** const svp = PadlistARRAY(padlist); 2283 AV* const newpad = newAV(); 2284 SV** const oldpad = AvARRAY(svp[depth-1]); 2285 I32 ix = AvFILLp((const AV *)svp[1]); 2286 const I32 names_fill = AvFILLp((const AV *)svp[0]); 2287 SV** const names = AvARRAY(svp[0]); 2288 AV *av; 2289 2290 for ( ;ix > 0; ix--) { 2291 if (names_fill >= ix && names[ix] != &PL_sv_undef) { 2292 const char sigil = SvPVX_const(names[ix])[0]; 2293 if ((SvFLAGS(names[ix]) & SVf_FAKE) 2294 || (SvFLAGS(names[ix]) & SVpad_STATE) 2295 || sigil == '&') 2296 { 2297 /* outer lexical or anon code */ 2298 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix])); 2299 } 2300 else { /* our own lexical */ 2301 SV *sv; 2302 if (sigil == '@') 2303 sv = MUTABLE_SV(newAV()); 2304 else if (sigil == '%') 2305 sv = MUTABLE_SV(newHV()); 2306 else 2307 sv = newSV(0); 2308 av_store(newpad, ix, sv); 2309 SvPADMY_on(sv); 2310 } 2311 } 2312 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) { 2313 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix])); 2314 } 2315 else { 2316 /* save temporaries on recursion? */ 2317 SV * const sv = newSV(0); 2318 av_store(newpad, ix, sv); 2319 SvPADTMP_on(sv); 2320 } 2321 } 2322 av = newAV(); 2323 av_store(newpad, 0, MUTABLE_SV(av)); 2324 AvREIFY_only(av); 2325 2326 padlist_store(padlist, depth, newpad); 2327 } 2328 } 2329 2330 /* 2331 =for apidoc Am|HV *|pad_compname_type|PADOFFSET po 2332 2333 Looks up the type of the lexical variable at position I<po> in the 2334 currently-compiling pad. If the variable is typed, the stash of the 2335 class to which it is typed is returned. If not, C<NULL> is returned. 2336 2337 =cut 2338 */ 2339 2340 HV * 2341 Perl_pad_compname_type(pTHX_ const PADOFFSET po) 2342 { 2343 dVAR; 2344 SV* const * const av = av_fetch(PL_comppad_name, po, FALSE); 2345 if ( SvPAD_TYPED(*av) ) { 2346 return SvSTASH(*av); 2347 } 2348 return NULL; 2349 } 2350 2351 #if defined(USE_ITHREADS) 2352 2353 # define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t)) 2354 2355 /* 2356 =for apidoc padlist_dup 2357 2358 Duplicates a pad. 2359 2360 =cut 2361 */ 2362 2363 PADLIST * 2364 Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param) 2365 { 2366 PADLIST *dstpad; 2367 bool cloneall; 2368 PADOFFSET max; 2369 2370 PERL_ARGS_ASSERT_PADLIST_DUP; 2371 2372 if (!srcpad) 2373 return NULL; 2374 2375 cloneall = param->flags & CLONEf_COPY_STACKS 2376 || SvREFCNT(PadlistARRAY(srcpad)[1]) > 1; 2377 assert (SvREFCNT(PadlistARRAY(srcpad)[1]) == 1); 2378 2379 max = cloneall ? PadlistMAX(srcpad) : 1; 2380 2381 Newx(dstpad, 1, PADLIST); 2382 ptr_table_store(PL_ptr_table, srcpad, dstpad); 2383 PadlistMAX(dstpad) = max; 2384 Newx(PadlistARRAY(dstpad), max + 1, PAD *); 2385 2386 if (cloneall) { 2387 PADOFFSET depth; 2388 for (depth = 0; depth <= max; ++depth) 2389 PadlistARRAY(dstpad)[depth] = 2390 av_dup_inc(PadlistARRAY(srcpad)[depth], param); 2391 } else { 2392 /* CvDEPTH() on our subroutine will be set to 0, so there's no need 2393 to build anything other than the first level of pads. */ 2394 I32 ix = AvFILLp(PadlistARRAY(srcpad)[1]); 2395 AV *pad1; 2396 const I32 names_fill = AvFILLp(PadlistARRAY(srcpad)[0]); 2397 const PAD *const srcpad1 = PadlistARRAY(srcpad)[1]; 2398 SV **oldpad = AvARRAY(srcpad1); 2399 SV **names; 2400 SV **pad1a; 2401 AV *args; 2402 2403 PadlistARRAY(dstpad)[0] = 2404 av_dup_inc(PadlistARRAY(srcpad)[0], param); 2405 names = AvARRAY(PadlistARRAY(dstpad)[0]); 2406 2407 pad1 = newAV(); 2408 2409 av_extend(pad1, ix); 2410 PadlistARRAY(dstpad)[1] = pad1; 2411 pad1a = AvARRAY(pad1); 2412 2413 if (ix > -1) { 2414 AvFILLp(pad1) = ix; 2415 2416 for ( ;ix > 0; ix--) { 2417 if (!oldpad[ix]) { 2418 pad1a[ix] = NULL; 2419 } else if (names_fill >= ix && names[ix] != &PL_sv_undef) { 2420 const char sigil = SvPVX_const(names[ix])[0]; 2421 if ((SvFLAGS(names[ix]) & SVf_FAKE) 2422 || (SvFLAGS(names[ix]) & SVpad_STATE) 2423 || sigil == '&') 2424 { 2425 /* outer lexical or anon code */ 2426 pad1a[ix] = sv_dup_inc(oldpad[ix], param); 2427 } 2428 else { /* our own lexical */ 2429 if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) { 2430 /* This is a work around for how the current 2431 implementation of ?{ } blocks in regexps 2432 interacts with lexicals. */ 2433 pad1a[ix] = sv_dup_inc(oldpad[ix], param); 2434 } else { 2435 SV *sv; 2436 2437 if (sigil == '@') 2438 sv = MUTABLE_SV(newAV()); 2439 else if (sigil == '%') 2440 sv = MUTABLE_SV(newHV()); 2441 else 2442 sv = newSV(0); 2443 pad1a[ix] = sv; 2444 SvPADMY_on(sv); 2445 } 2446 } 2447 } 2448 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) { 2449 pad1a[ix] = sv_dup_inc(oldpad[ix], param); 2450 } 2451 else { 2452 /* save temporaries on recursion? */ 2453 SV * const sv = newSV(0); 2454 pad1a[ix] = sv; 2455 2456 /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs 2457 FIXTHAT before merging this branch. 2458 (And I know how to) */ 2459 if (SvPADMY(oldpad[ix])) 2460 SvPADMY_on(sv); 2461 else 2462 SvPADTMP_on(sv); 2463 } 2464 } 2465 2466 if (oldpad[0]) { 2467 args = newAV(); /* Will be @_ */ 2468 AvREIFY_only(args); 2469 pad1a[0] = (SV *)args; 2470 } 2471 } 2472 } 2473 2474 return dstpad; 2475 } 2476 2477 #endif /* USE_ITHREADS */ 2478 2479 PAD ** 2480 Perl_padlist_store(pTHX_ PADLIST *padlist, I32 key, PAD *val) 2481 { 2482 dVAR; 2483 PAD **ary; 2484 SSize_t const oldmax = PadlistMAX(padlist); 2485 2486 PERL_ARGS_ASSERT_PADLIST_STORE; 2487 2488 assert(key >= 0); 2489 2490 if (key > PadlistMAX(padlist)) { 2491 av_extend_guts(NULL,key,&PadlistMAX(padlist), 2492 (SV ***)&PadlistARRAY(padlist), 2493 (SV ***)&PadlistARRAY(padlist)); 2494 Zero(PadlistARRAY(padlist)+oldmax+1, PadlistMAX(padlist)-oldmax, 2495 PAD *); 2496 } 2497 ary = PadlistARRAY(padlist); 2498 SvREFCNT_dec(ary[key]); 2499 ary[key] = val; 2500 return &ary[key]; 2501 } 2502 2503 /* 2504 * Local variables: 2505 * c-indentation-style: bsd 2506 * c-basic-offset: 4 2507 * indent-tabs-mode: nil 2508 * End: 2509 * 2510 * ex: set ts=8 sts=4 sw=4 et: 2511 */ 2512