1 #line 2 "op.c" 2 /* op.c 3 * 4 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 5 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others 6 * 7 * You may distribute under the terms of either the GNU General Public 8 * License or the Artistic License, as specified in the README file. 9 * 10 */ 11 12 /* 13 * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was 14 * our Mr. Bilbo's first cousin on the mother's side (her mother being the 15 * youngest of the Old Took's daughters); and Mr. Drogo was his second 16 * cousin. So Mr. Frodo is his first *and* second cousin, once removed 17 * either way, as the saying is, if you follow me.' --the Gaffer 18 * 19 * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"] 20 */ 21 22 /* This file contains the functions that create, manipulate and optimize 23 * the OP structures that hold a compiled perl program. 24 * 25 * Note that during the build of miniperl, a temporary copy of this file 26 * is made, called opmini.c. 27 * 28 * A Perl program is compiled into a tree of OP nodes. Each op contains: 29 * * structural OP pointers to its children and siblings (op_sibling, 30 * op_first etc) that define the tree structure; 31 * * execution order OP pointers (op_next, plus sometimes op_other, 32 * op_lastop etc) that define the execution sequence plus variants; 33 * * a pointer to the C "pp" function that would execute the op; 34 * * any data specific to that op. 35 * For example, an OP_CONST op points to the pp_const() function and to an 36 * SV containing the constant value. When pp_const() is executed, its job 37 * is to push that SV onto the stack. 38 * 39 * OPs are mainly created by the newFOO() functions, which are mainly 40 * called from the parser (in perly.y) as the code is parsed. For example 41 * the Perl code $a + $b * $c would cause the equivalent of the following 42 * to be called (oversimplifying a bit): 43 * 44 * newBINOP(OP_ADD, flags, 45 * newSVREF($a), 46 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c)) 47 * ) 48 * 49 * As the parser reduces low-level rules, it creates little op subtrees; 50 * as higher-level rules are resolved, these subtrees get joined together 51 * as branches on a bigger subtree, until eventually a top-level rule like 52 * a subroutine definition is reduced, at which point there is one large 53 * parse tree left. 54 * 55 * The execution order pointers (op_next) are generated as the subtrees 56 * are joined together. Consider this sub-expression: A*B + C/D: at the 57 * point when it's just been parsed, the op tree looks like: 58 * 59 * [+] 60 * | 61 * [*]------[/] 62 * | | 63 * A---B C---D 64 * 65 * with the intended execution order being: 66 * 67 * [PREV] => A => B => [*] => C => D => [/] => [+] => [NEXT] 68 * 69 * At this point all the nodes' op_next pointers will have been set, 70 * except that: 71 * * we don't know what the [NEXT] node will be yet; 72 * * we don't know what the [PREV] node will be yet, but when it gets 73 * created and needs its op_next set, it needs to be set to point to 74 * A, which is non-obvious. 75 * To handle both those cases, we temporarily set the top node's 76 * op_next to point to the first node to be executed in this subtree (A in 77 * this case). This means that initially a subtree's op_next chain, 78 * starting from the top node, will visit each node in execution sequence 79 * then point back at the top node. 80 * When we embed this subtree in a larger tree, its top op_next is used 81 * to get the start node, then is set to point to its new neighbour. 82 * For example the two separate [*],A,B and [/],C,D subtrees would 83 * initially have had: 84 * [*] => A; A => B; B => [*] 85 * and 86 * [/] => C; C => D; D => [/] 87 * When these two subtrees were joined together to make the [+] subtree, 88 * [+]'s op_next was set to [*]'s op_next, i.e. A; then [*]'s op_next was 89 * set to point to [/]'s op_next, i.e. C. 90 * 91 * This op_next linking is done by the LINKLIST() macro and its underlying 92 * op_linklist() function. Given a top-level op, if its op_next is 93 * non-null, it's already been linked, so leave it. Otherwise link it with 94 * its children as described above, possibly recursively if any of the 95 * children have a null op_next. 96 * 97 * In summary: given a subtree, its top-level node's op_next will either 98 * be: 99 * NULL: the subtree hasn't been LINKLIST()ed yet; 100 * fake: points to the start op for this subtree; 101 * real: once the subtree has been embedded into a larger tree 102 */ 103 104 /* 105 106 Here's an older description from Larry. 107 108 Perl's compiler is essentially a 3-pass compiler with interleaved phases: 109 110 A bottom-up pass 111 A top-down pass 112 An execution-order pass 113 114 The bottom-up pass is represented by all the "newOP" routines and 115 the ck_ routines. The bottom-upness is actually driven by yacc. 116 So at the point that a ck_ routine fires, we have no idea what the 117 context is, either upward in the syntax tree, or either forward or 118 backward in the execution order. (The bottom-up parser builds that 119 part of the execution order it knows about, but if you follow the "next" 120 links around, you'll find it's actually a closed loop through the 121 top level node.) 122 123 Whenever the bottom-up parser gets to a node that supplies context to 124 its components, it invokes that portion of the top-down pass that applies 125 to that part of the subtree (and marks the top node as processed, so 126 if a node further up supplies context, it doesn't have to take the 127 plunge again). As a particular subcase of this, as the new node is 128 built, it takes all the closed execution loops of its subcomponents 129 and links them into a new closed loop for the higher level node. But 130 it's still not the real execution order. 131 132 The actual execution order is not known till we get a grammar reduction 133 to a top-level unit like a subroutine or file that will be called by 134 "name" rather than via a "next" pointer. At that point, we can call 135 into peep() to do that code's portion of the 3rd pass. It has to be 136 recursive, but it's recursive on basic blocks, not on tree nodes. 137 */ 138 139 /* To implement user lexical pragmas, there needs to be a way at run time to 140 get the compile time state of %^H for that block. Storing %^H in every 141 block (or even COP) would be very expensive, so a different approach is 142 taken. The (running) state of %^H is serialised into a tree of HE-like 143 structs. Stores into %^H are chained onto the current leaf as a struct 144 refcounted_he * with the key and the value. Deletes from %^H are saved 145 with a value of PL_sv_placeholder. The state of %^H at any point can be 146 turned back into a regular HV by walking back up the tree from that point's 147 leaf, ignoring any key you've already seen (placeholder or not), storing 148 the rest into the HV structure, then removing the placeholders. Hence 149 memory is only used to store the %^H deltas from the enclosing COP, rather 150 than the entire %^H on each COP. 151 152 To cause actions on %^H to write out the serialisation records, it has 153 magic type 'H'. This magic (itself) does nothing, but its presence causes 154 the values to gain magic type 'h', which has entries for set and clear. 155 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store 156 record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS> 157 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that 158 it will be correctly restored when any inner compiling scope is exited. 159 */ 160 161 #include "EXTERN.h" 162 #define PERL_IN_OP_C 163 #include "perl.h" 164 #include "keywords.h" 165 #include "feature.h" 166 #include "regcomp.h" 167 #include "invlist_inline.h" 168 169 #define CALL_PEEP(o) PL_peepp(aTHX_ o) 170 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o) 171 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o) 172 173 static const char array_passed_to_stat[] = "Array passed to stat will be coerced to a scalar"; 174 175 /* remove any leading "empty" ops from the op_next chain whose first 176 * node's address is stored in op_p. Store the updated address of the 177 * first node in op_p. 178 */ 179 180 STATIC void 181 S_prune_chain_head(OP** op_p) 182 { 183 while (*op_p 184 && ( (*op_p)->op_type == OP_NULL 185 || (*op_p)->op_type == OP_SCOPE 186 || (*op_p)->op_type == OP_SCALAR 187 || (*op_p)->op_type == OP_LINESEQ) 188 ) 189 *op_p = (*op_p)->op_next; 190 } 191 192 193 /* See the explanatory comments above struct opslab in op.h. */ 194 195 #ifdef PERL_DEBUG_READONLY_OPS 196 # define PERL_SLAB_SIZE 128 197 # define PERL_MAX_SLAB_SIZE 4096 198 # include <sys/mman.h> 199 #endif 200 201 #ifndef PERL_SLAB_SIZE 202 # define PERL_SLAB_SIZE 64 203 #endif 204 #ifndef PERL_MAX_SLAB_SIZE 205 # define PERL_MAX_SLAB_SIZE 2048 206 #endif 207 208 /* rounds up to nearest pointer */ 209 #define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *)) 210 #define DIFF(o,p) ((size_t)((I32 **)(p) - (I32**)(o))) 211 212 /* requires double parens and aTHX_ */ 213 #define DEBUG_S_warn(args) \ 214 DEBUG_S( \ 215 PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \ 216 ) 217 218 219 /* malloc a new op slab (suitable for attaching to PL_compcv). 220 * sz is in units of pointers */ 221 222 static OPSLAB * 223 S_new_slab(pTHX_ OPSLAB *head, size_t sz) 224 { 225 OPSLAB *slab; 226 227 /* opslot_offset is only U16 */ 228 assert(sz < U16_MAX); 229 230 #ifdef PERL_DEBUG_READONLY_OPS 231 slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *), 232 PROT_READ|PROT_WRITE, 233 MAP_ANON|MAP_PRIVATE, -1, 0); 234 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n", 235 (unsigned long) sz, slab)); 236 if (slab == MAP_FAILED) { 237 perror("mmap failed"); 238 abort(); 239 } 240 #else 241 slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *)); 242 #endif 243 slab->opslab_size = (U16)sz; 244 245 #ifndef WIN32 246 /* The context is unused in non-Windows */ 247 PERL_UNUSED_CONTEXT; 248 #endif 249 slab->opslab_free_space = sz - DIFF(slab, &slab->opslab_slots); 250 slab->opslab_head = head ? head : slab; 251 DEBUG_S_warn((aTHX_ "allocated new op slab sz 0x%x, %p, head slab %p", 252 (unsigned int)slab->opslab_size, (void*)slab, 253 (void*)(slab->opslab_head))); 254 return slab; 255 } 256 257 /* opslot_size includes the size of the slot header, and an op can't be smaller than BASEOP */ 258 #define OPSLOT_SIZE_BASE (SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) 259 #define OPSLOT_SIZE_TO_INDEX(sz) ((sz) - OPSLOT_SIZE_BASE) 260 261 #define link_freed_op(slab, o) S_link_freed_op(aTHX_ slab, o) 262 static void 263 S_link_freed_op(pTHX_ OPSLAB *slab, OP *o) { 264 U16 sz = OpSLOT(o)->opslot_size; 265 U16 index = OPSLOT_SIZE_TO_INDEX(sz); 266 267 assert(sz >= OPSLOT_SIZE_BASE); 268 /* make sure the array is large enough to include ops this large */ 269 if (!slab->opslab_freed) { 270 /* we don't have a free list array yet, make a new one */ 271 slab->opslab_freed_size = index+1; 272 slab->opslab_freed = (OP**)PerlMemShared_calloc((slab->opslab_freed_size), sizeof(OP*)); 273 274 if (!slab->opslab_freed) 275 croak_no_mem(); 276 } 277 else if (index >= slab->opslab_freed_size) { 278 /* It's probably not worth doing exponential expansion here, the number of op sizes 279 is small. 280 */ 281 /* We already have a list that isn't large enough, expand it */ 282 size_t newsize = index+1; 283 OP **p = (OP **)PerlMemShared_realloc(slab->opslab_freed, newsize * sizeof(OP*)); 284 285 if (!p) 286 croak_no_mem(); 287 288 Zero(p+slab->opslab_freed_size, newsize - slab->opslab_freed_size, OP *); 289 290 slab->opslab_freed = p; 291 slab->opslab_freed_size = newsize; 292 } 293 294 o->op_next = slab->opslab_freed[index]; 295 slab->opslab_freed[index] = o; 296 } 297 298 /* Returns a sz-sized block of memory (suitable for holding an op) from 299 * a free slot in the chain of op slabs attached to PL_compcv. 300 * Allocates a new slab if necessary. 301 * if PL_compcv isn't compiling, malloc() instead. 302 */ 303 304 void * 305 Perl_Slab_Alloc(pTHX_ size_t sz) 306 { 307 OPSLAB *head_slab; /* first slab in the chain */ 308 OPSLAB *slab2; 309 OPSLOT *slot; 310 OP *o; 311 size_t opsz; 312 313 /* We only allocate ops from the slab during subroutine compilation. 314 We find the slab via PL_compcv, hence that must be non-NULL. It could 315 also be pointing to a subroutine which is now fully set up (CvROOT() 316 pointing to the top of the optree for that sub), or a subroutine 317 which isn't using the slab allocator. If our sanity checks aren't met, 318 don't use a slab, but allocate the OP directly from the heap. */ 319 if (!PL_compcv || CvROOT(PL_compcv) 320 || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv))) 321 { 322 o = (OP*)PerlMemShared_calloc(1, sz); 323 goto gotit; 324 } 325 326 /* While the subroutine is under construction, the slabs are accessed via 327 CvSTART(), to avoid needing to expand PVCV by one pointer for something 328 unneeded at runtime. Once a subroutine is constructed, the slabs are 329 accessed via CvROOT(). So if CvSTART() is NULL, no slab has been 330 allocated yet. See the commit message for 8be227ab5eaa23f2 for more 331 details. */ 332 if (!CvSTART(PL_compcv)) { 333 CvSTART(PL_compcv) = 334 (OP *)(head_slab = S_new_slab(aTHX_ NULL, PERL_SLAB_SIZE)); 335 CvSLABBED_on(PL_compcv); 336 head_slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */ 337 } 338 else ++(head_slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt; 339 340 opsz = SIZE_TO_PSIZE(sz); 341 sz = opsz + OPSLOT_HEADER_P; 342 343 /* The head slab for each CV maintains a free list of OPs. In particular, constant folding 344 will free up OPs, so it makes sense to re-use them where possible. A 345 freed up slot is used in preference to a new allocation. */ 346 if (head_slab->opslab_freed && 347 OPSLOT_SIZE_TO_INDEX(sz) < head_slab->opslab_freed_size) { 348 U16 base_index; 349 350 /* look for a large enough size with any freed ops */ 351 for (base_index = OPSLOT_SIZE_TO_INDEX(sz); 352 base_index < head_slab->opslab_freed_size && !head_slab->opslab_freed[base_index]; 353 ++base_index) { 354 } 355 356 if (base_index < head_slab->opslab_freed_size) { 357 /* found a freed op */ 358 o = head_slab->opslab_freed[base_index]; 359 360 DEBUG_S_warn((aTHX_ "realloced op at %p, slab %p, head slab %p", 361 (void*)o, 362 (I32**)OpSLOT(o) - OpSLOT(o)->opslot_offset, 363 (void*)head_slab)); 364 head_slab->opslab_freed[base_index] = o->op_next; 365 Zero(o, opsz, I32 *); 366 o->op_slabbed = 1; 367 goto gotit; 368 } 369 } 370 371 #define INIT_OPSLOT(s) \ 372 slot->opslot_offset = DIFF(slab2, slot) ; \ 373 slot->opslot_size = s; \ 374 slab2->opslab_free_space -= s; \ 375 o = &slot->opslot_op; \ 376 o->op_slabbed = 1 377 378 /* The partially-filled slab is next in the chain. */ 379 slab2 = head_slab->opslab_next ? head_slab->opslab_next : head_slab; 380 if (slab2->opslab_free_space < sz) { 381 /* Remaining space is too small. */ 382 /* If we can fit a BASEOP, add it to the free chain, so as not 383 to waste it. */ 384 if (slab2->opslab_free_space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) { 385 slot = &slab2->opslab_slots; 386 INIT_OPSLOT(slab2->opslab_free_space); 387 o->op_type = OP_FREED; 388 link_freed_op(head_slab, o); 389 } 390 391 /* Create a new slab. Make this one twice as big. */ 392 slab2 = S_new_slab(aTHX_ head_slab, 393 slab2->opslab_size > PERL_MAX_SLAB_SIZE / 2 394 ? PERL_MAX_SLAB_SIZE 395 : slab2->opslab_size * 2); 396 slab2->opslab_next = head_slab->opslab_next; 397 head_slab->opslab_next = slab2; 398 } 399 assert(slab2->opslab_size >= sz); 400 401 /* Create a new op slot */ 402 slot = (OPSLOT *) 403 ((I32 **)&slab2->opslab_slots 404 + slab2->opslab_free_space - sz); 405 assert(slot >= &slab2->opslab_slots); 406 INIT_OPSLOT(sz); 407 DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p, head slab %p", 408 (void*)o, (void*)slab2, (void*)head_slab)); 409 410 gotit: 411 /* moresib == 0, op_sibling == 0 implies a solitary unattached op */ 412 assert(!o->op_moresib); 413 assert(!o->op_sibparent); 414 415 return (void *)o; 416 } 417 418 #undef INIT_OPSLOT 419 420 #ifdef PERL_DEBUG_READONLY_OPS 421 void 422 Perl_Slab_to_ro(pTHX_ OPSLAB *slab) 423 { 424 PERL_ARGS_ASSERT_SLAB_TO_RO; 425 426 if (slab->opslab_readonly) return; 427 slab->opslab_readonly = 1; 428 for (; slab; slab = slab->opslab_next) { 429 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n", 430 (unsigned long) slab->opslab_size, slab));*/ 431 if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ)) 432 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab, 433 (unsigned long)slab->opslab_size, errno); 434 } 435 } 436 437 void 438 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab) 439 { 440 OPSLAB *slab2; 441 442 PERL_ARGS_ASSERT_SLAB_TO_RW; 443 444 if (!slab->opslab_readonly) return; 445 slab2 = slab; 446 for (; slab2; slab2 = slab2->opslab_next) { 447 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n", 448 (unsigned long) size, slab2));*/ 449 if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *), 450 PROT_READ|PROT_WRITE)) { 451 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab, 452 (unsigned long)slab2->opslab_size, errno); 453 } 454 } 455 slab->opslab_readonly = 0; 456 } 457 458 #else 459 # define Slab_to_rw(op) NOOP 460 #endif 461 462 /* This cannot possibly be right, but it was copied from the old slab 463 allocator, to which it was originally added, without explanation, in 464 commit 083fcd5. */ 465 #ifdef NETWARE 466 # define PerlMemShared PerlMem 467 #endif 468 469 /* make freed ops die if they're inadvertently executed */ 470 #ifdef DEBUGGING 471 static OP * 472 S_pp_freed(pTHX) 473 { 474 DIE(aTHX_ "panic: freed op 0x%p called\n", PL_op); 475 } 476 #endif 477 478 479 /* Return the block of memory used by an op to the free list of 480 * the OP slab associated with that op. 481 */ 482 483 void 484 Perl_Slab_Free(pTHX_ void *op) 485 { 486 OP * const o = (OP *)op; 487 OPSLAB *slab; 488 489 PERL_ARGS_ASSERT_SLAB_FREE; 490 491 #ifdef DEBUGGING 492 o->op_ppaddr = S_pp_freed; 493 #endif 494 495 if (!o->op_slabbed) { 496 if (!o->op_static) 497 PerlMemShared_free(op); 498 return; 499 } 500 501 slab = OpSLAB(o); 502 /* If this op is already freed, our refcount will get screwy. */ 503 assert(o->op_type != OP_FREED); 504 o->op_type = OP_FREED; 505 link_freed_op(slab, o); 506 DEBUG_S_warn((aTHX_ "freeing op at %p, slab %p, head slab %p", 507 (void*)o, 508 (I32**)OpSLOT(o) - OpSLOT(o)->opslot_offset, 509 (void*)slab)); 510 OpslabREFCNT_dec_padok(slab); 511 } 512 513 void 514 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab) 515 { 516 const bool havepad = !!PL_comppad; 517 PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD; 518 if (havepad) { 519 ENTER; 520 PAD_SAVE_SETNULLPAD(); 521 } 522 opslab_free(slab); 523 if (havepad) LEAVE; 524 } 525 526 /* Free a chain of OP slabs. Should only be called after all ops contained 527 * in it have been freed. At this point, its reference count should be 1, 528 * because OpslabREFCNT_dec() skips doing rc-- when it detects that rc == 1, 529 * and just directly calls opslab_free(). 530 * (Note that the reference count which PL_compcv held on the slab should 531 * have been removed once compilation of the sub was complete). 532 * 533 * 534 */ 535 536 void 537 Perl_opslab_free(pTHX_ OPSLAB *slab) 538 { 539 OPSLAB *slab2; 540 PERL_ARGS_ASSERT_OPSLAB_FREE; 541 PERL_UNUSED_CONTEXT; 542 DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab)); 543 assert(slab->opslab_refcnt == 1); 544 PerlMemShared_free(slab->opslab_freed); 545 do { 546 slab2 = slab->opslab_next; 547 #ifdef DEBUGGING 548 slab->opslab_refcnt = ~(size_t)0; 549 #endif 550 #ifdef PERL_DEBUG_READONLY_OPS 551 DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n", 552 (void*)slab)); 553 if (munmap(slab, slab->opslab_size * sizeof(I32 *))) { 554 perror("munmap failed"); 555 abort(); 556 } 557 #else 558 PerlMemShared_free(slab); 559 #endif 560 slab = slab2; 561 } while (slab); 562 } 563 564 /* like opslab_free(), but first calls op_free() on any ops in the slab 565 * not marked as OP_FREED 566 */ 567 568 void 569 Perl_opslab_force_free(pTHX_ OPSLAB *slab) 570 { 571 OPSLAB *slab2; 572 #ifdef DEBUGGING 573 size_t savestack_count = 0; 574 #endif 575 PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE; 576 slab2 = slab; 577 do { 578 OPSLOT *slot = (OPSLOT*) 579 ((I32**)&slab2->opslab_slots + slab2->opslab_free_space); 580 OPSLOT *end = (OPSLOT*) 581 ((I32**)slab2 + slab2->opslab_size); 582 for (; slot < end; 583 slot = (OPSLOT*) ((I32**)slot + slot->opslot_size) ) 584 { 585 if (slot->opslot_op.op_type != OP_FREED 586 && !(slot->opslot_op.op_savefree 587 #ifdef DEBUGGING 588 && ++savestack_count 589 #endif 590 ) 591 ) { 592 assert(slot->opslot_op.op_slabbed); 593 op_free(&slot->opslot_op); 594 if (slab->opslab_refcnt == 1) goto free; 595 } 596 } 597 } while ((slab2 = slab2->opslab_next)); 598 /* > 1 because the CV still holds a reference count. */ 599 if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */ 600 #ifdef DEBUGGING 601 assert(savestack_count == slab->opslab_refcnt-1); 602 #endif 603 /* Remove the CV’s reference count. */ 604 slab->opslab_refcnt--; 605 return; 606 } 607 free: 608 opslab_free(slab); 609 } 610 611 #ifdef PERL_DEBUG_READONLY_OPS 612 OP * 613 Perl_op_refcnt_inc(pTHX_ OP *o) 614 { 615 if(o) { 616 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL; 617 if (slab && slab->opslab_readonly) { 618 Slab_to_rw(slab); 619 ++o->op_targ; 620 Slab_to_ro(slab); 621 } else { 622 ++o->op_targ; 623 } 624 } 625 return o; 626 627 } 628 629 PADOFFSET 630 Perl_op_refcnt_dec(pTHX_ OP *o) 631 { 632 PADOFFSET result; 633 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL; 634 635 PERL_ARGS_ASSERT_OP_REFCNT_DEC; 636 637 if (slab && slab->opslab_readonly) { 638 Slab_to_rw(slab); 639 result = --o->op_targ; 640 Slab_to_ro(slab); 641 } else { 642 result = --o->op_targ; 643 } 644 return result; 645 } 646 #endif 647 /* 648 * In the following definition, the ", (OP*)0" is just to make the compiler 649 * think the expression is of the right type: croak actually does a Siglongjmp. 650 */ 651 #define CHECKOP(type,o) \ 652 ((PL_op_mask && PL_op_mask[type]) \ 653 ? ( op_free((OP*)o), \ 654 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \ 655 (OP*)0 ) \ 656 : PL_check[type](aTHX_ (OP*)o)) 657 658 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2) 659 660 #define OpTYPE_set(o,type) \ 661 STMT_START { \ 662 o->op_type = (OPCODE)type; \ 663 o->op_ppaddr = PL_ppaddr[type]; \ 664 } STMT_END 665 666 STATIC OP * 667 S_no_fh_allowed(pTHX_ OP *o) 668 { 669 PERL_ARGS_ASSERT_NO_FH_ALLOWED; 670 671 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function", 672 OP_DESC(o))); 673 return o; 674 } 675 676 STATIC OP * 677 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags) 678 { 679 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV; 680 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags); 681 return o; 682 } 683 684 STATIC OP * 685 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags) 686 { 687 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV; 688 689 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags); 690 return o; 691 } 692 693 STATIC void 694 S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid) 695 { 696 PERL_ARGS_ASSERT_BAD_TYPE_PV; 697 698 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)", 699 (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0); 700 } 701 702 STATIC void 703 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t) 704 { 705 SV * const namesv = cv_name((CV *)gv, NULL, 0); 706 PERL_ARGS_ASSERT_BAD_TYPE_GV; 707 708 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %" SVf " must be %s (not %s)", 709 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv)); 710 } 711 712 STATIC void 713 S_no_bareword_allowed(pTHX_ OP *o) 714 { 715 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED; 716 717 qerror(Perl_mess(aTHX_ 718 "Bareword \"%" SVf "\" not allowed while \"strict subs\" in use", 719 SVfARG(cSVOPo_sv))); 720 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */ 721 } 722 723 /* "register" allocation */ 724 725 PADOFFSET 726 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags) 727 { 728 PADOFFSET off; 729 const bool is_our = (PL_parser->in_my == KEY_our); 730 731 PERL_ARGS_ASSERT_ALLOCMY; 732 733 if (flags & ~SVf_UTF8) 734 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf, 735 (UV)flags); 736 737 /* complain about "my $<special_var>" etc etc */ 738 if ( len 739 && !( is_our 740 || isALPHA(name[1]) 741 || ( (flags & SVf_UTF8) 742 && isIDFIRST_utf8_safe((U8 *)name+1, name + len)) 743 || (name[1] == '_' && len > 2))) 744 { 745 const char * const type = 746 PL_parser->in_my == KEY_sigvar ? "subroutine signature" : 747 PL_parser->in_my == KEY_state ? "\"state\"" : "\"my\""; 748 749 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1])) 750 && isASCII(name[1]) 751 && (!isPRINT(name[1]) || memCHRs("\t\n\r\f", name[1]))) { 752 /* diag_listed_as: Can't use global %s in %s */ 753 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in %s", 754 name[0], toCTRL(name[1]), 755 (int)(len - 2), name + 2, 756 type)); 757 } else { 758 yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in %s", 759 (int) len, name, 760 type), flags & SVf_UTF8); 761 } 762 } 763 764 /* allocate a spare slot and store the name in that slot */ 765 766 off = pad_add_name_pvn(name, len, 767 (is_our ? padadd_OUR : 768 PL_parser->in_my == KEY_state ? padadd_STATE : 0), 769 PL_parser->in_my_stash, 770 (is_our 771 /* $_ is always in main::, even with our */ 772 ? (PL_curstash && !memEQs(name,len,"$_") 773 ? PL_curstash 774 : PL_defstash) 775 : NULL 776 ) 777 ); 778 /* anon sub prototypes contains state vars should always be cloned, 779 * otherwise the state var would be shared between anon subs */ 780 781 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv)) 782 CvCLONE_on(PL_compcv); 783 784 return off; 785 } 786 787 /* 788 =head1 Optree Manipulation Functions 789 790 =for apidoc alloccopstash 791 792 Available only under threaded builds, this function allocates an entry in 793 C<PL_stashpad> for the stash passed to it. 794 795 =cut 796 */ 797 798 #ifdef USE_ITHREADS 799 PADOFFSET 800 Perl_alloccopstash(pTHX_ HV *hv) 801 { 802 PADOFFSET off = 0, o = 1; 803 bool found_slot = FALSE; 804 805 PERL_ARGS_ASSERT_ALLOCCOPSTASH; 806 807 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix; 808 809 for (; o < PL_stashpadmax; ++o) { 810 if (PL_stashpad[o] == hv) return PL_stashpadix = o; 811 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV) 812 found_slot = TRUE, off = o; 813 } 814 if (!found_slot) { 815 Renew(PL_stashpad, PL_stashpadmax + 10, HV *); 816 Zero(PL_stashpad + PL_stashpadmax, 10, HV *); 817 off = PL_stashpadmax; 818 PL_stashpadmax += 10; 819 } 820 821 PL_stashpad[PL_stashpadix = off] = hv; 822 return off; 823 } 824 #endif 825 826 /* free the body of an op without examining its contents. 827 * Always use this rather than FreeOp directly */ 828 829 static void 830 S_op_destroy(pTHX_ OP *o) 831 { 832 FreeOp(o); 833 } 834 835 /* Destructor */ 836 837 /* 838 =for apidoc op_free 839 840 Free an op and its children. Only use this when an op is no longer linked 841 to from any optree. 842 843 =cut 844 */ 845 846 void 847 Perl_op_free(pTHX_ OP *o) 848 { 849 dVAR; 850 OPCODE type; 851 OP *top_op = o; 852 OP *next_op = o; 853 bool went_up = FALSE; /* whether we reached the current node by 854 following the parent pointer from a child, and 855 so have already seen this node */ 856 857 if (!o || o->op_type == OP_FREED) 858 return; 859 860 if (o->op_private & OPpREFCOUNTED) { 861 /* if base of tree is refcounted, just decrement */ 862 switch (o->op_type) { 863 case OP_LEAVESUB: 864 case OP_LEAVESUBLV: 865 case OP_LEAVEEVAL: 866 case OP_LEAVE: 867 case OP_SCOPE: 868 case OP_LEAVEWRITE: 869 { 870 PADOFFSET refcnt; 871 OP_REFCNT_LOCK; 872 refcnt = OpREFCNT_dec(o); 873 OP_REFCNT_UNLOCK; 874 if (refcnt) { 875 /* Need to find and remove any pattern match ops from 876 * the list we maintain for reset(). */ 877 find_and_forget_pmops(o); 878 return; 879 } 880 } 881 break; 882 default: 883 break; 884 } 885 } 886 887 while (next_op) { 888 o = next_op; 889 890 /* free child ops before ourself, (then free ourself "on the 891 * way back up") */ 892 893 if (!went_up && o->op_flags & OPf_KIDS) { 894 next_op = cUNOPo->op_first; 895 continue; 896 } 897 898 /* find the next node to visit, *then* free the current node 899 * (can't rely on o->op_* fields being valid after o has been 900 * freed) */ 901 902 /* The next node to visit will be either the sibling, or the 903 * parent if no siblings left, or NULL if we've worked our way 904 * back up to the top node in the tree */ 905 next_op = (o == top_op) ? NULL : o->op_sibparent; 906 went_up = cBOOL(!OpHAS_SIBLING(o)); /* parents are already visited */ 907 908 /* Now process the current node */ 909 910 /* Though ops may be freed twice, freeing the op after its slab is a 911 big no-no. */ 912 assert(!o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0); 913 /* During the forced freeing of ops after compilation failure, kidops 914 may be freed before their parents. */ 915 if (!o || o->op_type == OP_FREED) 916 continue; 917 918 type = o->op_type; 919 920 /* an op should only ever acquire op_private flags that we know about. 921 * If this fails, you may need to fix something in regen/op_private. 922 * Don't bother testing if: 923 * * the op_ppaddr doesn't match the op; someone may have 924 * overridden the op and be doing strange things with it; 925 * * we've errored, as op flags are often left in an 926 * inconsistent state then. Note that an error when 927 * compiling the main program leaves PL_parser NULL, so 928 * we can't spot faults in the main code, only 929 * evaled/required code */ 930 #ifdef DEBUGGING 931 if ( o->op_ppaddr == PL_ppaddr[type] 932 && PL_parser 933 && !PL_parser->error_count) 934 { 935 assert(!(o->op_private & ~PL_op_private_valid[type])); 936 } 937 #endif 938 939 940 /* Call the op_free hook if it has been set. Do it now so that it's called 941 * at the right time for refcounted ops, but still before all of the kids 942 * are freed. */ 943 CALL_OPFREEHOOK(o); 944 945 if (type == OP_NULL) 946 type = (OPCODE)o->op_targ; 947 948 if (o->op_slabbed) 949 Slab_to_rw(OpSLAB(o)); 950 951 /* COP* is not cleared by op_clear() so that we may track line 952 * numbers etc even after null() */ 953 if (type == OP_NEXTSTATE || type == OP_DBSTATE) { 954 cop_free((COP*)o); 955 } 956 957 op_clear(o); 958 FreeOp(o); 959 if (PL_op == o) 960 PL_op = NULL; 961 } 962 } 963 964 965 /* S_op_clear_gv(): free a GV attached to an OP */ 966 967 STATIC 968 #ifdef USE_ITHREADS 969 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp) 970 #else 971 void S_op_clear_gv(pTHX_ OP *o, SV**svp) 972 #endif 973 { 974 975 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV 976 || o->op_type == OP_MULTIDEREF) 977 #ifdef USE_ITHREADS 978 && PL_curpad 979 ? ((GV*)PAD_SVl(*ixp)) : NULL; 980 #else 981 ? (GV*)(*svp) : NULL; 982 #endif 983 /* It's possible during global destruction that the GV is freed 984 before the optree. Whilst the SvREFCNT_inc is happy to bump from 985 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0 986 will trigger an assertion failure, because the entry to sv_clear 987 checks that the scalar is not already freed. A check of for 988 !SvIS_FREED(gv) turns out to be invalid, because during global 989 destruction the reference count can be forced down to zero 990 (with SVf_BREAK set). In which case raising to 1 and then 991 dropping to 0 triggers cleanup before it should happen. I 992 *think* that this might actually be a general, systematic, 993 weakness of the whole idea of SVf_BREAK, in that code *is* 994 allowed to raise and lower references during global destruction, 995 so any *valid* code that happens to do this during global 996 destruction might well trigger premature cleanup. */ 997 bool still_valid = gv && SvREFCNT(gv); 998 999 if (still_valid) 1000 SvREFCNT_inc_simple_void(gv); 1001 #ifdef USE_ITHREADS 1002 if (*ixp > 0) { 1003 pad_swipe(*ixp, TRUE); 1004 *ixp = 0; 1005 } 1006 #else 1007 SvREFCNT_dec(*svp); 1008 *svp = NULL; 1009 #endif 1010 if (still_valid) { 1011 int try_downgrade = SvREFCNT(gv) == 2; 1012 SvREFCNT_dec_NN(gv); 1013 if (try_downgrade) 1014 gv_try_downgrade(gv); 1015 } 1016 } 1017 1018 1019 void 1020 Perl_op_clear(pTHX_ OP *o) 1021 { 1022 1023 dVAR; 1024 1025 PERL_ARGS_ASSERT_OP_CLEAR; 1026 1027 switch (o->op_type) { 1028 case OP_NULL: /* Was holding old type, if any. */ 1029 /* FALLTHROUGH */ 1030 case OP_ENTERTRY: 1031 case OP_ENTEREVAL: /* Was holding hints. */ 1032 case OP_ARGDEFELEM: /* Was holding signature index. */ 1033 o->op_targ = 0; 1034 break; 1035 default: 1036 if (!(o->op_flags & OPf_REF) || !OP_IS_STAT(o->op_type)) 1037 break; 1038 /* FALLTHROUGH */ 1039 case OP_GVSV: 1040 case OP_GV: 1041 case OP_AELEMFAST: 1042 #ifdef USE_ITHREADS 1043 S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix)); 1044 #else 1045 S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv)); 1046 #endif 1047 break; 1048 case OP_METHOD_REDIR: 1049 case OP_METHOD_REDIR_SUPER: 1050 #ifdef USE_ITHREADS 1051 if (cMETHOPx(o)->op_rclass_targ) { 1052 pad_swipe(cMETHOPx(o)->op_rclass_targ, 1); 1053 cMETHOPx(o)->op_rclass_targ = 0; 1054 } 1055 #else 1056 SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv); 1057 cMETHOPx(o)->op_rclass_sv = NULL; 1058 #endif 1059 /* FALLTHROUGH */ 1060 case OP_METHOD_NAMED: 1061 case OP_METHOD_SUPER: 1062 SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv); 1063 cMETHOPx(o)->op_u.op_meth_sv = NULL; 1064 #ifdef USE_ITHREADS 1065 if (o->op_targ) { 1066 pad_swipe(o->op_targ, 1); 1067 o->op_targ = 0; 1068 } 1069 #endif 1070 break; 1071 case OP_CONST: 1072 case OP_HINTSEVAL: 1073 SvREFCNT_dec(cSVOPo->op_sv); 1074 cSVOPo->op_sv = NULL; 1075 #ifdef USE_ITHREADS 1076 /** Bug #15654 1077 Even if op_clear does a pad_free for the target of the op, 1078 pad_free doesn't actually remove the sv that exists in the pad; 1079 instead it lives on. This results in that it could be reused as 1080 a target later on when the pad was reallocated. 1081 **/ 1082 if(o->op_targ) { 1083 pad_swipe(o->op_targ,1); 1084 o->op_targ = 0; 1085 } 1086 #endif 1087 break; 1088 case OP_DUMP: 1089 case OP_GOTO: 1090 case OP_NEXT: 1091 case OP_LAST: 1092 case OP_REDO: 1093 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS)) 1094 break; 1095 /* FALLTHROUGH */ 1096 case OP_TRANS: 1097 case OP_TRANSR: 1098 if ( (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) 1099 && (o->op_private & OPpTRANS_USE_SVOP)) 1100 { 1101 #ifdef USE_ITHREADS 1102 if (cPADOPo->op_padix > 0) { 1103 pad_swipe(cPADOPo->op_padix, TRUE); 1104 cPADOPo->op_padix = 0; 1105 } 1106 #else 1107 SvREFCNT_dec(cSVOPo->op_sv); 1108 cSVOPo->op_sv = NULL; 1109 #endif 1110 } 1111 else { 1112 PerlMemShared_free(cPVOPo->op_pv); 1113 cPVOPo->op_pv = NULL; 1114 } 1115 break; 1116 case OP_SUBST: 1117 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot); 1118 goto clear_pmop; 1119 1120 case OP_SPLIT: 1121 if ( (o->op_private & OPpSPLIT_ASSIGN) /* @array = split */ 1122 && !(o->op_flags & OPf_STACKED)) /* @{expr} = split */ 1123 { 1124 if (o->op_private & OPpSPLIT_LEX) 1125 pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff); 1126 else 1127 #ifdef USE_ITHREADS 1128 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE); 1129 #else 1130 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv)); 1131 #endif 1132 } 1133 /* FALLTHROUGH */ 1134 case OP_MATCH: 1135 case OP_QR: 1136 clear_pmop: 1137 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE)) 1138 op_free(cPMOPo->op_code_list); 1139 cPMOPo->op_code_list = NULL; 1140 forget_pmop(cPMOPo); 1141 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL; 1142 /* we use the same protection as the "SAFE" version of the PM_ macros 1143 * here since sv_clean_all might release some PMOPs 1144 * after PL_regex_padav has been cleared 1145 * and the clearing of PL_regex_padav needs to 1146 * happen before sv_clean_all 1147 */ 1148 #ifdef USE_ITHREADS 1149 if(PL_regex_pad) { /* We could be in destruction */ 1150 const IV offset = (cPMOPo)->op_pmoffset; 1151 ReREFCNT_dec(PM_GETRE(cPMOPo)); 1152 PL_regex_pad[offset] = &PL_sv_undef; 1153 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset, 1154 sizeof(offset)); 1155 } 1156 #else 1157 ReREFCNT_dec(PM_GETRE(cPMOPo)); 1158 PM_SETRE(cPMOPo, NULL); 1159 #endif 1160 1161 break; 1162 1163 case OP_ARGCHECK: 1164 PerlMemShared_free(cUNOP_AUXo->op_aux); 1165 break; 1166 1167 case OP_MULTICONCAT: 1168 { 1169 UNOP_AUX_item *aux = cUNOP_AUXo->op_aux; 1170 /* aux[PERL_MULTICONCAT_IX_PLAIN_PV] and/or 1171 * aux[PERL_MULTICONCAT_IX_UTF8_PV] point to plain and/or 1172 * utf8 shared strings */ 1173 char *p1 = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv; 1174 char *p2 = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv; 1175 if (p1) 1176 PerlMemShared_free(p1); 1177 if (p2 && p1 != p2) 1178 PerlMemShared_free(p2); 1179 PerlMemShared_free(aux); 1180 } 1181 break; 1182 1183 case OP_MULTIDEREF: 1184 { 1185 UNOP_AUX_item *items = cUNOP_AUXo->op_aux; 1186 UV actions = items->uv; 1187 bool last = 0; 1188 bool is_hash = FALSE; 1189 1190 while (!last) { 1191 switch (actions & MDEREF_ACTION_MASK) { 1192 1193 case MDEREF_reload: 1194 actions = (++items)->uv; 1195 continue; 1196 1197 case MDEREF_HV_padhv_helem: 1198 is_hash = TRUE; 1199 /* FALLTHROUGH */ 1200 case MDEREF_AV_padav_aelem: 1201 pad_free((++items)->pad_offset); 1202 goto do_elem; 1203 1204 case MDEREF_HV_gvhv_helem: 1205 is_hash = TRUE; 1206 /* FALLTHROUGH */ 1207 case MDEREF_AV_gvav_aelem: 1208 #ifdef USE_ITHREADS 1209 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset)); 1210 #else 1211 S_op_clear_gv(aTHX_ o, &((++items)->sv)); 1212 #endif 1213 goto do_elem; 1214 1215 case MDEREF_HV_gvsv_vivify_rv2hv_helem: 1216 is_hash = TRUE; 1217 /* FALLTHROUGH */ 1218 case MDEREF_AV_gvsv_vivify_rv2av_aelem: 1219 #ifdef USE_ITHREADS 1220 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset)); 1221 #else 1222 S_op_clear_gv(aTHX_ o, &((++items)->sv)); 1223 #endif 1224 goto do_vivify_rv2xv_elem; 1225 1226 case MDEREF_HV_padsv_vivify_rv2hv_helem: 1227 is_hash = TRUE; 1228 /* FALLTHROUGH */ 1229 case MDEREF_AV_padsv_vivify_rv2av_aelem: 1230 pad_free((++items)->pad_offset); 1231 goto do_vivify_rv2xv_elem; 1232 1233 case MDEREF_HV_pop_rv2hv_helem: 1234 case MDEREF_HV_vivify_rv2hv_helem: 1235 is_hash = TRUE; 1236 /* FALLTHROUGH */ 1237 do_vivify_rv2xv_elem: 1238 case MDEREF_AV_pop_rv2av_aelem: 1239 case MDEREF_AV_vivify_rv2av_aelem: 1240 do_elem: 1241 switch (actions & MDEREF_INDEX_MASK) { 1242 case MDEREF_INDEX_none: 1243 last = 1; 1244 break; 1245 case MDEREF_INDEX_const: 1246 if (is_hash) { 1247 #ifdef USE_ITHREADS 1248 /* see RT #15654 */ 1249 pad_swipe((++items)->pad_offset, 1); 1250 #else 1251 SvREFCNT_dec((++items)->sv); 1252 #endif 1253 } 1254 else 1255 items++; 1256 break; 1257 case MDEREF_INDEX_padsv: 1258 pad_free((++items)->pad_offset); 1259 break; 1260 case MDEREF_INDEX_gvsv: 1261 #ifdef USE_ITHREADS 1262 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset)); 1263 #else 1264 S_op_clear_gv(aTHX_ o, &((++items)->sv)); 1265 #endif 1266 break; 1267 } 1268 1269 if (actions & MDEREF_FLAG_last) 1270 last = 1; 1271 is_hash = FALSE; 1272 1273 break; 1274 1275 default: 1276 assert(0); 1277 last = 1; 1278 break; 1279 1280 } /* switch */ 1281 1282 actions >>= MDEREF_SHIFT; 1283 } /* while */ 1284 1285 /* start of malloc is at op_aux[-1], where the length is 1286 * stored */ 1287 PerlMemShared_free(cUNOP_AUXo->op_aux - 1); 1288 } 1289 break; 1290 } 1291 1292 if (o->op_targ > 0) { 1293 pad_free(o->op_targ); 1294 o->op_targ = 0; 1295 } 1296 } 1297 1298 STATIC void 1299 S_cop_free(pTHX_ COP* cop) 1300 { 1301 PERL_ARGS_ASSERT_COP_FREE; 1302 1303 CopFILE_free(cop); 1304 if (! specialWARN(cop->cop_warnings)) 1305 PerlMemShared_free(cop->cop_warnings); 1306 cophh_free(CopHINTHASH_get(cop)); 1307 if (PL_curcop == cop) 1308 PL_curcop = NULL; 1309 } 1310 1311 STATIC void 1312 S_forget_pmop(pTHX_ PMOP *const o) 1313 { 1314 HV * const pmstash = PmopSTASH(o); 1315 1316 PERL_ARGS_ASSERT_FORGET_PMOP; 1317 1318 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) { 1319 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab); 1320 if (mg) { 1321 PMOP **const array = (PMOP**) mg->mg_ptr; 1322 U32 count = mg->mg_len / sizeof(PMOP**); 1323 U32 i = count; 1324 1325 while (i--) { 1326 if (array[i] == o) { 1327 /* Found it. Move the entry at the end to overwrite it. */ 1328 array[i] = array[--count]; 1329 mg->mg_len = count * sizeof(PMOP**); 1330 /* Could realloc smaller at this point always, but probably 1331 not worth it. Probably worth free()ing if we're the 1332 last. */ 1333 if(!count) { 1334 Safefree(mg->mg_ptr); 1335 mg->mg_ptr = NULL; 1336 } 1337 break; 1338 } 1339 } 1340 } 1341 } 1342 if (PL_curpm == o) 1343 PL_curpm = NULL; 1344 } 1345 1346 1347 STATIC void 1348 S_find_and_forget_pmops(pTHX_ OP *o) 1349 { 1350 OP* top_op = o; 1351 1352 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS; 1353 1354 while (1) { 1355 switch (o->op_type) { 1356 case OP_SUBST: 1357 case OP_SPLIT: 1358 case OP_MATCH: 1359 case OP_QR: 1360 forget_pmop((PMOP*)o); 1361 } 1362 1363 if (o->op_flags & OPf_KIDS) { 1364 o = cUNOPo->op_first; 1365 continue; 1366 } 1367 1368 while (1) { 1369 if (o == top_op) 1370 return; /* at top; no parents/siblings to try */ 1371 if (OpHAS_SIBLING(o)) { 1372 o = o->op_sibparent; /* process next sibling */ 1373 break; 1374 } 1375 o = o->op_sibparent; /*try parent's next sibling */ 1376 } 1377 } 1378 } 1379 1380 1381 /* 1382 =for apidoc op_null 1383 1384 Neutralizes an op when it is no longer needed, but is still linked to from 1385 other ops. 1386 1387 =cut 1388 */ 1389 1390 void 1391 Perl_op_null(pTHX_ OP *o) 1392 { 1393 dVAR; 1394 1395 PERL_ARGS_ASSERT_OP_NULL; 1396 1397 if (o->op_type == OP_NULL) 1398 return; 1399 op_clear(o); 1400 o->op_targ = o->op_type; 1401 OpTYPE_set(o, OP_NULL); 1402 } 1403 1404 void 1405 Perl_op_refcnt_lock(pTHX) 1406 PERL_TSA_ACQUIRE(PL_op_mutex) 1407 { 1408 #ifdef USE_ITHREADS 1409 dVAR; 1410 #endif 1411 PERL_UNUSED_CONTEXT; 1412 OP_REFCNT_LOCK; 1413 } 1414 1415 void 1416 Perl_op_refcnt_unlock(pTHX) 1417 PERL_TSA_RELEASE(PL_op_mutex) 1418 { 1419 #ifdef USE_ITHREADS 1420 dVAR; 1421 #endif 1422 PERL_UNUSED_CONTEXT; 1423 OP_REFCNT_UNLOCK; 1424 } 1425 1426 1427 /* 1428 =for apidoc op_sibling_splice 1429 1430 A general function for editing the structure of an existing chain of 1431 op_sibling nodes. By analogy with the perl-level C<splice()> function, allows 1432 you to delete zero or more sequential nodes, replacing them with zero or 1433 more different nodes. Performs the necessary op_first/op_last 1434 housekeeping on the parent node and op_sibling manipulation on the 1435 children. The last deleted node will be marked as the last node by 1436 updating the op_sibling/op_sibparent or op_moresib field as appropriate. 1437 1438 Note that op_next is not manipulated, and nodes are not freed; that is the 1439 responsibility of the caller. It also won't create a new list op for an 1440 empty list etc; use higher-level functions like op_append_elem() for that. 1441 1442 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if 1443 the splicing doesn't affect the first or last op in the chain. 1444 1445 C<start> is the node preceding the first node to be spliced. Node(s) 1446 following it will be deleted, and ops will be inserted after it. If it is 1447 C<NULL>, the first node onwards is deleted, and nodes are inserted at the 1448 beginning. 1449 1450 C<del_count> is the number of nodes to delete. If zero, no nodes are deleted. 1451 If -1 or greater than or equal to the number of remaining kids, all 1452 remaining kids are deleted. 1453 1454 C<insert> is the first of a chain of nodes to be inserted in place of the nodes. 1455 If C<NULL>, no nodes are inserted. 1456 1457 The head of the chain of deleted ops is returned, or C<NULL> if no ops were 1458 deleted. 1459 1460 For example: 1461 1462 action before after returns 1463 ------ ----- ----- ------- 1464 1465 P P 1466 splice(P, A, 2, X-Y-Z) | | B-C 1467 A-B-C-D A-X-Y-Z-D 1468 1469 P P 1470 splice(P, NULL, 1, X-Y) | | A 1471 A-B-C-D X-Y-B-C-D 1472 1473 P P 1474 splice(P, NULL, 3, NULL) | | A-B-C 1475 A-B-C-D D 1476 1477 P P 1478 splice(P, B, 0, X-Y) | | NULL 1479 A-B-C-D A-B-X-Y-C-D 1480 1481 1482 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>, 1483 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>. 1484 1485 =cut 1486 */ 1487 1488 OP * 1489 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert) 1490 { 1491 OP *first; 1492 OP *rest; 1493 OP *last_del = NULL; 1494 OP *last_ins = NULL; 1495 1496 if (start) 1497 first = OpSIBLING(start); 1498 else if (!parent) 1499 goto no_parent; 1500 else 1501 first = cLISTOPx(parent)->op_first; 1502 1503 assert(del_count >= -1); 1504 1505 if (del_count && first) { 1506 last_del = first; 1507 while (--del_count && OpHAS_SIBLING(last_del)) 1508 last_del = OpSIBLING(last_del); 1509 rest = OpSIBLING(last_del); 1510 OpLASTSIB_set(last_del, NULL); 1511 } 1512 else 1513 rest = first; 1514 1515 if (insert) { 1516 last_ins = insert; 1517 while (OpHAS_SIBLING(last_ins)) 1518 last_ins = OpSIBLING(last_ins); 1519 OpMAYBESIB_set(last_ins, rest, NULL); 1520 } 1521 else 1522 insert = rest; 1523 1524 if (start) { 1525 OpMAYBESIB_set(start, insert, NULL); 1526 } 1527 else { 1528 assert(parent); 1529 cLISTOPx(parent)->op_first = insert; 1530 if (insert) 1531 parent->op_flags |= OPf_KIDS; 1532 else 1533 parent->op_flags &= ~OPf_KIDS; 1534 } 1535 1536 if (!rest) { 1537 /* update op_last etc */ 1538 U32 type; 1539 OP *lastop; 1540 1541 if (!parent) 1542 goto no_parent; 1543 1544 /* ought to use OP_CLASS(parent) here, but that can't handle 1545 * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't 1546 * either */ 1547 type = parent->op_type; 1548 if (type == OP_CUSTOM) { 1549 dTHX; 1550 type = XopENTRYCUSTOM(parent, xop_class); 1551 } 1552 else { 1553 if (type == OP_NULL) 1554 type = parent->op_targ; 1555 type = PL_opargs[type] & OA_CLASS_MASK; 1556 } 1557 1558 lastop = last_ins ? last_ins : start ? start : NULL; 1559 if ( type == OA_BINOP 1560 || type == OA_LISTOP 1561 || type == OA_PMOP 1562 || type == OA_LOOP 1563 ) 1564 cLISTOPx(parent)->op_last = lastop; 1565 1566 if (lastop) 1567 OpLASTSIB_set(lastop, parent); 1568 } 1569 return last_del ? first : NULL; 1570 1571 no_parent: 1572 Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent"); 1573 } 1574 1575 /* 1576 =for apidoc op_parent 1577 1578 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise. 1579 1580 =cut 1581 */ 1582 1583 OP * 1584 Perl_op_parent(OP *o) 1585 { 1586 PERL_ARGS_ASSERT_OP_PARENT; 1587 while (OpHAS_SIBLING(o)) 1588 o = OpSIBLING(o); 1589 return o->op_sibparent; 1590 } 1591 1592 /* replace the sibling following start with a new UNOP, which becomes 1593 * the parent of the original sibling; e.g. 1594 * 1595 * op_sibling_newUNOP(P, A, unop-args...) 1596 * 1597 * P P 1598 * | becomes | 1599 * A-B-C A-U-C 1600 * | 1601 * B 1602 * 1603 * where U is the new UNOP. 1604 * 1605 * parent and start args are the same as for op_sibling_splice(); 1606 * type and flags args are as newUNOP(). 1607 * 1608 * Returns the new UNOP. 1609 */ 1610 1611 STATIC OP * 1612 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags) 1613 { 1614 OP *kid, *newop; 1615 1616 kid = op_sibling_splice(parent, start, 1, NULL); 1617 newop = newUNOP(type, flags, kid); 1618 op_sibling_splice(parent, start, 0, newop); 1619 return newop; 1620 } 1621 1622 1623 /* lowest-level newLOGOP-style function - just allocates and populates 1624 * the struct. Higher-level stuff should be done by S_new_logop() / 1625 * newLOGOP(). This function exists mainly to avoid op_first assignment 1626 * being spread throughout this file. 1627 */ 1628 1629 LOGOP * 1630 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other) 1631 { 1632 dVAR; 1633 LOGOP *logop; 1634 OP *kid = first; 1635 NewOp(1101, logop, 1, LOGOP); 1636 OpTYPE_set(logop, type); 1637 logop->op_first = first; 1638 logop->op_other = other; 1639 if (first) 1640 logop->op_flags = OPf_KIDS; 1641 while (kid && OpHAS_SIBLING(kid)) 1642 kid = OpSIBLING(kid); 1643 if (kid) 1644 OpLASTSIB_set(kid, (OP*)logop); 1645 return logop; 1646 } 1647 1648 1649 /* Contextualizers */ 1650 1651 /* 1652 =for apidoc op_contextualize 1653 1654 Applies a syntactic context to an op tree representing an expression. 1655 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>, 1656 or C<G_VOID> to specify the context to apply. The modified op tree 1657 is returned. 1658 1659 =cut 1660 */ 1661 1662 OP * 1663 Perl_op_contextualize(pTHX_ OP *o, I32 context) 1664 { 1665 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE; 1666 switch (context) { 1667 case G_SCALAR: return scalar(o); 1668 case G_ARRAY: return list(o); 1669 case G_VOID: return scalarvoid(o); 1670 default: 1671 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld", 1672 (long) context); 1673 } 1674 } 1675 1676 /* 1677 1678 =for apidoc op_linklist 1679 This function is the implementation of the L</LINKLIST> macro. It should 1680 not be called directly. 1681 1682 =cut 1683 */ 1684 1685 1686 OP * 1687 Perl_op_linklist(pTHX_ OP *o) 1688 { 1689 1690 OP **prevp; 1691 OP *kid; 1692 OP * top_op = o; 1693 1694 PERL_ARGS_ASSERT_OP_LINKLIST; 1695 1696 while (1) { 1697 /* Descend down the tree looking for any unprocessed subtrees to 1698 * do first */ 1699 if (!o->op_next) { 1700 if (o->op_flags & OPf_KIDS) { 1701 o = cUNOPo->op_first; 1702 continue; 1703 } 1704 o->op_next = o; /* leaf node; link to self initially */ 1705 } 1706 1707 /* if we're at the top level, there either weren't any children 1708 * to process, or we've worked our way back to the top. */ 1709 if (o == top_op) 1710 return o->op_next; 1711 1712 /* o is now processed. Next, process any sibling subtrees */ 1713 1714 if (OpHAS_SIBLING(o)) { 1715 o = OpSIBLING(o); 1716 continue; 1717 } 1718 1719 /* Done all the subtrees at this level. Go back up a level and 1720 * link the parent in with all its (processed) children. 1721 */ 1722 1723 o = o->op_sibparent; 1724 assert(!o->op_next); 1725 prevp = &(o->op_next); 1726 kid = (o->op_flags & OPf_KIDS) ? cUNOPo->op_first : NULL; 1727 while (kid) { 1728 *prevp = kid->op_next; 1729 prevp = &(kid->op_next); 1730 kid = OpSIBLING(kid); 1731 } 1732 *prevp = o; 1733 } 1734 } 1735 1736 1737 static OP * 1738 S_scalarkids(pTHX_ OP *o) 1739 { 1740 if (o && o->op_flags & OPf_KIDS) { 1741 OP *kid; 1742 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) 1743 scalar(kid); 1744 } 1745 return o; 1746 } 1747 1748 STATIC OP * 1749 S_scalarboolean(pTHX_ OP *o) 1750 { 1751 PERL_ARGS_ASSERT_SCALARBOOLEAN; 1752 1753 if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST && 1754 !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) || 1755 (o->op_type == OP_NOT && cUNOPo->op_first->op_type == OP_SASSIGN && 1756 cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST && 1757 !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) { 1758 if (ckWARN(WARN_SYNTAX)) { 1759 const line_t oldline = CopLINE(PL_curcop); 1760 1761 if (PL_parser && PL_parser->copline != NOLINE) { 1762 /* This ensures that warnings are reported at the first line 1763 of the conditional, not the last. */ 1764 CopLINE_set(PL_curcop, PL_parser->copline); 1765 } 1766 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be =="); 1767 CopLINE_set(PL_curcop, oldline); 1768 } 1769 } 1770 return scalar(o); 1771 } 1772 1773 static SV * 1774 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type) 1775 { 1776 assert(o); 1777 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV || 1778 o->op_type == OP_PADHV || o->op_type == OP_RV2HV); 1779 { 1780 const char funny = o->op_type == OP_PADAV 1781 || o->op_type == OP_RV2AV ? '@' : '%'; 1782 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) { 1783 GV *gv; 1784 if (cUNOPo->op_first->op_type != OP_GV 1785 || !(gv = cGVOPx_gv(cUNOPo->op_first))) 1786 return NULL; 1787 return varname(gv, funny, 0, NULL, 0, subscript_type); 1788 } 1789 return 1790 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type); 1791 } 1792 } 1793 1794 static SV * 1795 S_op_varname(pTHX_ const OP *o) 1796 { 1797 return S_op_varname_subscript(aTHX_ o, 1); 1798 } 1799 1800 static void 1801 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv) 1802 { /* or not so pretty :-) */ 1803 if (o->op_type == OP_CONST) { 1804 *retsv = cSVOPo_sv; 1805 if (SvPOK(*retsv)) { 1806 SV *sv = *retsv; 1807 *retsv = sv_newmortal(); 1808 pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL, 1809 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT); 1810 } 1811 else if (!SvOK(*retsv)) 1812 *retpv = "undef"; 1813 } 1814 else *retpv = "..."; 1815 } 1816 1817 static void 1818 S_scalar_slice_warning(pTHX_ const OP *o) 1819 { 1820 OP *kid; 1821 const bool h = o->op_type == OP_HSLICE 1822 || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE); 1823 const char lbrack = 1824 h ? '{' : '['; 1825 const char rbrack = 1826 h ? '}' : ']'; 1827 SV *name; 1828 SV *keysv = NULL; /* just to silence compiler warnings */ 1829 const char *key = NULL; 1830 1831 if (!(o->op_private & OPpSLICEWARNING)) 1832 return; 1833 if (PL_parser && PL_parser->error_count) 1834 /* This warning can be nonsensical when there is a syntax error. */ 1835 return; 1836 1837 kid = cLISTOPo->op_first; 1838 kid = OpSIBLING(kid); /* get past pushmark */ 1839 /* weed out false positives: any ops that can return lists */ 1840 switch (kid->op_type) { 1841 case OP_BACKTICK: 1842 case OP_GLOB: 1843 case OP_READLINE: 1844 case OP_MATCH: 1845 case OP_RV2AV: 1846 case OP_EACH: 1847 case OP_VALUES: 1848 case OP_KEYS: 1849 case OP_SPLIT: 1850 case OP_LIST: 1851 case OP_SORT: 1852 case OP_REVERSE: 1853 case OP_ENTERSUB: 1854 case OP_CALLER: 1855 case OP_LSTAT: 1856 case OP_STAT: 1857 case OP_READDIR: 1858 case OP_SYSTEM: 1859 case OP_TMS: 1860 case OP_LOCALTIME: 1861 case OP_GMTIME: 1862 case OP_ENTEREVAL: 1863 return; 1864 } 1865 1866 /* Don't warn if we have a nulled list either. */ 1867 if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST) 1868 return; 1869 1870 assert(OpSIBLING(kid)); 1871 name = S_op_varname(aTHX_ OpSIBLING(kid)); 1872 if (!name) /* XS module fiddling with the op tree */ 1873 return; 1874 S_op_pretty(aTHX_ kid, &keysv, &key); 1875 assert(SvPOK(name)); 1876 sv_chop(name,SvPVX(name)+1); 1877 if (key) 1878 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */ 1879 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 1880 "Scalar value @%" SVf "%c%s%c better written as $%" SVf 1881 "%c%s%c", 1882 SVfARG(name), lbrack, key, rbrack, SVfARG(name), 1883 lbrack, key, rbrack); 1884 else 1885 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */ 1886 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 1887 "Scalar value @%" SVf "%c%" SVf "%c better written as $%" 1888 SVf "%c%" SVf "%c", 1889 SVfARG(name), lbrack, SVfARG(keysv), rbrack, 1890 SVfARG(name), lbrack, SVfARG(keysv), rbrack); 1891 } 1892 1893 1894 1895 /* apply scalar context to the o subtree */ 1896 1897 OP * 1898 Perl_scalar(pTHX_ OP *o) 1899 { 1900 OP * top_op = o; 1901 1902 while (1) { 1903 OP *next_kid = NULL; /* what op (if any) to process next */ 1904 OP *kid; 1905 1906 /* assumes no premature commitment */ 1907 if (!o || (PL_parser && PL_parser->error_count) 1908 || (o->op_flags & OPf_WANT) 1909 || o->op_type == OP_RETURN) 1910 { 1911 goto do_next; 1912 } 1913 1914 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR; 1915 1916 switch (o->op_type) { 1917 case OP_REPEAT: 1918 scalar(cBINOPo->op_first); 1919 /* convert what initially looked like a list repeat into a 1920 * scalar repeat, e.g. $s = (1) x $n 1921 */ 1922 if (o->op_private & OPpREPEAT_DOLIST) { 1923 kid = cLISTOPx(cUNOPo->op_first)->op_first; 1924 assert(kid->op_type == OP_PUSHMARK); 1925 if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) { 1926 op_null(cLISTOPx(cUNOPo->op_first)->op_first); 1927 o->op_private &=~ OPpREPEAT_DOLIST; 1928 } 1929 } 1930 break; 1931 1932 case OP_OR: 1933 case OP_AND: 1934 case OP_COND_EXPR: 1935 /* impose scalar context on everything except the condition */ 1936 next_kid = OpSIBLING(cUNOPo->op_first); 1937 break; 1938 1939 default: 1940 if (o->op_flags & OPf_KIDS) 1941 next_kid = cUNOPo->op_first; /* do all kids */ 1942 break; 1943 1944 /* the children of these ops are usually a list of statements, 1945 * except the leaves, whose first child is a corresponding enter 1946 */ 1947 case OP_SCOPE: 1948 case OP_LINESEQ: 1949 case OP_LIST: 1950 kid = cLISTOPo->op_first; 1951 goto do_kids; 1952 case OP_LEAVE: 1953 case OP_LEAVETRY: 1954 kid = cLISTOPo->op_first; 1955 scalar(kid); 1956 kid = OpSIBLING(kid); 1957 do_kids: 1958 while (kid) { 1959 OP *sib = OpSIBLING(kid); 1960 /* Apply void context to all kids except the last, which 1961 * is scalar (ignoring a trailing ex-nextstate in determining 1962 * if it's the last kid). E.g. 1963 * $scalar = do { void; void; scalar } 1964 * Except that 'when's are always scalar, e.g. 1965 * $scalar = do { given(..) { 1966 * when (..) { scalar } 1967 * when (..) { scalar } 1968 * ... 1969 * }} 1970 */ 1971 if (!sib 1972 || ( !OpHAS_SIBLING(sib) 1973 && sib->op_type == OP_NULL 1974 && ( sib->op_targ == OP_NEXTSTATE 1975 || sib->op_targ == OP_DBSTATE ) 1976 ) 1977 ) 1978 { 1979 /* tail call optimise calling scalar() on the last kid */ 1980 next_kid = kid; 1981 goto do_next; 1982 } 1983 else if (kid->op_type == OP_LEAVEWHEN) 1984 scalar(kid); 1985 else 1986 scalarvoid(kid); 1987 kid = sib; 1988 } 1989 NOT_REACHED; /* NOTREACHED */ 1990 break; 1991 1992 case OP_SORT: 1993 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context"); 1994 break; 1995 1996 case OP_KVHSLICE: 1997 case OP_KVASLICE: 1998 { 1999 /* Warn about scalar context */ 2000 const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '['; 2001 const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']'; 2002 SV *name; 2003 SV *keysv; 2004 const char *key = NULL; 2005 2006 /* This warning can be nonsensical when there is a syntax error. */ 2007 if (PL_parser && PL_parser->error_count) 2008 break; 2009 2010 if (!ckWARN(WARN_SYNTAX)) break; 2011 2012 kid = cLISTOPo->op_first; 2013 kid = OpSIBLING(kid); /* get past pushmark */ 2014 assert(OpSIBLING(kid)); 2015 name = S_op_varname(aTHX_ OpSIBLING(kid)); 2016 if (!name) /* XS module fiddling with the op tree */ 2017 break; 2018 S_op_pretty(aTHX_ kid, &keysv, &key); 2019 assert(SvPOK(name)); 2020 sv_chop(name,SvPVX(name)+1); 2021 if (key) 2022 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */ 2023 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 2024 "%%%" SVf "%c%s%c in scalar context better written " 2025 "as $%" SVf "%c%s%c", 2026 SVfARG(name), lbrack, key, rbrack, SVfARG(name), 2027 lbrack, key, rbrack); 2028 else 2029 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */ 2030 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 2031 "%%%" SVf "%c%" SVf "%c in scalar context better " 2032 "written as $%" SVf "%c%" SVf "%c", 2033 SVfARG(name), lbrack, SVfARG(keysv), rbrack, 2034 SVfARG(name), lbrack, SVfARG(keysv), rbrack); 2035 } 2036 } /* switch */ 2037 2038 /* If next_kid is set, someone in the code above wanted us to process 2039 * that kid and all its remaining siblings. Otherwise, work our way 2040 * back up the tree */ 2041 do_next: 2042 while (!next_kid) { 2043 if (o == top_op) 2044 return top_op; /* at top; no parents/siblings to try */ 2045 if (OpHAS_SIBLING(o)) 2046 next_kid = o->op_sibparent; 2047 else { 2048 o = o->op_sibparent; /*try parent's next sibling */ 2049 switch (o->op_type) { 2050 case OP_SCOPE: 2051 case OP_LINESEQ: 2052 case OP_LIST: 2053 case OP_LEAVE: 2054 case OP_LEAVETRY: 2055 /* should really restore PL_curcop to its old value, but 2056 * setting it to PL_compiling is better than do nothing */ 2057 PL_curcop = &PL_compiling; 2058 } 2059 } 2060 } 2061 o = next_kid; 2062 } /* while */ 2063 } 2064 2065 2066 /* apply void context to the optree arg */ 2067 2068 OP * 2069 Perl_scalarvoid(pTHX_ OP *arg) 2070 { 2071 dVAR; 2072 OP *kid; 2073 SV* sv; 2074 OP *o = arg; 2075 2076 PERL_ARGS_ASSERT_SCALARVOID; 2077 2078 while (1) { 2079 U8 want; 2080 SV *useless_sv = NULL; 2081 const char* useless = NULL; 2082 OP * next_kid = NULL; 2083 2084 if (o->op_type == OP_NEXTSTATE 2085 || o->op_type == OP_DBSTATE 2086 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE 2087 || o->op_targ == OP_DBSTATE))) 2088 PL_curcop = (COP*)o; /* for warning below */ 2089 2090 /* assumes no premature commitment */ 2091 want = o->op_flags & OPf_WANT; 2092 if ((want && want != OPf_WANT_SCALAR) 2093 || (PL_parser && PL_parser->error_count) 2094 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN) 2095 { 2096 goto get_next_op; 2097 } 2098 2099 if ((o->op_private & OPpTARGET_MY) 2100 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */ 2101 { 2102 /* newASSIGNOP has already applied scalar context, which we 2103 leave, as if this op is inside SASSIGN. */ 2104 goto get_next_op; 2105 } 2106 2107 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID; 2108 2109 switch (o->op_type) { 2110 default: 2111 if (!(PL_opargs[o->op_type] & OA_FOLDCONST)) 2112 break; 2113 /* FALLTHROUGH */ 2114 case OP_REPEAT: 2115 if (o->op_flags & OPf_STACKED) 2116 break; 2117 if (o->op_type == OP_REPEAT) 2118 scalar(cBINOPo->op_first); 2119 goto func_ops; 2120 case OP_CONCAT: 2121 if ((o->op_flags & OPf_STACKED) && 2122 !(o->op_private & OPpCONCAT_NESTED)) 2123 break; 2124 goto func_ops; 2125 case OP_SUBSTR: 2126 if (o->op_private == 4) 2127 break; 2128 /* FALLTHROUGH */ 2129 case OP_WANTARRAY: 2130 case OP_GV: 2131 case OP_SMARTMATCH: 2132 case OP_AV2ARYLEN: 2133 case OP_REF: 2134 case OP_REFGEN: 2135 case OP_SREFGEN: 2136 case OP_DEFINED: 2137 case OP_HEX: 2138 case OP_OCT: 2139 case OP_LENGTH: 2140 case OP_VEC: 2141 case OP_INDEX: 2142 case OP_RINDEX: 2143 case OP_SPRINTF: 2144 case OP_KVASLICE: 2145 case OP_KVHSLICE: 2146 case OP_UNPACK: 2147 case OP_PACK: 2148 case OP_JOIN: 2149 case OP_LSLICE: 2150 case OP_ANONLIST: 2151 case OP_ANONHASH: 2152 case OP_SORT: 2153 case OP_REVERSE: 2154 case OP_RANGE: 2155 case OP_FLIP: 2156 case OP_FLOP: 2157 case OP_CALLER: 2158 case OP_FILENO: 2159 case OP_EOF: 2160 case OP_TELL: 2161 case OP_GETSOCKNAME: 2162 case OP_GETPEERNAME: 2163 case OP_READLINK: 2164 case OP_TELLDIR: 2165 case OP_GETPPID: 2166 case OP_GETPGRP: 2167 case OP_GETPRIORITY: 2168 case OP_TIME: 2169 case OP_TMS: 2170 case OP_LOCALTIME: 2171 case OP_GMTIME: 2172 case OP_GHBYNAME: 2173 case OP_GHBYADDR: 2174 case OP_GHOSTENT: 2175 case OP_GNBYNAME: 2176 case OP_GNBYADDR: 2177 case OP_GNETENT: 2178 case OP_GPBYNAME: 2179 case OP_GPBYNUMBER: 2180 case OP_GPROTOENT: 2181 case OP_GSBYNAME: 2182 case OP_GSBYPORT: 2183 case OP_GSERVENT: 2184 case OP_GPWNAM: 2185 case OP_GPWUID: 2186 case OP_GGRNAM: 2187 case OP_GGRGID: 2188 case OP_GETLOGIN: 2189 case OP_PROTOTYPE: 2190 case OP_RUNCV: 2191 func_ops: 2192 useless = OP_DESC(o); 2193 break; 2194 2195 case OP_GVSV: 2196 case OP_PADSV: 2197 case OP_PADAV: 2198 case OP_PADHV: 2199 case OP_PADANY: 2200 case OP_AELEM: 2201 case OP_AELEMFAST: 2202 case OP_AELEMFAST_LEX: 2203 case OP_ASLICE: 2204 case OP_HELEM: 2205 case OP_HSLICE: 2206 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO))) 2207 /* Otherwise it's "Useless use of grep iterator" */ 2208 useless = OP_DESC(o); 2209 break; 2210 2211 case OP_SPLIT: 2212 if (!(o->op_private & OPpSPLIT_ASSIGN)) 2213 useless = OP_DESC(o); 2214 break; 2215 2216 case OP_NOT: 2217 kid = cUNOPo->op_first; 2218 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST && 2219 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) { 2220 goto func_ops; 2221 } 2222 useless = "negative pattern binding (!~)"; 2223 break; 2224 2225 case OP_SUBST: 2226 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT) 2227 useless = "non-destructive substitution (s///r)"; 2228 break; 2229 2230 case OP_TRANSR: 2231 useless = "non-destructive transliteration (tr///r)"; 2232 break; 2233 2234 case OP_RV2GV: 2235 case OP_RV2SV: 2236 case OP_RV2AV: 2237 case OP_RV2HV: 2238 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) && 2239 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE)) 2240 useless = "a variable"; 2241 break; 2242 2243 case OP_CONST: 2244 sv = cSVOPo_sv; 2245 if (cSVOPo->op_private & OPpCONST_STRICT) 2246 no_bareword_allowed(o); 2247 else { 2248 if (ckWARN(WARN_VOID)) { 2249 NV nv; 2250 /* don't warn on optimised away booleans, eg 2251 * use constant Foo, 5; Foo || print; */ 2252 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT) 2253 useless = NULL; 2254 /* the constants 0 and 1 are permitted as they are 2255 conventionally used as dummies in constructs like 2256 1 while some_condition_with_side_effects; */ 2257 else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0)) 2258 useless = NULL; 2259 else if (SvPOK(sv)) { 2260 SV * const dsv = newSVpvs(""); 2261 useless_sv 2262 = Perl_newSVpvf(aTHX_ 2263 "a constant (%s)", 2264 pv_pretty(dsv, SvPVX_const(sv), 2265 SvCUR(sv), 32, NULL, NULL, 2266 PERL_PV_PRETTY_DUMP 2267 | PERL_PV_ESCAPE_NOCLEAR 2268 | PERL_PV_ESCAPE_UNI_DETECT)); 2269 SvREFCNT_dec_NN(dsv); 2270 } 2271 else if (SvOK(sv)) { 2272 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv)); 2273 } 2274 else 2275 useless = "a constant (undef)"; 2276 } 2277 } 2278 op_null(o); /* don't execute or even remember it */ 2279 break; 2280 2281 case OP_POSTINC: 2282 OpTYPE_set(o, OP_PREINC); /* pre-increment is faster */ 2283 break; 2284 2285 case OP_POSTDEC: 2286 OpTYPE_set(o, OP_PREDEC); /* pre-decrement is faster */ 2287 break; 2288 2289 case OP_I_POSTINC: 2290 OpTYPE_set(o, OP_I_PREINC); /* pre-increment is faster */ 2291 break; 2292 2293 case OP_I_POSTDEC: 2294 OpTYPE_set(o, OP_I_PREDEC); /* pre-decrement is faster */ 2295 break; 2296 2297 case OP_SASSIGN: { 2298 OP *rv2gv; 2299 UNOP *refgen, *rv2cv; 2300 LISTOP *exlist; 2301 2302 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2) 2303 break; 2304 2305 rv2gv = ((BINOP *)o)->op_last; 2306 if (!rv2gv || rv2gv->op_type != OP_RV2GV) 2307 break; 2308 2309 refgen = (UNOP *)((BINOP *)o)->op_first; 2310 2311 if (!refgen || (refgen->op_type != OP_REFGEN 2312 && refgen->op_type != OP_SREFGEN)) 2313 break; 2314 2315 exlist = (LISTOP *)refgen->op_first; 2316 if (!exlist || exlist->op_type != OP_NULL 2317 || exlist->op_targ != OP_LIST) 2318 break; 2319 2320 if (exlist->op_first->op_type != OP_PUSHMARK 2321 && exlist->op_first != exlist->op_last) 2322 break; 2323 2324 rv2cv = (UNOP*)exlist->op_last; 2325 2326 if (rv2cv->op_type != OP_RV2CV) 2327 break; 2328 2329 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0); 2330 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0); 2331 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0); 2332 2333 o->op_private |= OPpASSIGN_CV_TO_GV; 2334 rv2gv->op_private |= OPpDONT_INIT_GV; 2335 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT; 2336 2337 break; 2338 } 2339 2340 case OP_AASSIGN: { 2341 inplace_aassign(o); 2342 break; 2343 } 2344 2345 case OP_OR: 2346 case OP_AND: 2347 kid = cLOGOPo->op_first; 2348 if (kid->op_type == OP_NOT 2349 && (kid->op_flags & OPf_KIDS)) { 2350 if (o->op_type == OP_AND) { 2351 OpTYPE_set(o, OP_OR); 2352 } else { 2353 OpTYPE_set(o, OP_AND); 2354 } 2355 op_null(kid); 2356 } 2357 /* FALLTHROUGH */ 2358 2359 case OP_DOR: 2360 case OP_COND_EXPR: 2361 case OP_ENTERGIVEN: 2362 case OP_ENTERWHEN: 2363 next_kid = OpSIBLING(cUNOPo->op_first); 2364 break; 2365 2366 case OP_NULL: 2367 if (o->op_flags & OPf_STACKED) 2368 break; 2369 /* FALLTHROUGH */ 2370 case OP_NEXTSTATE: 2371 case OP_DBSTATE: 2372 case OP_ENTERTRY: 2373 case OP_ENTER: 2374 if (!(o->op_flags & OPf_KIDS)) 2375 break; 2376 /* FALLTHROUGH */ 2377 case OP_SCOPE: 2378 case OP_LEAVE: 2379 case OP_LEAVETRY: 2380 case OP_LEAVELOOP: 2381 case OP_LINESEQ: 2382 case OP_LEAVEGIVEN: 2383 case OP_LEAVEWHEN: 2384 kids: 2385 next_kid = cLISTOPo->op_first; 2386 break; 2387 case OP_LIST: 2388 /* If the first kid after pushmark is something that the padrange 2389 optimisation would reject, then null the list and the pushmark. 2390 */ 2391 if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK 2392 && ( !(kid = OpSIBLING(kid)) 2393 || ( kid->op_type != OP_PADSV 2394 && kid->op_type != OP_PADAV 2395 && kid->op_type != OP_PADHV) 2396 || kid->op_private & ~OPpLVAL_INTRO 2397 || !(kid = OpSIBLING(kid)) 2398 || ( kid->op_type != OP_PADSV 2399 && kid->op_type != OP_PADAV 2400 && kid->op_type != OP_PADHV) 2401 || kid->op_private & ~OPpLVAL_INTRO) 2402 ) { 2403 op_null(cUNOPo->op_first); /* NULL the pushmark */ 2404 op_null(o); /* NULL the list */ 2405 } 2406 goto kids; 2407 case OP_ENTEREVAL: 2408 scalarkids(o); 2409 break; 2410 case OP_SCALAR: 2411 scalar(o); 2412 break; 2413 } 2414 2415 if (useless_sv) { 2416 /* mortalise it, in case warnings are fatal. */ 2417 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), 2418 "Useless use of %" SVf " in void context", 2419 SVfARG(sv_2mortal(useless_sv))); 2420 } 2421 else if (useless) { 2422 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), 2423 "Useless use of %s in void context", 2424 useless); 2425 } 2426 2427 get_next_op: 2428 /* if a kid hasn't been nominated to process, continue with the 2429 * next sibling, or if no siblings left, go back to the parent's 2430 * siblings and so on 2431 */ 2432 while (!next_kid) { 2433 if (o == arg) 2434 return arg; /* at top; no parents/siblings to try */ 2435 if (OpHAS_SIBLING(o)) 2436 next_kid = o->op_sibparent; 2437 else 2438 o = o->op_sibparent; /*try parent's next sibling */ 2439 } 2440 o = next_kid; 2441 } 2442 2443 return arg; 2444 } 2445 2446 2447 static OP * 2448 S_listkids(pTHX_ OP *o) 2449 { 2450 if (o && o->op_flags & OPf_KIDS) { 2451 OP *kid; 2452 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) 2453 list(kid); 2454 } 2455 return o; 2456 } 2457 2458 2459 /* apply list context to the o subtree */ 2460 2461 OP * 2462 Perl_list(pTHX_ OP *o) 2463 { 2464 OP * top_op = o; 2465 2466 while (1) { 2467 OP *next_kid = NULL; /* what op (if any) to process next */ 2468 2469 OP *kid; 2470 2471 /* assumes no premature commitment */ 2472 if (!o || (o->op_flags & OPf_WANT) 2473 || (PL_parser && PL_parser->error_count) 2474 || o->op_type == OP_RETURN) 2475 { 2476 goto do_next; 2477 } 2478 2479 if ((o->op_private & OPpTARGET_MY) 2480 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */ 2481 { 2482 goto do_next; /* As if inside SASSIGN */ 2483 } 2484 2485 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST; 2486 2487 switch (o->op_type) { 2488 case OP_REPEAT: 2489 if (o->op_private & OPpREPEAT_DOLIST 2490 && !(o->op_flags & OPf_STACKED)) 2491 { 2492 list(cBINOPo->op_first); 2493 kid = cBINOPo->op_last; 2494 /* optimise away (.....) x 1 */ 2495 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv) 2496 && SvIVX(kSVOP_sv) == 1) 2497 { 2498 op_null(o); /* repeat */ 2499 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */ 2500 /* const (rhs): */ 2501 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL)); 2502 } 2503 } 2504 break; 2505 2506 case OP_OR: 2507 case OP_AND: 2508 case OP_COND_EXPR: 2509 /* impose list context on everything except the condition */ 2510 next_kid = OpSIBLING(cUNOPo->op_first); 2511 break; 2512 2513 default: 2514 if (!(o->op_flags & OPf_KIDS)) 2515 break; 2516 /* possibly flatten 1..10 into a constant array */ 2517 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) { 2518 list(cBINOPo->op_first); 2519 gen_constant_list(o); 2520 goto do_next; 2521 } 2522 next_kid = cUNOPo->op_first; /* do all kids */ 2523 break; 2524 2525 case OP_LIST: 2526 if (cLISTOPo->op_first->op_type == OP_PUSHMARK) { 2527 op_null(cUNOPo->op_first); /* NULL the pushmark */ 2528 op_null(o); /* NULL the list */ 2529 } 2530 if (o->op_flags & OPf_KIDS) 2531 next_kid = cUNOPo->op_first; /* do all kids */ 2532 break; 2533 2534 /* the children of these ops are usually a list of statements, 2535 * except the leaves, whose first child is a corresponding enter 2536 */ 2537 case OP_SCOPE: 2538 case OP_LINESEQ: 2539 kid = cLISTOPo->op_first; 2540 goto do_kids; 2541 case OP_LEAVE: 2542 case OP_LEAVETRY: 2543 kid = cLISTOPo->op_first; 2544 list(kid); 2545 kid = OpSIBLING(kid); 2546 do_kids: 2547 while (kid) { 2548 OP *sib = OpSIBLING(kid); 2549 /* Apply void context to all kids except the last, which 2550 * is list. E.g. 2551 * @a = do { void; void; list } 2552 * Except that 'when's are always list context, e.g. 2553 * @a = do { given(..) { 2554 * when (..) { list } 2555 * when (..) { list } 2556 * ... 2557 * }} 2558 */ 2559 if (!sib) { 2560 /* tail call optimise calling list() on the last kid */ 2561 next_kid = kid; 2562 goto do_next; 2563 } 2564 else if (kid->op_type == OP_LEAVEWHEN) 2565 list(kid); 2566 else 2567 scalarvoid(kid); 2568 kid = sib; 2569 } 2570 NOT_REACHED; /* NOTREACHED */ 2571 break; 2572 2573 } 2574 2575 /* If next_kid is set, someone in the code above wanted us to process 2576 * that kid and all its remaining siblings. Otherwise, work our way 2577 * back up the tree */ 2578 do_next: 2579 while (!next_kid) { 2580 if (o == top_op) 2581 return top_op; /* at top; no parents/siblings to try */ 2582 if (OpHAS_SIBLING(o)) 2583 next_kid = o->op_sibparent; 2584 else { 2585 o = o->op_sibparent; /*try parent's next sibling */ 2586 switch (o->op_type) { 2587 case OP_SCOPE: 2588 case OP_LINESEQ: 2589 case OP_LIST: 2590 case OP_LEAVE: 2591 case OP_LEAVETRY: 2592 /* should really restore PL_curcop to its old value, but 2593 * setting it to PL_compiling is better than do nothing */ 2594 PL_curcop = &PL_compiling; 2595 } 2596 } 2597 2598 2599 } 2600 o = next_kid; 2601 } /* while */ 2602 } 2603 2604 2605 static OP * 2606 S_scalarseq(pTHX_ OP *o) 2607 { 2608 if (o) { 2609 const OPCODE type = o->op_type; 2610 2611 if (type == OP_LINESEQ || type == OP_SCOPE || 2612 type == OP_LEAVE || type == OP_LEAVETRY) 2613 { 2614 OP *kid, *sib; 2615 for (kid = cLISTOPo->op_first; kid; kid = sib) { 2616 if ((sib = OpSIBLING(kid)) 2617 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL 2618 || ( sib->op_targ != OP_NEXTSTATE 2619 && sib->op_targ != OP_DBSTATE ))) 2620 { 2621 scalarvoid(kid); 2622 } 2623 } 2624 PL_curcop = &PL_compiling; 2625 } 2626 o->op_flags &= ~OPf_PARENS; 2627 if (PL_hints & HINT_BLOCK_SCOPE) 2628 o->op_flags |= OPf_PARENS; 2629 } 2630 else 2631 o = newOP(OP_STUB, 0); 2632 return o; 2633 } 2634 2635 STATIC OP * 2636 S_modkids(pTHX_ OP *o, I32 type) 2637 { 2638 if (o && o->op_flags & OPf_KIDS) { 2639 OP *kid; 2640 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) 2641 op_lvalue(kid, type); 2642 } 2643 return o; 2644 } 2645 2646 2647 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid 2648 * const fields. Also, convert CONST keys to HEK-in-SVs. 2649 * rop is the op that retrieves the hash; 2650 * key_op is the first key 2651 * real if false, only check (and possibly croak); don't update op 2652 */ 2653 2654 STATIC void 2655 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op, int real) 2656 { 2657 PADNAME *lexname; 2658 GV **fields; 2659 bool check_fields; 2660 2661 /* find the padsv corresponding to $lex->{} or @{$lex}{} */ 2662 if (rop) { 2663 if (rop->op_first->op_type == OP_PADSV) 2664 /* @$hash{qw(keys here)} */ 2665 rop = (UNOP*)rop->op_first; 2666 else { 2667 /* @{$hash}{qw(keys here)} */ 2668 if (rop->op_first->op_type == OP_SCOPE 2669 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV) 2670 { 2671 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last; 2672 } 2673 else 2674 rop = NULL; 2675 } 2676 } 2677 2678 lexname = NULL; /* just to silence compiler warnings */ 2679 fields = NULL; /* just to silence compiler warnings */ 2680 2681 check_fields = 2682 rop 2683 && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ), 2684 SvPAD_TYPED(lexname)) 2685 && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE)) 2686 && isGV(*fields) && GvHV(*fields); 2687 2688 for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) { 2689 SV **svp, *sv; 2690 if (key_op->op_type != OP_CONST) 2691 continue; 2692 svp = cSVOPx_svp(key_op); 2693 2694 /* make sure it's not a bareword under strict subs */ 2695 if (key_op->op_private & OPpCONST_BARE && 2696 key_op->op_private & OPpCONST_STRICT) 2697 { 2698 no_bareword_allowed((OP*)key_op); 2699 } 2700 2701 /* Make the CONST have a shared SV */ 2702 if ( !SvIsCOW_shared_hash(sv = *svp) 2703 && SvTYPE(sv) < SVt_PVMG 2704 && SvOK(sv) 2705 && !SvROK(sv) 2706 && real) 2707 { 2708 SSize_t keylen; 2709 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen); 2710 SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0); 2711 SvREFCNT_dec_NN(sv); 2712 *svp = nsv; 2713 } 2714 2715 if ( check_fields 2716 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0)) 2717 { 2718 Perl_croak(aTHX_ "No such class field \"%" SVf "\" " 2719 "in variable %" PNf " of type %" HEKf, 2720 SVfARG(*svp), PNfARG(lexname), 2721 HEKfARG(HvNAME_HEK(PadnameTYPE(lexname)))); 2722 } 2723 } 2724 } 2725 2726 /* info returned by S_sprintf_is_multiconcatable() */ 2727 2728 struct sprintf_ismc_info { 2729 SSize_t nargs; /* num of args to sprintf (not including the format) */ 2730 char *start; /* start of raw format string */ 2731 char *end; /* bytes after end of raw format string */ 2732 STRLEN total_len; /* total length (in bytes) of format string, not 2733 including '%s' and half of '%%' */ 2734 STRLEN variant; /* number of bytes by which total_len_p would grow 2735 if upgraded to utf8 */ 2736 bool utf8; /* whether the format is utf8 */ 2737 }; 2738 2739 2740 /* is the OP_SPRINTF o suitable for converting into a multiconcat op? 2741 * i.e. its format argument is a const string with only '%s' and '%%' 2742 * formats, and the number of args is known, e.g. 2743 * sprintf "a=%s f=%s", $a[0], scalar(f()); 2744 * but not 2745 * sprintf "i=%d a=%s f=%s", $i, @a, f(); 2746 * 2747 * If successful, the sprintf_ismc_info struct pointed to by info will be 2748 * populated. 2749 */ 2750 2751 STATIC bool 2752 S_sprintf_is_multiconcatable(pTHX_ OP *o,struct sprintf_ismc_info *info) 2753 { 2754 OP *pm, *constop, *kid; 2755 SV *sv; 2756 char *s, *e, *p; 2757 SSize_t nargs, nformats; 2758 STRLEN cur, total_len, variant; 2759 bool utf8; 2760 2761 /* if sprintf's behaviour changes, die here so that someone 2762 * can decide whether to enhance this function or skip optimising 2763 * under those new circumstances */ 2764 assert(!(o->op_flags & OPf_STACKED)); 2765 assert(!(PL_opargs[OP_SPRINTF] & OA_TARGLEX)); 2766 assert(!(o->op_private & ~OPpARG4_MASK)); 2767 2768 pm = cUNOPo->op_first; 2769 if (pm->op_type != OP_PUSHMARK) /* weird coreargs stuff */ 2770 return FALSE; 2771 constop = OpSIBLING(pm); 2772 if (!constop || constop->op_type != OP_CONST) 2773 return FALSE; 2774 sv = cSVOPx_sv(constop); 2775 if (SvMAGICAL(sv) || !SvPOK(sv)) 2776 return FALSE; 2777 2778 s = SvPV(sv, cur); 2779 e = s + cur; 2780 2781 /* Scan format for %% and %s and work out how many %s there are. 2782 * Abandon if other format types are found. 2783 */ 2784 2785 nformats = 0; 2786 total_len = 0; 2787 variant = 0; 2788 2789 for (p = s; p < e; p++) { 2790 if (*p != '%') { 2791 total_len++; 2792 if (!UTF8_IS_INVARIANT(*p)) 2793 variant++; 2794 continue; 2795 } 2796 p++; 2797 if (p >= e) 2798 return FALSE; /* lone % at end gives "Invalid conversion" */ 2799 if (*p == '%') 2800 total_len++; 2801 else if (*p == 's') 2802 nformats++; 2803 else 2804 return FALSE; 2805 } 2806 2807 if (!nformats || nformats > PERL_MULTICONCAT_MAXARG) 2808 return FALSE; 2809 2810 utf8 = cBOOL(SvUTF8(sv)); 2811 if (utf8) 2812 variant = 0; 2813 2814 /* scan args; they must all be in scalar cxt */ 2815 2816 nargs = 0; 2817 kid = OpSIBLING(constop); 2818 2819 while (kid) { 2820 if ((kid->op_flags & OPf_WANT) != OPf_WANT_SCALAR) 2821 return FALSE; 2822 nargs++; 2823 kid = OpSIBLING(kid); 2824 } 2825 2826 if (nargs != nformats) 2827 return FALSE; /* e.g. sprintf("%s%s", $a); */ 2828 2829 2830 info->nargs = nargs; 2831 info->start = s; 2832 info->end = e; 2833 info->total_len = total_len; 2834 info->variant = variant; 2835 info->utf8 = utf8; 2836 2837 return TRUE; 2838 } 2839 2840 2841 2842 /* S_maybe_multiconcat(): 2843 * 2844 * given an OP_STRINGIFY, OP_SASSIGN, OP_CONCAT or OP_SPRINTF op, possibly 2845 * convert it (and its children) into an OP_MULTICONCAT. See the code 2846 * comments just before pp_multiconcat() for the full details of what 2847 * OP_MULTICONCAT supports. 2848 * 2849 * Basically we're looking for an optree with a chain of OP_CONCATS down 2850 * the LHS (or an OP_SPRINTF), with possibly an OP_SASSIGN, and/or 2851 * OP_STRINGIFY, and/or OP_CONCAT acting as '.=' at its head, e.g. 2852 * 2853 * $x = "$a$b-$c" 2854 * 2855 * looks like 2856 * 2857 * SASSIGN 2858 * | 2859 * STRINGIFY -- PADSV[$x] 2860 * | 2861 * | 2862 * ex-PUSHMARK -- CONCAT/S 2863 * | 2864 * CONCAT/S -- PADSV[$d] 2865 * | 2866 * CONCAT -- CONST["-"] 2867 * | 2868 * PADSV[$a] -- PADSV[$b] 2869 * 2870 * Note that at this stage the OP_SASSIGN may have already been optimised 2871 * away with OPpTARGET_MY set on the OP_STRINGIFY or OP_CONCAT. 2872 */ 2873 2874 STATIC void 2875 S_maybe_multiconcat(pTHX_ OP *o) 2876 { 2877 dVAR; 2878 OP *lastkidop; /* the right-most of any kids unshifted onto o */ 2879 OP *topop; /* the top-most op in the concat tree (often equals o, 2880 unless there are assign/stringify ops above it */ 2881 OP *parentop; /* the parent op of topop (or itself if no parent) */ 2882 OP *targmyop; /* the op (if any) with the OPpTARGET_MY flag */ 2883 OP *targetop; /* the op corresponding to target=... or target.=... */ 2884 OP *stringop; /* the OP_STRINGIFY op, if any */ 2885 OP *nextop; /* used for recreating the op_next chain without consts */ 2886 OP *kid; /* general-purpose op pointer */ 2887 UNOP_AUX_item *aux; 2888 UNOP_AUX_item *lenp; 2889 char *const_str, *p; 2890 struct sprintf_ismc_info sprintf_info; 2891 2892 /* store info about each arg in args[]; 2893 * toparg is the highest used slot; argp is a general 2894 * pointer to args[] slots */ 2895 struct { 2896 void *p; /* initially points to const sv (or null for op); 2897 later, set to SvPV(constsv), with ... */ 2898 STRLEN len; /* ... len set to SvPV(..., len) */ 2899 } *argp, *toparg, args[PERL_MULTICONCAT_MAXARG*2 + 1]; 2900 2901 SSize_t nargs = 0; 2902 SSize_t nconst = 0; 2903 SSize_t nadjconst = 0; /* adjacent consts - may be demoted to args */ 2904 STRLEN variant; 2905 bool utf8 = FALSE; 2906 bool kid_is_last = FALSE; /* most args will be the RHS kid of a concat op; 2907 the last-processed arg will the LHS of one, 2908 as args are processed in reverse order */ 2909 U8 stacked_last = 0; /* whether the last seen concat op was STACKED */ 2910 STRLEN total_len = 0; /* sum of the lengths of the const segments */ 2911 U8 flags = 0; /* what will become the op_flags and ... */ 2912 U8 private_flags = 0; /* ... op_private of the multiconcat op */ 2913 bool is_sprintf = FALSE; /* we're optimising an sprintf */ 2914 bool is_targable = FALSE; /* targetop is an OPpTARGET_MY candidate */ 2915 bool prev_was_const = FALSE; /* previous arg was a const */ 2916 2917 /* ----------------------------------------------------------------- 2918 * Phase 1: 2919 * 2920 * Examine the optree non-destructively to determine whether it's 2921 * suitable to be converted into an OP_MULTICONCAT. Accumulate 2922 * information about the optree in args[]. 2923 */ 2924 2925 argp = args; 2926 targmyop = NULL; 2927 targetop = NULL; 2928 stringop = NULL; 2929 topop = o; 2930 parentop = o; 2931 2932 assert( o->op_type == OP_SASSIGN 2933 || o->op_type == OP_CONCAT 2934 || o->op_type == OP_SPRINTF 2935 || o->op_type == OP_STRINGIFY); 2936 2937 Zero(&sprintf_info, 1, struct sprintf_ismc_info); 2938 2939 /* first see if, at the top of the tree, there is an assign, 2940 * append and/or stringify */ 2941 2942 if (topop->op_type == OP_SASSIGN) { 2943 /* expr = ..... */ 2944 if (o->op_ppaddr != PL_ppaddr[OP_SASSIGN]) 2945 return; 2946 if (o->op_private & (OPpASSIGN_BACKWARDS|OPpASSIGN_CV_TO_GV)) 2947 return; 2948 assert(!(o->op_private & ~OPpARG2_MASK)); /* barf on unknown flags */ 2949 2950 parentop = topop; 2951 topop = cBINOPo->op_first; 2952 targetop = OpSIBLING(topop); 2953 if (!targetop) /* probably some sort of syntax error */ 2954 return; 2955 2956 /* don't optimise away assign in 'local $foo = ....' */ 2957 if ( (targetop->op_private & OPpLVAL_INTRO) 2958 /* these are the common ops which do 'local', but 2959 * not all */ 2960 && ( targetop->op_type == OP_GVSV 2961 || targetop->op_type == OP_RV2SV 2962 || targetop->op_type == OP_AELEM 2963 || targetop->op_type == OP_HELEM 2964 ) 2965 ) 2966 return; 2967 } 2968 else if ( topop->op_type == OP_CONCAT 2969 && (topop->op_flags & OPf_STACKED) 2970 && (!(topop->op_private & OPpCONCAT_NESTED)) 2971 ) 2972 { 2973 /* expr .= ..... */ 2974 2975 /* OPpTARGET_MY shouldn't be able to be set here. If it is, 2976 * decide what to do about it */ 2977 assert(!(o->op_private & OPpTARGET_MY)); 2978 2979 /* barf on unknown flags */ 2980 assert(!(o->op_private & ~(OPpARG2_MASK|OPpTARGET_MY))); 2981 private_flags |= OPpMULTICONCAT_APPEND; 2982 targetop = cBINOPo->op_first; 2983 parentop = topop; 2984 topop = OpSIBLING(targetop); 2985 2986 /* $x .= <FOO> gets optimised to rcatline instead */ 2987 if (topop->op_type == OP_READLINE) 2988 return; 2989 } 2990 2991 if (targetop) { 2992 /* Can targetop (the LHS) if it's a padsv, be optimised 2993 * away and use OPpTARGET_MY instead? 2994 */ 2995 if ( (targetop->op_type == OP_PADSV) 2996 && !(targetop->op_private & OPpDEREF) 2997 && !(targetop->op_private & OPpPAD_STATE) 2998 /* we don't support 'my $x .= ...' */ 2999 && ( o->op_type == OP_SASSIGN 3000 || !(targetop->op_private & OPpLVAL_INTRO)) 3001 ) 3002 is_targable = TRUE; 3003 } 3004 3005 if (topop->op_type == OP_STRINGIFY) { 3006 if (topop->op_ppaddr != PL_ppaddr[OP_STRINGIFY]) 3007 return; 3008 stringop = topop; 3009 3010 /* barf on unknown flags */ 3011 assert(!(o->op_private & ~(OPpARG4_MASK|OPpTARGET_MY))); 3012 3013 if ((topop->op_private & OPpTARGET_MY)) { 3014 if (o->op_type == OP_SASSIGN) 3015 return; /* can't have two assigns */ 3016 targmyop = topop; 3017 } 3018 3019 private_flags |= OPpMULTICONCAT_STRINGIFY; 3020 parentop = topop; 3021 topop = cBINOPx(topop)->op_first; 3022 assert(OP_TYPE_IS_OR_WAS_NN(topop, OP_PUSHMARK)); 3023 topop = OpSIBLING(topop); 3024 } 3025 3026 if (topop->op_type == OP_SPRINTF) { 3027 if (topop->op_ppaddr != PL_ppaddr[OP_SPRINTF]) 3028 return; 3029 if (S_sprintf_is_multiconcatable(aTHX_ topop, &sprintf_info)) { 3030 nargs = sprintf_info.nargs; 3031 total_len = sprintf_info.total_len; 3032 variant = sprintf_info.variant; 3033 utf8 = sprintf_info.utf8; 3034 is_sprintf = TRUE; 3035 private_flags |= OPpMULTICONCAT_FAKE; 3036 toparg = argp; 3037 /* we have an sprintf op rather than a concat optree. 3038 * Skip most of the code below which is associated with 3039 * processing that optree. We also skip phase 2, determining 3040 * whether its cost effective to optimise, since for sprintf, 3041 * multiconcat is *always* faster */ 3042 goto create_aux; 3043 } 3044 /* note that even if the sprintf itself isn't multiconcatable, 3045 * the expression as a whole may be, e.g. in 3046 * $x .= sprintf("%d",...) 3047 * the sprintf op will be left as-is, but the concat/S op may 3048 * be upgraded to multiconcat 3049 */ 3050 } 3051 else if (topop->op_type == OP_CONCAT) { 3052 if (topop->op_ppaddr != PL_ppaddr[OP_CONCAT]) 3053 return; 3054 3055 if ((topop->op_private & OPpTARGET_MY)) { 3056 if (o->op_type == OP_SASSIGN || targmyop) 3057 return; /* can't have two assigns */ 3058 targmyop = topop; 3059 } 3060 } 3061 3062 /* Is it safe to convert a sassign/stringify/concat op into 3063 * a multiconcat? */ 3064 assert((PL_opargs[OP_SASSIGN] & OA_CLASS_MASK) == OA_BINOP); 3065 assert((PL_opargs[OP_CONCAT] & OA_CLASS_MASK) == OA_BINOP); 3066 assert((PL_opargs[OP_STRINGIFY] & OA_CLASS_MASK) == OA_LISTOP); 3067 assert((PL_opargs[OP_SPRINTF] & OA_CLASS_MASK) == OA_LISTOP); 3068 STATIC_ASSERT_STMT( STRUCT_OFFSET(BINOP, op_last) 3069 == STRUCT_OFFSET(UNOP_AUX, op_aux)); 3070 STATIC_ASSERT_STMT( STRUCT_OFFSET(LISTOP, op_last) 3071 == STRUCT_OFFSET(UNOP_AUX, op_aux)); 3072 3073 /* Now scan the down the tree looking for a series of 3074 * CONCAT/OPf_STACKED ops on the LHS (with the last one not 3075 * stacked). For example this tree: 3076 * 3077 * | 3078 * CONCAT/STACKED 3079 * | 3080 * CONCAT/STACKED -- EXPR5 3081 * | 3082 * CONCAT/STACKED -- EXPR4 3083 * | 3084 * CONCAT -- EXPR3 3085 * | 3086 * EXPR1 -- EXPR2 3087 * 3088 * corresponds to an expression like 3089 * 3090 * (EXPR1 . EXPR2 . EXPR3 . EXPR4 . EXPR5) 3091 * 3092 * Record info about each EXPR in args[]: in particular, whether it is 3093 * a stringifiable OP_CONST and if so what the const sv is. 3094 * 3095 * The reason why the last concat can't be STACKED is the difference 3096 * between 3097 * 3098 * ((($a .= $a) .= $a) .= $a) .= $a 3099 * 3100 * and 3101 * $a . $a . $a . $a . $a 3102 * 3103 * The main difference between the optrees for those two constructs 3104 * is the presence of the last STACKED. As well as modifying $a, 3105 * the former sees the changed $a between each concat, so if $s is 3106 * initially 'a', the first returns 'a' x 16, while the latter returns 3107 * 'a' x 5. And pp_multiconcat can't handle that kind of thing. 3108 */ 3109 3110 kid = topop; 3111 3112 for (;;) { 3113 OP *argop; 3114 SV *sv; 3115 bool last = FALSE; 3116 3117 if ( kid->op_type == OP_CONCAT 3118 && !kid_is_last 3119 ) { 3120 OP *k1, *k2; 3121 k1 = cUNOPx(kid)->op_first; 3122 k2 = OpSIBLING(k1); 3123 /* shouldn't happen except maybe after compile err? */ 3124 if (!k2) 3125 return; 3126 3127 /* avoid turning (A . B . ($lex = C) ...) into (A . B . C ...) */ 3128 if (kid->op_private & OPpTARGET_MY) 3129 kid_is_last = TRUE; 3130 3131 stacked_last = (kid->op_flags & OPf_STACKED); 3132 if (!stacked_last) 3133 kid_is_last = TRUE; 3134 3135 kid = k1; 3136 argop = k2; 3137 } 3138 else { 3139 argop = kid; 3140 last = TRUE; 3141 } 3142 3143 if ( nargs + nadjconst > PERL_MULTICONCAT_MAXARG - 2 3144 || (argp - args + 1) > (PERL_MULTICONCAT_MAXARG*2 + 1) - 2) 3145 { 3146 /* At least two spare slots are needed to decompose both 3147 * concat args. If there are no slots left, continue to 3148 * examine the rest of the optree, but don't push new values 3149 * on args[]. If the optree as a whole is legal for conversion 3150 * (in particular that the last concat isn't STACKED), then 3151 * the first PERL_MULTICONCAT_MAXARG elements of the optree 3152 * can be converted into an OP_MULTICONCAT now, with the first 3153 * child of that op being the remainder of the optree - 3154 * which may itself later be converted to a multiconcat op 3155 * too. 3156 */ 3157 if (last) { 3158 /* the last arg is the rest of the optree */ 3159 argp++->p = NULL; 3160 nargs++; 3161 } 3162 } 3163 else if ( argop->op_type == OP_CONST 3164 && ((sv = cSVOPx_sv(argop))) 3165 /* defer stringification until runtime of 'constant' 3166 * things that might stringify variantly, e.g. the radix 3167 * point of NVs, or overloaded RVs */ 3168 && (SvPOK(sv) || SvIOK(sv)) 3169 && (!SvGMAGICAL(sv)) 3170 ) { 3171 if (argop->op_private & OPpCONST_STRICT) 3172 no_bareword_allowed(argop); 3173 argp++->p = sv; 3174 utf8 |= cBOOL(SvUTF8(sv)); 3175 nconst++; 3176 if (prev_was_const) 3177 /* this const may be demoted back to a plain arg later; 3178 * make sure we have enough arg slots left */ 3179 nadjconst++; 3180 prev_was_const = !prev_was_const; 3181 } 3182 else { 3183 argp++->p = NULL; 3184 nargs++; 3185 prev_was_const = FALSE; 3186 } 3187 3188 if (last) 3189 break; 3190 } 3191 3192 toparg = argp - 1; 3193 3194 if (stacked_last) 3195 return; /* we don't support ((A.=B).=C)...) */ 3196 3197 /* look for two adjacent consts and don't fold them together: 3198 * $o . "a" . "b" 3199 * should do 3200 * $o->concat("a")->concat("b") 3201 * rather than 3202 * $o->concat("ab") 3203 * (but $o .= "a" . "b" should still fold) 3204 */ 3205 { 3206 bool seen_nonconst = FALSE; 3207 for (argp = toparg; argp >= args; argp--) { 3208 if (argp->p == NULL) { 3209 seen_nonconst = TRUE; 3210 continue; 3211 } 3212 if (!seen_nonconst) 3213 continue; 3214 if (argp[1].p) { 3215 /* both previous and current arg were constants; 3216 * leave the current OP_CONST as-is */ 3217 argp->p = NULL; 3218 nconst--; 3219 nargs++; 3220 } 3221 } 3222 } 3223 3224 /* ----------------------------------------------------------------- 3225 * Phase 2: 3226 * 3227 * At this point we have determined that the optree *can* be converted 3228 * into a multiconcat. Having gathered all the evidence, we now decide 3229 * whether it *should*. 3230 */ 3231 3232 3233 /* we need at least one concat action, e.g.: 3234 * 3235 * Y . Z 3236 * X = Y . Z 3237 * X .= Y 3238 * 3239 * otherwise we could be doing something like $x = "foo", which 3240 * if treated as a concat, would fail to COW. 3241 */ 3242 if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 2) 3243 return; 3244 3245 /* Benchmarking seems to indicate that we gain if: 3246 * * we optimise at least two actions into a single multiconcat 3247 * (e.g concat+concat, sassign+concat); 3248 * * or if we can eliminate at least 1 OP_CONST; 3249 * * or if we can eliminate a padsv via OPpTARGET_MY 3250 */ 3251 3252 if ( 3253 /* eliminated at least one OP_CONST */ 3254 nconst >= 1 3255 /* eliminated an OP_SASSIGN */ 3256 || o->op_type == OP_SASSIGN 3257 /* eliminated an OP_PADSV */ 3258 || (!targmyop && is_targable) 3259 ) 3260 /* definitely a net gain to optimise */ 3261 goto optimise; 3262 3263 /* ... if not, what else? */ 3264 3265 /* special-case '$lex1 = expr . $lex1' (where expr isn't lex1): 3266 * multiconcat is faster (due to not creating a temporary copy of 3267 * $lex1), whereas for a general $lex1 = $lex2 . $lex3, concat is 3268 * faster. 3269 */ 3270 if ( nconst == 0 3271 && nargs == 2 3272 && targmyop 3273 && topop->op_type == OP_CONCAT 3274 ) { 3275 PADOFFSET t = targmyop->op_targ; 3276 OP *k1 = cBINOPx(topop)->op_first; 3277 OP *k2 = cBINOPx(topop)->op_last; 3278 if ( k2->op_type == OP_PADSV 3279 && k2->op_targ == t 3280 && ( k1->op_type != OP_PADSV 3281 || k1->op_targ != t) 3282 ) 3283 goto optimise; 3284 } 3285 3286 /* need at least two concats */ 3287 if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 3) 3288 return; 3289 3290 3291 3292 /* ----------------------------------------------------------------- 3293 * Phase 3: 3294 * 3295 * At this point the optree has been verified as ok to be optimised 3296 * into an OP_MULTICONCAT. Now start changing things. 3297 */ 3298 3299 optimise: 3300 3301 /* stringify all const args and determine utf8ness */ 3302 3303 variant = 0; 3304 for (argp = args; argp <= toparg; argp++) { 3305 SV *sv = (SV*)argp->p; 3306 if (!sv) 3307 continue; /* not a const op */ 3308 if (utf8 && !SvUTF8(sv)) 3309 sv_utf8_upgrade_nomg(sv); 3310 argp->p = SvPV_nomg(sv, argp->len); 3311 total_len += argp->len; 3312 3313 /* see if any strings would grow if converted to utf8 */ 3314 if (!utf8) { 3315 variant += variant_under_utf8_count((U8 *) argp->p, 3316 (U8 *) argp->p + argp->len); 3317 } 3318 } 3319 3320 /* create and populate aux struct */ 3321 3322 create_aux: 3323 3324 aux = (UNOP_AUX_item*)PerlMemShared_malloc( 3325 sizeof(UNOP_AUX_item) 3326 * ( 3327 PERL_MULTICONCAT_HEADER_SIZE 3328 + ((nargs + 1) * (variant ? 2 : 1)) 3329 ) 3330 ); 3331 const_str = (char *)PerlMemShared_malloc(total_len ? total_len : 1); 3332 3333 /* Extract all the non-const expressions from the concat tree then 3334 * dispose of the old tree, e.g. convert the tree from this: 3335 * 3336 * o => SASSIGN 3337 * | 3338 * STRINGIFY -- TARGET 3339 * | 3340 * ex-PUSHMARK -- CONCAT 3341 * | 3342 * CONCAT -- EXPR5 3343 * | 3344 * CONCAT -- EXPR4 3345 * | 3346 * CONCAT -- EXPR3 3347 * | 3348 * EXPR1 -- EXPR2 3349 * 3350 * 3351 * to: 3352 * 3353 * o => MULTICONCAT 3354 * | 3355 * ex-PUSHMARK -- EXPR1 -- EXPR2 -- EXPR3 -- EXPR4 -- EXPR5 -- TARGET 3356 * 3357 * except that if EXPRi is an OP_CONST, it's discarded. 3358 * 3359 * During the conversion process, EXPR ops are stripped from the tree 3360 * and unshifted onto o. Finally, any of o's remaining original 3361 * childen are discarded and o is converted into an OP_MULTICONCAT. 3362 * 3363 * In this middle of this, o may contain both: unshifted args on the 3364 * left, and some remaining original args on the right. lastkidop 3365 * is set to point to the right-most unshifted arg to delineate 3366 * between the two sets. 3367 */ 3368 3369 3370 if (is_sprintf) { 3371 /* create a copy of the format with the %'s removed, and record 3372 * the sizes of the const string segments in the aux struct */ 3373 char *q, *oldq; 3374 lenp = aux + PERL_MULTICONCAT_IX_LENGTHS; 3375 3376 p = sprintf_info.start; 3377 q = const_str; 3378 oldq = q; 3379 for (; p < sprintf_info.end; p++) { 3380 if (*p == '%') { 3381 p++; 3382 if (*p != '%') { 3383 (lenp++)->ssize = q - oldq; 3384 oldq = q; 3385 continue; 3386 } 3387 } 3388 *q++ = *p; 3389 } 3390 lenp->ssize = q - oldq; 3391 assert((STRLEN)(q - const_str) == total_len); 3392 3393 /* Attach all the args (i.e. the kids of the sprintf) to o (which 3394 * may or may not be topop) The pushmark and const ops need to be 3395 * kept in case they're an op_next entry point. 3396 */ 3397 lastkidop = cLISTOPx(topop)->op_last; 3398 kid = cUNOPx(topop)->op_first; /* pushmark */ 3399 op_null(kid); 3400 op_null(OpSIBLING(kid)); /* const */ 3401 if (o != topop) { 3402 kid = op_sibling_splice(topop, NULL, -1, NULL); /* cut all args */ 3403 op_sibling_splice(o, NULL, 0, kid); /* and attach to o */ 3404 lastkidop->op_next = o; 3405 } 3406 } 3407 else { 3408 p = const_str; 3409 lenp = aux + PERL_MULTICONCAT_IX_LENGTHS; 3410 3411 lenp->ssize = -1; 3412 3413 /* Concatenate all const strings into const_str. 3414 * Note that args[] contains the RHS args in reverse order, so 3415 * we scan args[] from top to bottom to get constant strings 3416 * in L-R order 3417 */ 3418 for (argp = toparg; argp >= args; argp--) { 3419 if (!argp->p) 3420 /* not a const op */ 3421 (++lenp)->ssize = -1; 3422 else { 3423 STRLEN l = argp->len; 3424 Copy(argp->p, p, l, char); 3425 p += l; 3426 if (lenp->ssize == -1) 3427 lenp->ssize = l; 3428 else 3429 lenp->ssize += l; 3430 } 3431 } 3432 3433 kid = topop; 3434 nextop = o; 3435 lastkidop = NULL; 3436 3437 for (argp = args; argp <= toparg; argp++) { 3438 /* only keep non-const args, except keep the first-in-next-chain 3439 * arg no matter what it is (but nulled if OP_CONST), because it 3440 * may be the entry point to this subtree from the previous 3441 * op_next. 3442 */ 3443 bool last = (argp == toparg); 3444 OP *prev; 3445 3446 /* set prev to the sibling *before* the arg to be cut out, 3447 * e.g. when cutting EXPR: 3448 * 3449 * | 3450 * kid= CONCAT 3451 * | 3452 * prev= CONCAT -- EXPR 3453 * | 3454 */ 3455 if (argp == args && kid->op_type != OP_CONCAT) { 3456 /* in e.g. '$x .= f(1)' there's no RHS concat tree 3457 * so the expression to be cut isn't kid->op_last but 3458 * kid itself */ 3459 OP *o1, *o2; 3460 /* find the op before kid */ 3461 o1 = NULL; 3462 o2 = cUNOPx(parentop)->op_first; 3463 while (o2 && o2 != kid) { 3464 o1 = o2; 3465 o2 = OpSIBLING(o2); 3466 } 3467 assert(o2 == kid); 3468 prev = o1; 3469 kid = parentop; 3470 } 3471 else if (kid == o && lastkidop) 3472 prev = last ? lastkidop : OpSIBLING(lastkidop); 3473 else 3474 prev = last ? NULL : cUNOPx(kid)->op_first; 3475 3476 if (!argp->p || last) { 3477 /* cut RH op */ 3478 OP *aop = op_sibling_splice(kid, prev, 1, NULL); 3479 /* and unshift to front of o */ 3480 op_sibling_splice(o, NULL, 0, aop); 3481 /* record the right-most op added to o: later we will 3482 * free anything to the right of it */ 3483 if (!lastkidop) 3484 lastkidop = aop; 3485 aop->op_next = nextop; 3486 if (last) { 3487 if (argp->p) 3488 /* null the const at start of op_next chain */ 3489 op_null(aop); 3490 } 3491 else if (prev) 3492 nextop = prev->op_next; 3493 } 3494 3495 /* the last two arguments are both attached to the same concat op */ 3496 if (argp < toparg - 1) 3497 kid = prev; 3498 } 3499 } 3500 3501 /* Populate the aux struct */ 3502 3503 aux[PERL_MULTICONCAT_IX_NARGS].ssize = nargs; 3504 aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv = utf8 ? NULL : const_str; 3505 aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize = utf8 ? 0 : total_len; 3506 aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = const_str; 3507 aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = total_len; 3508 3509 /* if variant > 0, calculate a variant const string and lengths where 3510 * the utf8 version of the string will take 'variant' more bytes than 3511 * the plain one. */ 3512 3513 if (variant) { 3514 char *p = const_str; 3515 STRLEN ulen = total_len + variant; 3516 UNOP_AUX_item *lens = aux + PERL_MULTICONCAT_IX_LENGTHS; 3517 UNOP_AUX_item *ulens = lens + (nargs + 1); 3518 char *up = (char*)PerlMemShared_malloc(ulen); 3519 SSize_t n; 3520 3521 aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = up; 3522 aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = ulen; 3523 3524 for (n = 0; n < (nargs + 1); n++) { 3525 SSize_t i; 3526 char * orig_up = up; 3527 for (i = (lens++)->ssize; i > 0; i--) { 3528 U8 c = *p++; 3529 append_utf8_from_native_byte(c, (U8**)&up); 3530 } 3531 (ulens++)->ssize = (i < 0) ? i : up - orig_up; 3532 } 3533 } 3534 3535 if (stringop) { 3536 /* if there was a top(ish)-level OP_STRINGIFY, we need to keep 3537 * that op's first child - an ex-PUSHMARK - because the op_next of 3538 * the previous op may point to it (i.e. it's the entry point for 3539 * the o optree) 3540 */ 3541 OP *pmop = 3542 (stringop == o) 3543 ? op_sibling_splice(o, lastkidop, 1, NULL) 3544 : op_sibling_splice(stringop, NULL, 1, NULL); 3545 assert(OP_TYPE_IS_OR_WAS_NN(pmop, OP_PUSHMARK)); 3546 op_sibling_splice(o, NULL, 0, pmop); 3547 if (!lastkidop) 3548 lastkidop = pmop; 3549 } 3550 3551 /* Optimise 3552 * target = A.B.C... 3553 * target .= A.B.C... 3554 */ 3555 3556 if (targetop) { 3557 assert(!targmyop); 3558 3559 if (o->op_type == OP_SASSIGN) { 3560 /* Move the target subtree from being the last of o's children 3561 * to being the last of o's preserved children. 3562 * Note the difference between 'target = ...' and 'target .= ...': 3563 * for the former, target is executed last; for the latter, 3564 * first. 3565 */ 3566 kid = OpSIBLING(lastkidop); 3567 op_sibling_splice(o, kid, 1, NULL); /* cut target op */ 3568 op_sibling_splice(o, lastkidop, 0, targetop); /* and paste */ 3569 lastkidop->op_next = kid->op_next; 3570 lastkidop = targetop; 3571 } 3572 else { 3573 /* Move the target subtree from being the first of o's 3574 * original children to being the first of *all* o's children. 3575 */ 3576 if (lastkidop) { 3577 op_sibling_splice(o, lastkidop, 1, NULL); /* cut target op */ 3578 op_sibling_splice(o, NULL, 0, targetop); /* and paste*/ 3579 } 3580 else { 3581 /* if the RHS of .= doesn't contain a concat (e.g. 3582 * $x .= "foo"), it gets missed by the "strip ops from the 3583 * tree and add to o" loop earlier */ 3584 assert(topop->op_type != OP_CONCAT); 3585 if (stringop) { 3586 /* in e.g. $x .= "$y", move the $y expression 3587 * from being a child of OP_STRINGIFY to being the 3588 * second child of the OP_CONCAT 3589 */ 3590 assert(cUNOPx(stringop)->op_first == topop); 3591 op_sibling_splice(stringop, NULL, 1, NULL); 3592 op_sibling_splice(o, cUNOPo->op_first, 0, topop); 3593 } 3594 assert(topop == OpSIBLING(cBINOPo->op_first)); 3595 if (toparg->p) 3596 op_null(topop); 3597 lastkidop = topop; 3598 } 3599 } 3600 3601 if (is_targable) { 3602 /* optimise 3603 * my $lex = A.B.C... 3604 * $lex = A.B.C... 3605 * $lex .= A.B.C... 3606 * The original padsv op is kept but nulled in case it's the 3607 * entry point for the optree (which it will be for 3608 * '$lex .= ... ' 3609 */ 3610 private_flags |= OPpTARGET_MY; 3611 private_flags |= (targetop->op_private & OPpLVAL_INTRO); 3612 o->op_targ = targetop->op_targ; 3613 targetop->op_targ = 0; 3614 op_null(targetop); 3615 } 3616 else 3617 flags |= OPf_STACKED; 3618 } 3619 else if (targmyop) { 3620 private_flags |= OPpTARGET_MY; 3621 if (o != targmyop) { 3622 o->op_targ = targmyop->op_targ; 3623 targmyop->op_targ = 0; 3624 } 3625 } 3626 3627 /* detach the emaciated husk of the sprintf/concat optree and free it */ 3628 for (;;) { 3629 kid = op_sibling_splice(o, lastkidop, 1, NULL); 3630 if (!kid) 3631 break; 3632 op_free(kid); 3633 } 3634 3635 /* and convert o into a multiconcat */ 3636 3637 o->op_flags = (flags|OPf_KIDS|stacked_last 3638 |(o->op_flags & (OPf_WANT|OPf_PARENS))); 3639 o->op_private = private_flags; 3640 o->op_type = OP_MULTICONCAT; 3641 o->op_ppaddr = PL_ppaddr[OP_MULTICONCAT]; 3642 cUNOP_AUXo->op_aux = aux; 3643 } 3644 3645 3646 /* do all the final processing on an optree (e.g. running the peephole 3647 * optimiser on it), then attach it to cv (if cv is non-null) 3648 */ 3649 3650 static void 3651 S_process_optree(pTHX_ CV *cv, OP *optree, OP* start) 3652 { 3653 OP **startp; 3654 3655 /* XXX for some reason, evals, require and main optrees are 3656 * never attached to their CV; instead they just hang off 3657 * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start 3658 * and get manually freed when appropriate */ 3659 if (cv) 3660 startp = &CvSTART(cv); 3661 else 3662 startp = PL_in_eval? &PL_eval_start : &PL_main_start; 3663 3664 *startp = start; 3665 optree->op_private |= OPpREFCOUNTED; 3666 OpREFCNT_set(optree, 1); 3667 optimize_optree(optree); 3668 CALL_PEEP(*startp); 3669 finalize_optree(optree); 3670 S_prune_chain_head(startp); 3671 3672 if (cv) { 3673 /* now that optimizer has done its work, adjust pad values */ 3674 pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT 3675 : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB); 3676 } 3677 } 3678 3679 3680 /* 3681 =for apidoc optimize_optree 3682 3683 This function applies some optimisations to the optree in top-down order. 3684 It is called before the peephole optimizer, which processes ops in 3685 execution order. Note that finalize_optree() also does a top-down scan, 3686 but is called *after* the peephole optimizer. 3687 3688 =cut 3689 */ 3690 3691 void 3692 Perl_optimize_optree(pTHX_ OP* o) 3693 { 3694 PERL_ARGS_ASSERT_OPTIMIZE_OPTREE; 3695 3696 ENTER; 3697 SAVEVPTR(PL_curcop); 3698 3699 optimize_op(o); 3700 3701 LEAVE; 3702 } 3703 3704 3705 /* helper for optimize_optree() which optimises one op then recurses 3706 * to optimise any children. 3707 */ 3708 3709 STATIC void 3710 S_optimize_op(pTHX_ OP* o) 3711 { 3712 OP *top_op = o; 3713 3714 PERL_ARGS_ASSERT_OPTIMIZE_OP; 3715 3716 while (1) { 3717 OP * next_kid = NULL; 3718 3719 assert(o->op_type != OP_FREED); 3720 3721 switch (o->op_type) { 3722 case OP_NEXTSTATE: 3723 case OP_DBSTATE: 3724 PL_curcop = ((COP*)o); /* for warnings */ 3725 break; 3726 3727 3728 case OP_CONCAT: 3729 case OP_SASSIGN: 3730 case OP_STRINGIFY: 3731 case OP_SPRINTF: 3732 S_maybe_multiconcat(aTHX_ o); 3733 break; 3734 3735 case OP_SUBST: 3736 if (cPMOPo->op_pmreplrootu.op_pmreplroot) { 3737 /* we can't assume that op_pmreplroot->op_sibparent == o 3738 * and that it is thus possible to walk back up the tree 3739 * past op_pmreplroot. So, although we try to avoid 3740 * recursing through op trees, do it here. After all, 3741 * there are unlikely to be many nested s///e's within 3742 * the replacement part of a s///e. 3743 */ 3744 optimize_op(cPMOPo->op_pmreplrootu.op_pmreplroot); 3745 } 3746 break; 3747 3748 default: 3749 break; 3750 } 3751 3752 if (o->op_flags & OPf_KIDS) 3753 next_kid = cUNOPo->op_first; 3754 3755 /* if a kid hasn't been nominated to process, continue with the 3756 * next sibling, or if no siblings left, go back to the parent's 3757 * siblings and so on 3758 */ 3759 while (!next_kid) { 3760 if (o == top_op) 3761 return; /* at top; no parents/siblings to try */ 3762 if (OpHAS_SIBLING(o)) 3763 next_kid = o->op_sibparent; 3764 else 3765 o = o->op_sibparent; /*try parent's next sibling */ 3766 } 3767 3768 /* this label not yet used. Goto here if any code above sets 3769 * next-kid 3770 get_next_op: 3771 */ 3772 o = next_kid; 3773 } 3774 } 3775 3776 3777 /* 3778 =for apidoc finalize_optree 3779 3780 This function finalizes the optree. Should be called directly after 3781 the complete optree is built. It does some additional 3782 checking which can't be done in the normal C<ck_>xxx functions and makes 3783 the tree thread-safe. 3784 3785 =cut 3786 */ 3787 void 3788 Perl_finalize_optree(pTHX_ OP* o) 3789 { 3790 PERL_ARGS_ASSERT_FINALIZE_OPTREE; 3791 3792 ENTER; 3793 SAVEVPTR(PL_curcop); 3794 3795 finalize_op(o); 3796 3797 LEAVE; 3798 } 3799 3800 #ifdef USE_ITHREADS 3801 /* Relocate sv to the pad for thread safety. 3802 * Despite being a "constant", the SV is written to, 3803 * for reference counts, sv_upgrade() etc. */ 3804 PERL_STATIC_INLINE void 3805 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp) 3806 { 3807 PADOFFSET ix; 3808 PERL_ARGS_ASSERT_OP_RELOCATE_SV; 3809 if (!*svp) return; 3810 ix = pad_alloc(OP_CONST, SVf_READONLY); 3811 SvREFCNT_dec(PAD_SVl(ix)); 3812 PAD_SETSV(ix, *svp); 3813 /* XXX I don't know how this isn't readonly already. */ 3814 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix)); 3815 *svp = NULL; 3816 *targp = ix; 3817 } 3818 #endif 3819 3820 /* 3821 =for apidoc traverse_op_tree 3822 3823 Return the next op in a depth-first traversal of the op tree, 3824 returning NULL when the traversal is complete. 3825 3826 The initial call must supply the root of the tree as both top and o. 3827 3828 For now it's static, but it may be exposed to the API in the future. 3829 3830 =cut 3831 */ 3832 3833 STATIC OP* 3834 S_traverse_op_tree(pTHX_ OP *top, OP *o) { 3835 OP *sib; 3836 3837 PERL_ARGS_ASSERT_TRAVERSE_OP_TREE; 3838 3839 if ((o->op_flags & OPf_KIDS) && cUNOPo->op_first) { 3840 return cUNOPo->op_first; 3841 } 3842 else if ((sib = OpSIBLING(o))) { 3843 return sib; 3844 } 3845 else { 3846 OP *parent = o->op_sibparent; 3847 assert(!(o->op_moresib)); 3848 while (parent && parent != top) { 3849 OP *sib = OpSIBLING(parent); 3850 if (sib) 3851 return sib; 3852 parent = parent->op_sibparent; 3853 } 3854 3855 return NULL; 3856 } 3857 } 3858 3859 STATIC void 3860 S_finalize_op(pTHX_ OP* o) 3861 { 3862 OP * const top = o; 3863 PERL_ARGS_ASSERT_FINALIZE_OP; 3864 3865 do { 3866 assert(o->op_type != OP_FREED); 3867 3868 switch (o->op_type) { 3869 case OP_NEXTSTATE: 3870 case OP_DBSTATE: 3871 PL_curcop = ((COP*)o); /* for warnings */ 3872 break; 3873 case OP_EXEC: 3874 if (OpHAS_SIBLING(o)) { 3875 OP *sib = OpSIBLING(o); 3876 if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE) 3877 && ckWARN(WARN_EXEC) 3878 && OpHAS_SIBLING(sib)) 3879 { 3880 const OPCODE type = OpSIBLING(sib)->op_type; 3881 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) { 3882 const line_t oldline = CopLINE(PL_curcop); 3883 CopLINE_set(PL_curcop, CopLINE((COP*)sib)); 3884 Perl_warner(aTHX_ packWARN(WARN_EXEC), 3885 "Statement unlikely to be reached"); 3886 Perl_warner(aTHX_ packWARN(WARN_EXEC), 3887 "\t(Maybe you meant system() when you said exec()?)\n"); 3888 CopLINE_set(PL_curcop, oldline); 3889 } 3890 } 3891 } 3892 break; 3893 3894 case OP_GV: 3895 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) { 3896 GV * const gv = cGVOPo_gv; 3897 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) { 3898 /* XXX could check prototype here instead of just carping */ 3899 SV * const sv = sv_newmortal(); 3900 gv_efullname3(sv, gv, NULL); 3901 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), 3902 "%" SVf "() called too early to check prototype", 3903 SVfARG(sv)); 3904 } 3905 } 3906 break; 3907 3908 case OP_CONST: 3909 if (cSVOPo->op_private & OPpCONST_STRICT) 3910 no_bareword_allowed(o); 3911 #ifdef USE_ITHREADS 3912 /* FALLTHROUGH */ 3913 case OP_HINTSEVAL: 3914 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ); 3915 #endif 3916 break; 3917 3918 #ifdef USE_ITHREADS 3919 /* Relocate all the METHOP's SVs to the pad for thread safety. */ 3920 case OP_METHOD_NAMED: 3921 case OP_METHOD_SUPER: 3922 case OP_METHOD_REDIR: 3923 case OP_METHOD_REDIR_SUPER: 3924 op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ); 3925 break; 3926 #endif 3927 3928 case OP_HELEM: { 3929 UNOP *rop; 3930 SVOP *key_op; 3931 OP *kid; 3932 3933 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST) 3934 break; 3935 3936 rop = (UNOP*)((BINOP*)o)->op_first; 3937 3938 goto check_keys; 3939 3940 case OP_HSLICE: 3941 S_scalar_slice_warning(aTHX_ o); 3942 /* FALLTHROUGH */ 3943 3944 case OP_KVHSLICE: 3945 kid = OpSIBLING(cLISTOPo->op_first); 3946 if (/* I bet there's always a pushmark... */ 3947 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST) 3948 && OP_TYPE_ISNT_NN(kid, OP_CONST)) 3949 { 3950 break; 3951 } 3952 3953 key_op = (SVOP*)(kid->op_type == OP_CONST 3954 ? kid 3955 : OpSIBLING(kLISTOP->op_first)); 3956 3957 rop = (UNOP*)((LISTOP*)o)->op_last; 3958 3959 check_keys: 3960 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV) 3961 rop = NULL; 3962 S_check_hash_fields_and_hekify(aTHX_ rop, key_op, 1); 3963 break; 3964 } 3965 case OP_NULL: 3966 if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE) 3967 break; 3968 /* FALLTHROUGH */ 3969 case OP_ASLICE: 3970 S_scalar_slice_warning(aTHX_ o); 3971 break; 3972 3973 case OP_SUBST: { 3974 if (cPMOPo->op_pmreplrootu.op_pmreplroot) 3975 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot); 3976 break; 3977 } 3978 default: 3979 break; 3980 } 3981 3982 #ifdef DEBUGGING 3983 if (o->op_flags & OPf_KIDS) { 3984 OP *kid; 3985 3986 /* check that op_last points to the last sibling, and that 3987 * the last op_sibling/op_sibparent field points back to the 3988 * parent, and that the only ops with KIDS are those which are 3989 * entitled to them */ 3990 U32 type = o->op_type; 3991 U32 family; 3992 bool has_last; 3993 3994 if (type == OP_NULL) { 3995 type = o->op_targ; 3996 /* ck_glob creates a null UNOP with ex-type GLOB 3997 * (which is a list op. So pretend it wasn't a listop */ 3998 if (type == OP_GLOB) 3999 type = OP_NULL; 4000 } 4001 family = PL_opargs[type] & OA_CLASS_MASK; 4002 4003 has_last = ( family == OA_BINOP 4004 || family == OA_LISTOP 4005 || family == OA_PMOP 4006 || family == OA_LOOP 4007 ); 4008 assert( has_last /* has op_first and op_last, or ... 4009 ... has (or may have) op_first: */ 4010 || family == OA_UNOP 4011 || family == OA_UNOP_AUX 4012 || family == OA_LOGOP 4013 || family == OA_BASEOP_OR_UNOP 4014 || family == OA_FILESTATOP 4015 || family == OA_LOOPEXOP 4016 || family == OA_METHOP 4017 || type == OP_CUSTOM 4018 || type == OP_NULL /* new_logop does this */ 4019 ); 4020 4021 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) { 4022 if (!OpHAS_SIBLING(kid)) { 4023 if (has_last) 4024 assert(kid == cLISTOPo->op_last); 4025 assert(kid->op_sibparent == o); 4026 } 4027 } 4028 } 4029 #endif 4030 } while (( o = traverse_op_tree(top, o)) != NULL); 4031 } 4032 4033 static void 4034 S_mark_padname_lvalue(pTHX_ PADNAME *pn) 4035 { 4036 CV *cv = PL_compcv; 4037 PadnameLVALUE_on(pn); 4038 while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) { 4039 cv = CvOUTSIDE(cv); 4040 /* RT #127786: cv can be NULL due to an eval within the DB package 4041 * called from an anon sub - anon subs don't have CvOUTSIDE() set 4042 * unless they contain an eval, but calling eval within DB 4043 * pretends the eval was done in the caller's scope. 4044 */ 4045 if (!cv) 4046 break; 4047 assert(CvPADLIST(cv)); 4048 pn = 4049 PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)]; 4050 assert(PadnameLEN(pn)); 4051 PadnameLVALUE_on(pn); 4052 } 4053 } 4054 4055 static bool 4056 S_vivifies(const OPCODE type) 4057 { 4058 switch(type) { 4059 case OP_RV2AV: case OP_ASLICE: 4060 case OP_RV2HV: case OP_KVASLICE: 4061 case OP_RV2SV: case OP_HSLICE: 4062 case OP_AELEMFAST: case OP_KVHSLICE: 4063 case OP_HELEM: 4064 case OP_AELEM: 4065 return 1; 4066 } 4067 return 0; 4068 } 4069 4070 4071 /* apply lvalue reference (aliasing) context to the optree o. 4072 * E.g. in 4073 * \($x,$y) = (...) 4074 * o would be the list ($x,$y) and type would be OP_AASSIGN. 4075 * It may descend and apply this to children too, for example in 4076 * \( $cond ? $x, $y) = (...) 4077 */ 4078 4079 static void 4080 S_lvref(pTHX_ OP *o, I32 type) 4081 { 4082 dVAR; 4083 OP *kid; 4084 OP * top_op = o; 4085 4086 while (1) { 4087 switch (o->op_type) { 4088 case OP_COND_EXPR: 4089 o = OpSIBLING(cUNOPo->op_first); 4090 continue; 4091 4092 case OP_PUSHMARK: 4093 goto do_next; 4094 4095 case OP_RV2AV: 4096 if (cUNOPo->op_first->op_type != OP_GV) goto badref; 4097 o->op_flags |= OPf_STACKED; 4098 if (o->op_flags & OPf_PARENS) { 4099 if (o->op_private & OPpLVAL_INTRO) { 4100 yyerror(Perl_form(aTHX_ "Can't modify reference to " 4101 "localized parenthesized array in list assignment")); 4102 goto do_next; 4103 } 4104 slurpy: 4105 OpTYPE_set(o, OP_LVAVREF); 4106 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE; 4107 o->op_flags |= OPf_MOD|OPf_REF; 4108 goto do_next; 4109 } 4110 o->op_private |= OPpLVREF_AV; 4111 goto checkgv; 4112 4113 case OP_RV2CV: 4114 kid = cUNOPo->op_first; 4115 if (kid->op_type == OP_NULL) 4116 kid = cUNOPx(OpSIBLING(kUNOP->op_first)) 4117 ->op_first; 4118 o->op_private = OPpLVREF_CV; 4119 if (kid->op_type == OP_GV) 4120 o->op_flags |= OPf_STACKED; 4121 else if (kid->op_type == OP_PADCV) { 4122 o->op_targ = kid->op_targ; 4123 kid->op_targ = 0; 4124 op_free(cUNOPo->op_first); 4125 cUNOPo->op_first = NULL; 4126 o->op_flags &=~ OPf_KIDS; 4127 } 4128 else goto badref; 4129 break; 4130 4131 case OP_RV2HV: 4132 if (o->op_flags & OPf_PARENS) { 4133 parenhash: 4134 yyerror(Perl_form(aTHX_ "Can't modify reference to " 4135 "parenthesized hash in list assignment")); 4136 goto do_next; 4137 } 4138 o->op_private |= OPpLVREF_HV; 4139 /* FALLTHROUGH */ 4140 case OP_RV2SV: 4141 checkgv: 4142 if (cUNOPo->op_first->op_type != OP_GV) goto badref; 4143 o->op_flags |= OPf_STACKED; 4144 break; 4145 4146 case OP_PADHV: 4147 if (o->op_flags & OPf_PARENS) goto parenhash; 4148 o->op_private |= OPpLVREF_HV; 4149 /* FALLTHROUGH */ 4150 case OP_PADSV: 4151 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX); 4152 break; 4153 4154 case OP_PADAV: 4155 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX); 4156 if (o->op_flags & OPf_PARENS) goto slurpy; 4157 o->op_private |= OPpLVREF_AV; 4158 break; 4159 4160 case OP_AELEM: 4161 case OP_HELEM: 4162 o->op_private |= OPpLVREF_ELEM; 4163 o->op_flags |= OPf_STACKED; 4164 break; 4165 4166 case OP_ASLICE: 4167 case OP_HSLICE: 4168 OpTYPE_set(o, OP_LVREFSLICE); 4169 o->op_private &= OPpLVAL_INTRO; 4170 goto do_next; 4171 4172 case OP_NULL: 4173 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */ 4174 goto badref; 4175 else if (!(o->op_flags & OPf_KIDS)) 4176 goto do_next; 4177 4178 /* the code formerly only recursed into the first child of 4179 * a non ex-list OP_NULL. if we ever encounter such a null op with 4180 * more than one child, need to decide whether its ok to process 4181 * *all* its kids or not */ 4182 assert(o->op_targ == OP_LIST 4183 || !(OpHAS_SIBLING(cBINOPo->op_first))); 4184 /* FALLTHROUGH */ 4185 case OP_LIST: 4186 o = cLISTOPo->op_first; 4187 continue; 4188 4189 case OP_STUB: 4190 if (o->op_flags & OPf_PARENS) 4191 goto do_next; 4192 /* FALLTHROUGH */ 4193 default: 4194 badref: 4195 /* diag_listed_as: Can't modify reference to %s in %s assignment */ 4196 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s", 4197 o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL 4198 ? "do block" 4199 : OP_DESC(o), 4200 PL_op_desc[type])); 4201 goto do_next; 4202 } 4203 4204 OpTYPE_set(o, OP_LVREF); 4205 o->op_private &= 4206 OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE; 4207 if (type == OP_ENTERLOOP) 4208 o->op_private |= OPpLVREF_ITER; 4209 4210 do_next: 4211 while (1) { 4212 if (o == top_op) 4213 return; /* at top; no parents/siblings to try */ 4214 if (OpHAS_SIBLING(o)) { 4215 o = o->op_sibparent; 4216 break; 4217 } 4218 o = o->op_sibparent; /*try parent's next sibling */ 4219 } 4220 } /* while */ 4221 } 4222 4223 4224 PERL_STATIC_INLINE bool 4225 S_potential_mod_type(I32 type) 4226 { 4227 /* Types that only potentially result in modification. */ 4228 return type == OP_GREPSTART || type == OP_ENTERSUB 4229 || type == OP_REFGEN || type == OP_LEAVESUBLV; 4230 } 4231 4232 4233 /* 4234 =for apidoc op_lvalue 4235 4236 Propagate lvalue ("modifiable") context to an op and its children. 4237 C<type> represents the context type, roughly based on the type of op that 4238 would do the modifying, although C<local()> is represented by C<OP_NULL>, 4239 because it has no op type of its own (it is signalled by a flag on 4240 the lvalue op). 4241 4242 This function detects things that can't be modified, such as C<$x+1>, and 4243 generates errors for them. For example, C<$x+1 = 2> would cause it to be 4244 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>. 4245 4246 It also flags things that need to behave specially in an lvalue context, 4247 such as C<$$x = 5> which might have to vivify a reference in C<$x>. 4248 4249 =cut 4250 4251 Perl_op_lvalue_flags() is a non-API lower-level interface to 4252 op_lvalue(). The flags param has these bits: 4253 OP_LVALUE_NO_CROAK: return rather than croaking on error 4254 4255 */ 4256 4257 OP * 4258 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) 4259 { 4260 dVAR; 4261 OP *top_op = o; 4262 4263 if (!o || (PL_parser && PL_parser->error_count)) 4264 return o; 4265 4266 while (1) { 4267 OP *kid; 4268 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */ 4269 int localize = -1; 4270 OP *next_kid = NULL; 4271 4272 if ((o->op_private & OPpTARGET_MY) 4273 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */ 4274 { 4275 goto do_next; 4276 } 4277 4278 /* elements of a list might be in void context because the list is 4279 in scalar context or because they are attribute sub calls */ 4280 if ((o->op_flags & OPf_WANT) == OPf_WANT_VOID) 4281 goto do_next; 4282 4283 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB; 4284 4285 switch (o->op_type) { 4286 case OP_UNDEF: 4287 PL_modcount++; 4288 goto do_next; 4289 4290 case OP_STUB: 4291 if ((o->op_flags & OPf_PARENS)) 4292 break; 4293 goto nomod; 4294 4295 case OP_ENTERSUB: 4296 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) && 4297 !(o->op_flags & OPf_STACKED)) { 4298 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */ 4299 assert(cUNOPo->op_first->op_type == OP_NULL); 4300 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */ 4301 break; 4302 } 4303 else { /* lvalue subroutine call */ 4304 o->op_private |= OPpLVAL_INTRO; 4305 PL_modcount = RETURN_UNLIMITED_NUMBER; 4306 if (S_potential_mod_type(type)) { 4307 o->op_private |= OPpENTERSUB_INARGS; 4308 break; 4309 } 4310 else { /* Compile-time error message: */ 4311 OP *kid = cUNOPo->op_first; 4312 CV *cv; 4313 GV *gv; 4314 SV *namesv; 4315 4316 if (kid->op_type != OP_PUSHMARK) { 4317 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST) 4318 Perl_croak(aTHX_ 4319 "panic: unexpected lvalue entersub " 4320 "args: type/targ %ld:%" UVuf, 4321 (long)kid->op_type, (UV)kid->op_targ); 4322 kid = kLISTOP->op_first; 4323 } 4324 while (OpHAS_SIBLING(kid)) 4325 kid = OpSIBLING(kid); 4326 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) { 4327 break; /* Postpone until runtime */ 4328 } 4329 4330 kid = kUNOP->op_first; 4331 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV) 4332 kid = kUNOP->op_first; 4333 if (kid->op_type == OP_NULL) 4334 Perl_croak(aTHX_ 4335 "Unexpected constant lvalue entersub " 4336 "entry via type/targ %ld:%" UVuf, 4337 (long)kid->op_type, (UV)kid->op_targ); 4338 if (kid->op_type != OP_GV) { 4339 break; 4340 } 4341 4342 gv = kGVOP_gv; 4343 cv = isGV(gv) 4344 ? GvCV(gv) 4345 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV 4346 ? MUTABLE_CV(SvRV(gv)) 4347 : NULL; 4348 if (!cv) 4349 break; 4350 if (CvLVALUE(cv)) 4351 break; 4352 if (flags & OP_LVALUE_NO_CROAK) 4353 return NULL; 4354 4355 namesv = cv_name(cv, NULL, 0); 4356 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue " 4357 "subroutine call of &%" SVf " in %s", 4358 SVfARG(namesv), PL_op_desc[type]), 4359 SvUTF8(namesv)); 4360 goto do_next; 4361 } 4362 } 4363 /* FALLTHROUGH */ 4364 default: 4365 nomod: 4366 if (flags & OP_LVALUE_NO_CROAK) return NULL; 4367 /* grep, foreach, subcalls, refgen */ 4368 if (S_potential_mod_type(type)) 4369 break; 4370 yyerror(Perl_form(aTHX_ "Can't modify %s in %s", 4371 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL) 4372 ? "do block" 4373 : OP_DESC(o)), 4374 type ? PL_op_desc[type] : "local")); 4375 goto do_next; 4376 4377 case OP_PREINC: 4378 case OP_PREDEC: 4379 case OP_POW: 4380 case OP_MULTIPLY: 4381 case OP_DIVIDE: 4382 case OP_MODULO: 4383 case OP_ADD: 4384 case OP_SUBTRACT: 4385 case OP_CONCAT: 4386 case OP_LEFT_SHIFT: 4387 case OP_RIGHT_SHIFT: 4388 case OP_BIT_AND: 4389 case OP_BIT_XOR: 4390 case OP_BIT_OR: 4391 case OP_I_MULTIPLY: 4392 case OP_I_DIVIDE: 4393 case OP_I_MODULO: 4394 case OP_I_ADD: 4395 case OP_I_SUBTRACT: 4396 if (!(o->op_flags & OPf_STACKED)) 4397 goto nomod; 4398 PL_modcount++; 4399 break; 4400 4401 case OP_REPEAT: 4402 if (o->op_flags & OPf_STACKED) { 4403 PL_modcount++; 4404 break; 4405 } 4406 if (!(o->op_private & OPpREPEAT_DOLIST)) 4407 goto nomod; 4408 else { 4409 const I32 mods = PL_modcount; 4410 /* we recurse rather than iterate here because we need to 4411 * calculate and use the delta applied to PL_modcount by the 4412 * first child. So in something like 4413 * ($x, ($y) x 3) = split; 4414 * split knows that 4 elements are wanted 4415 */ 4416 modkids(cBINOPo->op_first, type); 4417 if (type != OP_AASSIGN) 4418 goto nomod; 4419 kid = cBINOPo->op_last; 4420 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) { 4421 const IV iv = SvIV(kSVOP_sv); 4422 if (PL_modcount != RETURN_UNLIMITED_NUMBER) 4423 PL_modcount = 4424 mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv); 4425 } 4426 else 4427 PL_modcount = RETURN_UNLIMITED_NUMBER; 4428 } 4429 break; 4430 4431 case OP_COND_EXPR: 4432 localize = 1; 4433 next_kid = OpSIBLING(cUNOPo->op_first); 4434 break; 4435 4436 case OP_RV2AV: 4437 case OP_RV2HV: 4438 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) { 4439 PL_modcount = RETURN_UNLIMITED_NUMBER; 4440 /* Treat \(@foo) like ordinary list, but still mark it as modi- 4441 fiable since some contexts need to know. */ 4442 o->op_flags |= OPf_MOD; 4443 goto do_next; 4444 } 4445 /* FALLTHROUGH */ 4446 case OP_RV2GV: 4447 if (scalar_mod_type(o, type)) 4448 goto nomod; 4449 ref(cUNOPo->op_first, o->op_type); 4450 /* FALLTHROUGH */ 4451 case OP_ASLICE: 4452 case OP_HSLICE: 4453 localize = 1; 4454 /* FALLTHROUGH */ 4455 case OP_AASSIGN: 4456 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */ 4457 if (type == OP_LEAVESUBLV && ( 4458 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV) 4459 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR 4460 )) 4461 o->op_private |= OPpMAYBE_LVSUB; 4462 /* FALLTHROUGH */ 4463 case OP_NEXTSTATE: 4464 case OP_DBSTATE: 4465 PL_modcount = RETURN_UNLIMITED_NUMBER; 4466 break; 4467 4468 case OP_KVHSLICE: 4469 case OP_KVASLICE: 4470 case OP_AKEYS: 4471 if (type == OP_LEAVESUBLV) 4472 o->op_private |= OPpMAYBE_LVSUB; 4473 goto nomod; 4474 4475 case OP_AVHVSWITCH: 4476 if (type == OP_LEAVESUBLV 4477 && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS) 4478 o->op_private |= OPpMAYBE_LVSUB; 4479 goto nomod; 4480 4481 case OP_AV2ARYLEN: 4482 PL_hints |= HINT_BLOCK_SCOPE; 4483 if (type == OP_LEAVESUBLV) 4484 o->op_private |= OPpMAYBE_LVSUB; 4485 PL_modcount++; 4486 break; 4487 4488 case OP_RV2SV: 4489 ref(cUNOPo->op_first, o->op_type); 4490 localize = 1; 4491 /* FALLTHROUGH */ 4492 case OP_GV: 4493 PL_hints |= HINT_BLOCK_SCOPE; 4494 /* FALLTHROUGH */ 4495 case OP_SASSIGN: 4496 case OP_ANDASSIGN: 4497 case OP_ORASSIGN: 4498 case OP_DORASSIGN: 4499 PL_modcount++; 4500 break; 4501 4502 case OP_AELEMFAST: 4503 case OP_AELEMFAST_LEX: 4504 localize = -1; 4505 PL_modcount++; 4506 break; 4507 4508 case OP_PADAV: 4509 case OP_PADHV: 4510 PL_modcount = RETURN_UNLIMITED_NUMBER; 4511 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) 4512 { 4513 /* Treat \(@foo) like ordinary list, but still mark it as modi- 4514 fiable since some contexts need to know. */ 4515 o->op_flags |= OPf_MOD; 4516 goto do_next; 4517 } 4518 if (scalar_mod_type(o, type)) 4519 goto nomod; 4520 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR 4521 && type == OP_LEAVESUBLV) 4522 o->op_private |= OPpMAYBE_LVSUB; 4523 /* FALLTHROUGH */ 4524 case OP_PADSV: 4525 PL_modcount++; 4526 if (!type) /* local() */ 4527 Perl_croak(aTHX_ "Can't localize lexical variable %" PNf, 4528 PNfARG(PAD_COMPNAME(o->op_targ))); 4529 if (!(o->op_private & OPpLVAL_INTRO) 4530 || ( type != OP_SASSIGN && type != OP_AASSIGN 4531 && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) )) 4532 S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ)); 4533 break; 4534 4535 case OP_PUSHMARK: 4536 localize = 0; 4537 break; 4538 4539 case OP_KEYS: 4540 if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type)) 4541 goto nomod; 4542 goto lvalue_func; 4543 case OP_SUBSTR: 4544 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */ 4545 goto nomod; 4546 /* FALLTHROUGH */ 4547 case OP_POS: 4548 case OP_VEC: 4549 lvalue_func: 4550 if (type == OP_LEAVESUBLV) 4551 o->op_private |= OPpMAYBE_LVSUB; 4552 if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) { 4553 /* we recurse rather than iterate here because the child 4554 * needs to be processed with a different 'type' parameter */ 4555 4556 /* substr and vec */ 4557 /* If this op is in merely potential (non-fatal) modifiable 4558 context, then apply OP_ENTERSUB context to 4559 the kid op (to avoid croaking). Other- 4560 wise pass this op’s own type so the correct op is mentioned 4561 in error messages. */ 4562 op_lvalue(OpSIBLING(cBINOPo->op_first), 4563 S_potential_mod_type(type) 4564 ? (I32)OP_ENTERSUB 4565 : o->op_type); 4566 } 4567 break; 4568 4569 case OP_AELEM: 4570 case OP_HELEM: 4571 ref(cBINOPo->op_first, o->op_type); 4572 if (type == OP_ENTERSUB && 4573 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF))) 4574 o->op_private |= OPpLVAL_DEFER; 4575 if (type == OP_LEAVESUBLV) 4576 o->op_private |= OPpMAYBE_LVSUB; 4577 localize = 1; 4578 PL_modcount++; 4579 break; 4580 4581 case OP_LEAVE: 4582 case OP_LEAVELOOP: 4583 o->op_private |= OPpLVALUE; 4584 /* FALLTHROUGH */ 4585 case OP_SCOPE: 4586 case OP_ENTER: 4587 case OP_LINESEQ: 4588 localize = 0; 4589 if (o->op_flags & OPf_KIDS) 4590 next_kid = cLISTOPo->op_last; 4591 break; 4592 4593 case OP_NULL: 4594 localize = 0; 4595 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */ 4596 goto nomod; 4597 else if (!(o->op_flags & OPf_KIDS)) 4598 break; 4599 4600 if (o->op_targ != OP_LIST) { 4601 OP *sib = OpSIBLING(cLISTOPo->op_first); 4602 /* OP_TRANS and OP_TRANSR with argument have a weird optree 4603 * that looks like 4604 * 4605 * null 4606 * arg 4607 * trans 4608 * 4609 * compared with things like OP_MATCH which have the argument 4610 * as a child: 4611 * 4612 * match 4613 * arg 4614 * 4615 * so handle specially to correctly get "Can't modify" croaks etc 4616 */ 4617 4618 if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR)) 4619 { 4620 /* this should trigger a "Can't modify transliteration" err */ 4621 op_lvalue(sib, type); 4622 } 4623 next_kid = cBINOPo->op_first; 4624 /* we assume OP_NULLs which aren't ex-list have no more than 2 4625 * children. If this assumption is wrong, increase the scan 4626 * limit below */ 4627 assert( !OpHAS_SIBLING(next_kid) 4628 || !OpHAS_SIBLING(OpSIBLING(next_kid))); 4629 break; 4630 } 4631 /* FALLTHROUGH */ 4632 case OP_LIST: 4633 localize = 0; 4634 next_kid = cLISTOPo->op_first; 4635 break; 4636 4637 case OP_COREARGS: 4638 goto do_next; 4639 4640 case OP_AND: 4641 case OP_OR: 4642 if (type == OP_LEAVESUBLV 4643 || !S_vivifies(cLOGOPo->op_first->op_type)) 4644 next_kid = cLOGOPo->op_first; 4645 else if (type == OP_LEAVESUBLV 4646 || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type)) 4647 next_kid = OpSIBLING(cLOGOPo->op_first); 4648 goto nomod; 4649 4650 case OP_SREFGEN: 4651 if (type == OP_NULL) { /* local */ 4652 local_refgen: 4653 if (!FEATURE_MYREF_IS_ENABLED) 4654 Perl_croak(aTHX_ "The experimental declared_refs " 4655 "feature is not enabled"); 4656 Perl_ck_warner_d(aTHX_ 4657 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS), 4658 "Declaring references is experimental"); 4659 next_kid = cUNOPo->op_first; 4660 goto do_next; 4661 } 4662 if (type != OP_AASSIGN && type != OP_SASSIGN 4663 && type != OP_ENTERLOOP) 4664 goto nomod; 4665 /* Don’t bother applying lvalue context to the ex-list. */ 4666 kid = cUNOPx(cUNOPo->op_first)->op_first; 4667 assert (!OpHAS_SIBLING(kid)); 4668 goto kid_2lvref; 4669 case OP_REFGEN: 4670 if (type == OP_NULL) /* local */ 4671 goto local_refgen; 4672 if (type != OP_AASSIGN) goto nomod; 4673 kid = cUNOPo->op_first; 4674 kid_2lvref: 4675 { 4676 const U8 ec = PL_parser ? PL_parser->error_count : 0; 4677 S_lvref(aTHX_ kid, type); 4678 if (!PL_parser || PL_parser->error_count == ec) { 4679 if (!FEATURE_REFALIASING_IS_ENABLED) 4680 Perl_croak(aTHX_ 4681 "Experimental aliasing via reference not enabled"); 4682 Perl_ck_warner_d(aTHX_ 4683 packWARN(WARN_EXPERIMENTAL__REFALIASING), 4684 "Aliasing via reference is experimental"); 4685 } 4686 } 4687 if (o->op_type == OP_REFGEN) 4688 op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */ 4689 op_null(o); 4690 goto do_next; 4691 4692 case OP_SPLIT: 4693 if ((o->op_private & OPpSPLIT_ASSIGN)) { 4694 /* This is actually @array = split. */ 4695 PL_modcount = RETURN_UNLIMITED_NUMBER; 4696 break; 4697 } 4698 goto nomod; 4699 4700 case OP_SCALAR: 4701 op_lvalue(cUNOPo->op_first, OP_ENTERSUB); 4702 goto nomod; 4703 } 4704 4705 /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that 4706 their argument is a filehandle; thus \stat(".") should not set 4707 it. AMS 20011102 */ 4708 if (type == OP_REFGEN && OP_IS_STAT(o->op_type)) 4709 goto do_next; 4710 4711 if (type != OP_LEAVESUBLV) 4712 o->op_flags |= OPf_MOD; 4713 4714 if (type == OP_AASSIGN || type == OP_SASSIGN) 4715 o->op_flags |= OPf_SPECIAL 4716 |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF); 4717 else if (!type) { /* local() */ 4718 switch (localize) { 4719 case 1: 4720 o->op_private |= OPpLVAL_INTRO; 4721 o->op_flags &= ~OPf_SPECIAL; 4722 PL_hints |= HINT_BLOCK_SCOPE; 4723 break; 4724 case 0: 4725 break; 4726 case -1: 4727 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), 4728 "Useless localization of %s", OP_DESC(o)); 4729 } 4730 } 4731 else if (type != OP_GREPSTART && type != OP_ENTERSUB 4732 && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB) 4733 o->op_flags |= OPf_REF; 4734 4735 do_next: 4736 while (!next_kid) { 4737 if (o == top_op) 4738 return top_op; /* at top; no parents/siblings to try */ 4739 if (OpHAS_SIBLING(o)) { 4740 next_kid = o->op_sibparent; 4741 if (!OpHAS_SIBLING(next_kid)) { 4742 /* a few node types don't recurse into their second child */ 4743 OP *parent = next_kid->op_sibparent; 4744 I32 ptype = parent->op_type; 4745 if ( (ptype == OP_NULL && parent->op_targ != OP_LIST) 4746 || ( (ptype == OP_AND || ptype == OP_OR) 4747 && (type != OP_LEAVESUBLV 4748 && S_vivifies(next_kid->op_type)) 4749 ) 4750 ) { 4751 /*try parent's next sibling */ 4752 o = parent; 4753 next_kid = NULL; 4754 } 4755 } 4756 } 4757 else 4758 o = o->op_sibparent; /*try parent's next sibling */ 4759 4760 } 4761 o = next_kid; 4762 4763 } /* while */ 4764 4765 } 4766 4767 4768 STATIC bool 4769 S_scalar_mod_type(const OP *o, I32 type) 4770 { 4771 switch (type) { 4772 case OP_POS: 4773 case OP_SASSIGN: 4774 if (o && o->op_type == OP_RV2GV) 4775 return FALSE; 4776 /* FALLTHROUGH */ 4777 case OP_PREINC: 4778 case OP_PREDEC: 4779 case OP_POSTINC: 4780 case OP_POSTDEC: 4781 case OP_I_PREINC: 4782 case OP_I_PREDEC: 4783 case OP_I_POSTINC: 4784 case OP_I_POSTDEC: 4785 case OP_POW: 4786 case OP_MULTIPLY: 4787 case OP_DIVIDE: 4788 case OP_MODULO: 4789 case OP_REPEAT: 4790 case OP_ADD: 4791 case OP_SUBTRACT: 4792 case OP_I_MULTIPLY: 4793 case OP_I_DIVIDE: 4794 case OP_I_MODULO: 4795 case OP_I_ADD: 4796 case OP_I_SUBTRACT: 4797 case OP_LEFT_SHIFT: 4798 case OP_RIGHT_SHIFT: 4799 case OP_BIT_AND: 4800 case OP_BIT_XOR: 4801 case OP_BIT_OR: 4802 case OP_NBIT_AND: 4803 case OP_NBIT_XOR: 4804 case OP_NBIT_OR: 4805 case OP_SBIT_AND: 4806 case OP_SBIT_XOR: 4807 case OP_SBIT_OR: 4808 case OP_CONCAT: 4809 case OP_SUBST: 4810 case OP_TRANS: 4811 case OP_TRANSR: 4812 case OP_READ: 4813 case OP_SYSREAD: 4814 case OP_RECV: 4815 case OP_ANDASSIGN: 4816 case OP_ORASSIGN: 4817 case OP_DORASSIGN: 4818 case OP_VEC: 4819 case OP_SUBSTR: 4820 return TRUE; 4821 default: 4822 return FALSE; 4823 } 4824 } 4825 4826 STATIC bool 4827 S_is_handle_constructor(const OP *o, I32 numargs) 4828 { 4829 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR; 4830 4831 switch (o->op_type) { 4832 case OP_PIPE_OP: 4833 case OP_SOCKPAIR: 4834 if (numargs == 2) 4835 return TRUE; 4836 /* FALLTHROUGH */ 4837 case OP_SYSOPEN: 4838 case OP_OPEN: 4839 case OP_SELECT: /* XXX c.f. SelectSaver.pm */ 4840 case OP_SOCKET: 4841 case OP_OPEN_DIR: 4842 case OP_ACCEPT: 4843 if (numargs == 1) 4844 return TRUE; 4845 /* FALLTHROUGH */ 4846 default: 4847 return FALSE; 4848 } 4849 } 4850 4851 static OP * 4852 S_refkids(pTHX_ OP *o, I32 type) 4853 { 4854 if (o && o->op_flags & OPf_KIDS) { 4855 OP *kid; 4856 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) 4857 ref(kid, type); 4858 } 4859 return o; 4860 } 4861 4862 4863 /* Apply reference (autovivification) context to the subtree at o. 4864 * For example in 4865 * push @{expression}, ....; 4866 * o will be the head of 'expression' and type will be OP_RV2AV. 4867 * It marks the op o (or a suitable child) as autovivifying, e.g. by 4868 * setting OPf_MOD. 4869 * For OP_RV2AV/OP_PADAV and OP_RV2HV/OP_PADHV sets OPf_REF too if 4870 * set_op_ref is true. 4871 * 4872 * Also calls scalar(o). 4873 */ 4874 4875 OP * 4876 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref) 4877 { 4878 dVAR; 4879 OP * top_op = o; 4880 4881 PERL_ARGS_ASSERT_DOREF; 4882 4883 if (PL_parser && PL_parser->error_count) 4884 return o; 4885 4886 while (1) { 4887 switch (o->op_type) { 4888 case OP_ENTERSUB: 4889 if ((type == OP_EXISTS || type == OP_DEFINED) && 4890 !(o->op_flags & OPf_STACKED)) { 4891 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */ 4892 assert(cUNOPo->op_first->op_type == OP_NULL); 4893 /* disable pushmark */ 4894 op_null(((LISTOP*)cUNOPo->op_first)->op_first); 4895 o->op_flags |= OPf_SPECIAL; 4896 } 4897 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){ 4898 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV 4899 : type == OP_RV2HV ? OPpDEREF_HV 4900 : OPpDEREF_SV); 4901 o->op_flags |= OPf_MOD; 4902 } 4903 4904 break; 4905 4906 case OP_COND_EXPR: 4907 o = OpSIBLING(cUNOPo->op_first); 4908 continue; 4909 4910 case OP_RV2SV: 4911 if (type == OP_DEFINED) 4912 o->op_flags |= OPf_SPECIAL; /* don't create GV */ 4913 /* FALLTHROUGH */ 4914 case OP_PADSV: 4915 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) { 4916 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV 4917 : type == OP_RV2HV ? OPpDEREF_HV 4918 : OPpDEREF_SV); 4919 o->op_flags |= OPf_MOD; 4920 } 4921 if (o->op_flags & OPf_KIDS) { 4922 type = o->op_type; 4923 o = cUNOPo->op_first; 4924 continue; 4925 } 4926 break; 4927 4928 case OP_RV2AV: 4929 case OP_RV2HV: 4930 if (set_op_ref) 4931 o->op_flags |= OPf_REF; 4932 /* FALLTHROUGH */ 4933 case OP_RV2GV: 4934 if (type == OP_DEFINED) 4935 o->op_flags |= OPf_SPECIAL; /* don't create GV */ 4936 type = o->op_type; 4937 o = cUNOPo->op_first; 4938 continue; 4939 4940 case OP_PADAV: 4941 case OP_PADHV: 4942 if (set_op_ref) 4943 o->op_flags |= OPf_REF; 4944 break; 4945 4946 case OP_SCALAR: 4947 case OP_NULL: 4948 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED) 4949 break; 4950 o = cBINOPo->op_first; 4951 continue; 4952 4953 case OP_AELEM: 4954 case OP_HELEM: 4955 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) { 4956 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV 4957 : type == OP_RV2HV ? OPpDEREF_HV 4958 : OPpDEREF_SV); 4959 o->op_flags |= OPf_MOD; 4960 } 4961 type = o->op_type; 4962 o = cBINOPo->op_first; 4963 continue;; 4964 4965 case OP_SCOPE: 4966 case OP_LEAVE: 4967 set_op_ref = FALSE; 4968 /* FALLTHROUGH */ 4969 case OP_ENTER: 4970 case OP_LIST: 4971 if (!(o->op_flags & OPf_KIDS)) 4972 break; 4973 o = cLISTOPo->op_last; 4974 continue; 4975 4976 default: 4977 break; 4978 } /* switch */ 4979 4980 while (1) { 4981 if (o == top_op) 4982 return scalar(top_op); /* at top; no parents/siblings to try */ 4983 if (OpHAS_SIBLING(o)) { 4984 o = o->op_sibparent; 4985 /* Normally skip all siblings and go straight to the parent; 4986 * the only op that requires two children to be processed 4987 * is OP_COND_EXPR */ 4988 if (!OpHAS_SIBLING(o) 4989 && o->op_sibparent->op_type == OP_COND_EXPR) 4990 break; 4991 continue; 4992 } 4993 o = o->op_sibparent; /*try parent's next sibling */ 4994 } 4995 } /* while */ 4996 } 4997 4998 4999 STATIC OP * 5000 S_dup_attrlist(pTHX_ OP *o) 5001 { 5002 OP *rop; 5003 5004 PERL_ARGS_ASSERT_DUP_ATTRLIST; 5005 5006 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids, 5007 * where the first kid is OP_PUSHMARK and the remaining ones 5008 * are OP_CONST. We need to push the OP_CONST values. 5009 */ 5010 if (o->op_type == OP_CONST) 5011 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv)); 5012 else { 5013 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS)); 5014 rop = NULL; 5015 for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) { 5016 if (o->op_type == OP_CONST) 5017 rop = op_append_elem(OP_LIST, rop, 5018 newSVOP(OP_CONST, o->op_flags, 5019 SvREFCNT_inc_NN(cSVOPo->op_sv))); 5020 } 5021 } 5022 return rop; 5023 } 5024 5025 STATIC void 5026 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs) 5027 { 5028 PERL_ARGS_ASSERT_APPLY_ATTRS; 5029 { 5030 SV * const stashsv = newSVhek(HvNAME_HEK(stash)); 5031 5032 /* fake up C<use attributes $pkg,$rv,@attrs> */ 5033 5034 #define ATTRSMODULE "attributes" 5035 #define ATTRSMODULE_PM "attributes.pm" 5036 5037 Perl_load_module( 5038 aTHX_ PERL_LOADMOD_IMPORT_OPS, 5039 newSVpvs(ATTRSMODULE), 5040 NULL, 5041 op_prepend_elem(OP_LIST, 5042 newSVOP(OP_CONST, 0, stashsv), 5043 op_prepend_elem(OP_LIST, 5044 newSVOP(OP_CONST, 0, 5045 newRV(target)), 5046 dup_attrlist(attrs)))); 5047 } 5048 } 5049 5050 STATIC void 5051 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) 5052 { 5053 OP *pack, *imop, *arg; 5054 SV *meth, *stashsv, **svp; 5055 5056 PERL_ARGS_ASSERT_APPLY_ATTRS_MY; 5057 5058 if (!attrs) 5059 return; 5060 5061 assert(target->op_type == OP_PADSV || 5062 target->op_type == OP_PADHV || 5063 target->op_type == OP_PADAV); 5064 5065 /* Ensure that attributes.pm is loaded. */ 5066 /* Don't force the C<use> if we don't need it. */ 5067 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE); 5068 if (svp && *svp != &PL_sv_undef) 5069 NOOP; /* already in %INC */ 5070 else 5071 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, 5072 newSVpvs(ATTRSMODULE), NULL); 5073 5074 /* Need package name for method call. */ 5075 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE)); 5076 5077 /* Build up the real arg-list. */ 5078 stashsv = newSVhek(HvNAME_HEK(stash)); 5079 5080 arg = newOP(OP_PADSV, 0); 5081 arg->op_targ = target->op_targ; 5082 arg = op_prepend_elem(OP_LIST, 5083 newSVOP(OP_CONST, 0, stashsv), 5084 op_prepend_elem(OP_LIST, 5085 newUNOP(OP_REFGEN, 0, 5086 arg), 5087 dup_attrlist(attrs))); 5088 5089 /* Fake up a method call to import */ 5090 meth = newSVpvs_share("import"); 5091 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID, 5092 op_append_elem(OP_LIST, 5093 op_prepend_elem(OP_LIST, pack, arg), 5094 newMETHOP_named(OP_METHOD_NAMED, 0, meth))); 5095 5096 /* Combine the ops. */ 5097 *imopsp = op_append_elem(OP_LIST, *imopsp, imop); 5098 } 5099 5100 /* 5101 =notfor apidoc apply_attrs_string 5102 5103 Attempts to apply a list of attributes specified by the C<attrstr> and 5104 C<len> arguments to the subroutine identified by the C<cv> argument which 5105 is expected to be associated with the package identified by the C<stashpv> 5106 argument (see L<attributes>). It gets this wrong, though, in that it 5107 does not correctly identify the boundaries of the individual attribute 5108 specifications within C<attrstr>. This is not really intended for the 5109 public API, but has to be listed here for systems such as AIX which 5110 need an explicit export list for symbols. (It's called from XS code 5111 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it 5112 to respect attribute syntax properly would be welcome. 5113 5114 =cut 5115 */ 5116 5117 void 5118 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv, 5119 const char *attrstr, STRLEN len) 5120 { 5121 OP *attrs = NULL; 5122 5123 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING; 5124 5125 if (!len) { 5126 len = strlen(attrstr); 5127 } 5128 5129 while (len) { 5130 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ; 5131 if (len) { 5132 const char * const sstr = attrstr; 5133 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ; 5134 attrs = op_append_elem(OP_LIST, attrs, 5135 newSVOP(OP_CONST, 0, 5136 newSVpvn(sstr, attrstr-sstr))); 5137 } 5138 } 5139 5140 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS, 5141 newSVpvs(ATTRSMODULE), 5142 NULL, op_prepend_elem(OP_LIST, 5143 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)), 5144 op_prepend_elem(OP_LIST, 5145 newSVOP(OP_CONST, 0, 5146 newRV(MUTABLE_SV(cv))), 5147 attrs))); 5148 } 5149 5150 STATIC void 5151 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name, 5152 bool curstash) 5153 { 5154 OP *new_proto = NULL; 5155 STRLEN pvlen; 5156 char *pv; 5157 OP *o; 5158 5159 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR; 5160 5161 if (!*attrs) 5162 return; 5163 5164 o = *attrs; 5165 if (o->op_type == OP_CONST) { 5166 pv = SvPV(cSVOPo_sv, pvlen); 5167 if (memBEGINs(pv, pvlen, "prototype(")) { 5168 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv)); 5169 SV ** const tmpo = cSVOPx_svp(o); 5170 SvREFCNT_dec(cSVOPo_sv); 5171 *tmpo = tmpsv; 5172 new_proto = o; 5173 *attrs = NULL; 5174 } 5175 } else if (o->op_type == OP_LIST) { 5176 OP * lasto; 5177 assert(o->op_flags & OPf_KIDS); 5178 lasto = cLISTOPo->op_first; 5179 assert(lasto->op_type == OP_PUSHMARK); 5180 for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) { 5181 if (o->op_type == OP_CONST) { 5182 pv = SvPV(cSVOPo_sv, pvlen); 5183 if (memBEGINs(pv, pvlen, "prototype(")) { 5184 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv)); 5185 SV ** const tmpo = cSVOPx_svp(o); 5186 SvREFCNT_dec(cSVOPo_sv); 5187 *tmpo = tmpsv; 5188 if (new_proto && ckWARN(WARN_MISC)) { 5189 STRLEN new_len; 5190 const char * newp = SvPV(cSVOPo_sv, new_len); 5191 Perl_warner(aTHX_ packWARN(WARN_MISC), 5192 "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub", 5193 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp)); 5194 op_free(new_proto); 5195 } 5196 else if (new_proto) 5197 op_free(new_proto); 5198 new_proto = o; 5199 /* excise new_proto from the list */ 5200 op_sibling_splice(*attrs, lasto, 1, NULL); 5201 o = lasto; 5202 continue; 5203 } 5204 } 5205 lasto = o; 5206 } 5207 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs 5208 would get pulled in with no real need */ 5209 if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) { 5210 op_free(*attrs); 5211 *attrs = NULL; 5212 } 5213 } 5214 5215 if (new_proto) { 5216 SV *svname; 5217 if (isGV(name)) { 5218 svname = sv_newmortal(); 5219 gv_efullname3(svname, name, NULL); 5220 } 5221 else if (SvPOK(name) && *SvPVX((SV *)name) == '&') 5222 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP); 5223 else 5224 svname = (SV *)name; 5225 if (ckWARN(WARN_ILLEGALPROTO)) 5226 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE, 5227 curstash); 5228 if (*proto && ckWARN(WARN_PROTOTYPE)) { 5229 STRLEN old_len, new_len; 5230 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len); 5231 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len); 5232 5233 if (curstash && svname == (SV *)name 5234 && !memchr(SvPVX(svname), ':', SvCUR(svname))) { 5235 svname = sv_2mortal(newSVsv(PL_curstname)); 5236 sv_catpvs(svname, "::"); 5237 sv_catsv(svname, (SV *)name); 5238 } 5239 5240 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), 5241 "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'" 5242 " in %" SVf, 5243 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp), 5244 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp), 5245 SVfARG(svname)); 5246 } 5247 if (*proto) 5248 op_free(*proto); 5249 *proto = new_proto; 5250 } 5251 } 5252 5253 static void 5254 S_cant_declare(pTHX_ OP *o) 5255 { 5256 if (o->op_type == OP_NULL 5257 && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS) 5258 o = cUNOPo->op_first; 5259 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"", 5260 o->op_type == OP_NULL 5261 && o->op_flags & OPf_SPECIAL 5262 ? "do block" 5263 : OP_DESC(o), 5264 PL_parser->in_my == KEY_our ? "our" : 5265 PL_parser->in_my == KEY_state ? "state" : 5266 "my")); 5267 } 5268 5269 STATIC OP * 5270 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) 5271 { 5272 I32 type; 5273 const bool stately = PL_parser && PL_parser->in_my == KEY_state; 5274 5275 PERL_ARGS_ASSERT_MY_KID; 5276 5277 if (!o || (PL_parser && PL_parser->error_count)) 5278 return o; 5279 5280 type = o->op_type; 5281 5282 if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) { 5283 OP *kid; 5284 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) 5285 my_kid(kid, attrs, imopsp); 5286 return o; 5287 } else if (type == OP_UNDEF || type == OP_STUB) { 5288 return o; 5289 } else if (type == OP_RV2SV || /* "our" declaration */ 5290 type == OP_RV2AV || 5291 type == OP_RV2HV) { 5292 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */ 5293 S_cant_declare(aTHX_ o); 5294 } else if (attrs) { 5295 GV * const gv = cGVOPx_gv(cUNOPo->op_first); 5296 assert(PL_parser); 5297 PL_parser->in_my = FALSE; 5298 PL_parser->in_my_stash = NULL; 5299 apply_attrs(GvSTASH(gv), 5300 (type == OP_RV2SV ? GvSVn(gv) : 5301 type == OP_RV2AV ? MUTABLE_SV(GvAVn(gv)) : 5302 type == OP_RV2HV ? MUTABLE_SV(GvHVn(gv)) : MUTABLE_SV(gv)), 5303 attrs); 5304 } 5305 o->op_private |= OPpOUR_INTRO; 5306 return o; 5307 } 5308 else if (type == OP_REFGEN || type == OP_SREFGEN) { 5309 if (!FEATURE_MYREF_IS_ENABLED) 5310 Perl_croak(aTHX_ "The experimental declared_refs " 5311 "feature is not enabled"); 5312 Perl_ck_warner_d(aTHX_ 5313 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS), 5314 "Declaring references is experimental"); 5315 /* Kid is a nulled OP_LIST, handled above. */ 5316 my_kid(cUNOPo->op_first, attrs, imopsp); 5317 return o; 5318 } 5319 else if (type != OP_PADSV && 5320 type != OP_PADAV && 5321 type != OP_PADHV && 5322 type != OP_PUSHMARK) 5323 { 5324 S_cant_declare(aTHX_ o); 5325 return o; 5326 } 5327 else if (attrs && type != OP_PUSHMARK) { 5328 HV *stash; 5329 5330 assert(PL_parser); 5331 PL_parser->in_my = FALSE; 5332 PL_parser->in_my_stash = NULL; 5333 5334 /* check for C<my Dog $spot> when deciding package */ 5335 stash = PAD_COMPNAME_TYPE(o->op_targ); 5336 if (!stash) 5337 stash = PL_curstash; 5338 apply_attrs_my(stash, o, attrs, imopsp); 5339 } 5340 o->op_flags |= OPf_MOD; 5341 o->op_private |= OPpLVAL_INTRO; 5342 if (stately) 5343 o->op_private |= OPpPAD_STATE; 5344 return o; 5345 } 5346 5347 OP * 5348 Perl_my_attrs(pTHX_ OP *o, OP *attrs) 5349 { 5350 OP *rops; 5351 int maybe_scalar = 0; 5352 5353 PERL_ARGS_ASSERT_MY_ATTRS; 5354 5355 /* [perl #17376]: this appears to be premature, and results in code such as 5356 C< our(%x); > executing in list mode rather than void mode */ 5357 #if 0 5358 if (o->op_flags & OPf_PARENS) 5359 list(o); 5360 else 5361 maybe_scalar = 1; 5362 #else 5363 maybe_scalar = 1; 5364 #endif 5365 if (attrs) 5366 SAVEFREEOP(attrs); 5367 rops = NULL; 5368 o = my_kid(o, attrs, &rops); 5369 if (rops) { 5370 if (maybe_scalar && o->op_type == OP_PADSV) { 5371 o = scalar(op_append_list(OP_LIST, rops, o)); 5372 o->op_private |= OPpLVAL_INTRO; 5373 } 5374 else { 5375 /* The listop in rops might have a pushmark at the beginning, 5376 which will mess up list assignment. */ 5377 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */ 5378 if (rops->op_type == OP_LIST && 5379 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK) 5380 { 5381 OP * const pushmark = lrops->op_first; 5382 /* excise pushmark */ 5383 op_sibling_splice(rops, NULL, 1, NULL); 5384 op_free(pushmark); 5385 } 5386 o = op_append_list(OP_LIST, o, rops); 5387 } 5388 } 5389 PL_parser->in_my = FALSE; 5390 PL_parser->in_my_stash = NULL; 5391 return o; 5392 } 5393 5394 OP * 5395 Perl_sawparens(pTHX_ OP *o) 5396 { 5397 PERL_UNUSED_CONTEXT; 5398 if (o) 5399 o->op_flags |= OPf_PARENS; 5400 return o; 5401 } 5402 5403 OP * 5404 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) 5405 { 5406 OP *o; 5407 bool ismatchop = 0; 5408 const OPCODE ltype = left->op_type; 5409 const OPCODE rtype = right->op_type; 5410 5411 PERL_ARGS_ASSERT_BIND_MATCH; 5412 5413 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV 5414 || ltype == OP_PADHV) && ckWARN(WARN_MISC)) 5415 { 5416 const char * const desc 5417 = PL_op_desc[( 5418 rtype == OP_SUBST || rtype == OP_TRANS 5419 || rtype == OP_TRANSR 5420 ) 5421 ? (int)rtype : OP_MATCH]; 5422 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV; 5423 SV * const name = 5424 S_op_varname(aTHX_ left); 5425 if (name) 5426 Perl_warner(aTHX_ packWARN(WARN_MISC), 5427 "Applying %s to %" SVf " will act on scalar(%" SVf ")", 5428 desc, SVfARG(name), SVfARG(name)); 5429 else { 5430 const char * const sample = (isary 5431 ? "@array" : "%hash"); 5432 Perl_warner(aTHX_ packWARN(WARN_MISC), 5433 "Applying %s to %s will act on scalar(%s)", 5434 desc, sample, sample); 5435 } 5436 } 5437 5438 if (rtype == OP_CONST && 5439 cSVOPx(right)->op_private & OPpCONST_BARE && 5440 cSVOPx(right)->op_private & OPpCONST_STRICT) 5441 { 5442 no_bareword_allowed(right); 5443 } 5444 5445 /* !~ doesn't make sense with /r, so error on it for now */ 5446 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) && 5447 type == OP_NOT) 5448 /* diag_listed_as: Using !~ with %s doesn't make sense */ 5449 yyerror("Using !~ with s///r doesn't make sense"); 5450 if (rtype == OP_TRANSR && type == OP_NOT) 5451 /* diag_listed_as: Using !~ with %s doesn't make sense */ 5452 yyerror("Using !~ with tr///r doesn't make sense"); 5453 5454 ismatchop = (rtype == OP_MATCH || 5455 rtype == OP_SUBST || 5456 rtype == OP_TRANS || rtype == OP_TRANSR) 5457 && !(right->op_flags & OPf_SPECIAL); 5458 if (ismatchop && right->op_private & OPpTARGET_MY) { 5459 right->op_targ = 0; 5460 right->op_private &= ~OPpTARGET_MY; 5461 } 5462 if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) { 5463 if (left->op_type == OP_PADSV 5464 && !(left->op_private & OPpLVAL_INTRO)) 5465 { 5466 right->op_targ = left->op_targ; 5467 op_free(left); 5468 o = right; 5469 } 5470 else { 5471 right->op_flags |= OPf_STACKED; 5472 if (rtype != OP_MATCH && rtype != OP_TRANSR && 5473 ! (rtype == OP_TRANS && 5474 right->op_private & OPpTRANS_IDENTICAL) && 5475 ! (rtype == OP_SUBST && 5476 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT))) 5477 left = op_lvalue(left, rtype); 5478 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR) 5479 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right); 5480 else 5481 o = op_prepend_elem(rtype, scalar(left), right); 5482 } 5483 if (type == OP_NOT) 5484 return newUNOP(OP_NOT, 0, scalar(o)); 5485 return o; 5486 } 5487 else 5488 return bind_match(type, left, 5489 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0)); 5490 } 5491 5492 OP * 5493 Perl_invert(pTHX_ OP *o) 5494 { 5495 if (!o) 5496 return NULL; 5497 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o)); 5498 } 5499 5500 OP * 5501 Perl_cmpchain_start(pTHX_ I32 type, OP *left, OP *right) 5502 { 5503 dVAR; 5504 BINOP *bop; 5505 OP *op; 5506 5507 if (!left) 5508 left = newOP(OP_NULL, 0); 5509 if (!right) 5510 right = newOP(OP_NULL, 0); 5511 scalar(left); 5512 scalar(right); 5513 NewOp(0, bop, 1, BINOP); 5514 op = (OP*)bop; 5515 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP); 5516 OpTYPE_set(op, type); 5517 cBINOPx(op)->op_flags = OPf_KIDS; 5518 cBINOPx(op)->op_private = 2; 5519 cBINOPx(op)->op_first = left; 5520 cBINOPx(op)->op_last = right; 5521 OpMORESIB_set(left, right); 5522 OpLASTSIB_set(right, op); 5523 return op; 5524 } 5525 5526 OP * 5527 Perl_cmpchain_extend(pTHX_ I32 type, OP *ch, OP *right) 5528 { 5529 dVAR; 5530 BINOP *bop; 5531 OP *op; 5532 5533 PERL_ARGS_ASSERT_CMPCHAIN_EXTEND; 5534 if (!right) 5535 right = newOP(OP_NULL, 0); 5536 scalar(right); 5537 NewOp(0, bop, 1, BINOP); 5538 op = (OP*)bop; 5539 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP); 5540 OpTYPE_set(op, type); 5541 if (ch->op_type != OP_NULL) { 5542 UNOP *lch; 5543 OP *nch, *cleft, *cright; 5544 NewOp(0, lch, 1, UNOP); 5545 nch = (OP*)lch; 5546 OpTYPE_set(nch, OP_NULL); 5547 nch->op_flags = OPf_KIDS; 5548 cleft = cBINOPx(ch)->op_first; 5549 cright = cBINOPx(ch)->op_last; 5550 cBINOPx(ch)->op_first = NULL; 5551 cBINOPx(ch)->op_last = NULL; 5552 cBINOPx(ch)->op_private = 0; 5553 cBINOPx(ch)->op_flags = 0; 5554 cUNOPx(nch)->op_first = cright; 5555 OpMORESIB_set(cright, ch); 5556 OpMORESIB_set(ch, cleft); 5557 OpLASTSIB_set(cleft, nch); 5558 ch = nch; 5559 } 5560 OpMORESIB_set(right, op); 5561 OpMORESIB_set(op, cUNOPx(ch)->op_first); 5562 cUNOPx(ch)->op_first = right; 5563 return ch; 5564 } 5565 5566 OP * 5567 Perl_cmpchain_finish(pTHX_ OP *ch) 5568 { 5569 dVAR; 5570 5571 PERL_ARGS_ASSERT_CMPCHAIN_FINISH; 5572 if (ch->op_type != OP_NULL) { 5573 OPCODE cmpoptype = ch->op_type; 5574 ch = CHECKOP(cmpoptype, ch); 5575 if(!ch->op_next && ch->op_type == cmpoptype) 5576 ch = fold_constants(op_integerize(op_std_init(ch))); 5577 return ch; 5578 } else { 5579 OP *condop = NULL; 5580 OP *rightarg = cUNOPx(ch)->op_first; 5581 cUNOPx(ch)->op_first = OpSIBLING(rightarg); 5582 OpLASTSIB_set(rightarg, NULL); 5583 while (1) { 5584 OP *cmpop = cUNOPx(ch)->op_first; 5585 OP *leftarg = OpSIBLING(cmpop); 5586 OPCODE cmpoptype = cmpop->op_type; 5587 OP *nextrightarg; 5588 bool is_last; 5589 is_last = !(cUNOPx(ch)->op_first = OpSIBLING(leftarg)); 5590 OpLASTSIB_set(cmpop, NULL); 5591 OpLASTSIB_set(leftarg, NULL); 5592 if (is_last) { 5593 ch->op_flags = 0; 5594 op_free(ch); 5595 nextrightarg = NULL; 5596 } else { 5597 nextrightarg = newUNOP(OP_CMPCHAIN_DUP, 0, leftarg); 5598 leftarg = newOP(OP_NULL, 0); 5599 } 5600 cBINOPx(cmpop)->op_first = leftarg; 5601 cBINOPx(cmpop)->op_last = rightarg; 5602 OpMORESIB_set(leftarg, rightarg); 5603 OpLASTSIB_set(rightarg, cmpop); 5604 cmpop->op_flags = OPf_KIDS; 5605 cmpop->op_private = 2; 5606 cmpop = CHECKOP(cmpoptype, cmpop); 5607 if(!cmpop->op_next && cmpop->op_type == cmpoptype) 5608 cmpop = op_integerize(op_std_init(cmpop)); 5609 condop = condop ? newLOGOP(OP_CMPCHAIN_AND, 0, cmpop, condop) : 5610 cmpop; 5611 if (!nextrightarg) 5612 return condop; 5613 rightarg = nextrightarg; 5614 } 5615 } 5616 } 5617 5618 /* 5619 =for apidoc op_scope 5620 5621 Wraps up an op tree with some additional ops so that at runtime a dynamic 5622 scope will be created. The original ops run in the new dynamic scope, 5623 and then, provided that they exit normally, the scope will be unwound. 5624 The additional ops used to create and unwind the dynamic scope will 5625 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used 5626 instead if the ops are simple enough to not need the full dynamic scope 5627 structure. 5628 5629 =cut 5630 */ 5631 5632 OP * 5633 Perl_op_scope(pTHX_ OP *o) 5634 { 5635 dVAR; 5636 if (o) { 5637 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) { 5638 o = op_prepend_elem(OP_LINESEQ, 5639 newOP(OP_ENTER, (o->op_flags & OPf_WANT)), o); 5640 OpTYPE_set(o, OP_LEAVE); 5641 } 5642 else if (o->op_type == OP_LINESEQ) { 5643 OP *kid; 5644 OpTYPE_set(o, OP_SCOPE); 5645 kid = ((LISTOP*)o)->op_first; 5646 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) { 5647 op_null(kid); 5648 5649 /* The following deals with things like 'do {1 for 1}' */ 5650 kid = OpSIBLING(kid); 5651 if (kid && 5652 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)) 5653 op_null(kid); 5654 } 5655 } 5656 else 5657 o = newLISTOP(OP_SCOPE, 0, o, NULL); 5658 } 5659 return o; 5660 } 5661 5662 OP * 5663 Perl_op_unscope(pTHX_ OP *o) 5664 { 5665 if (o && o->op_type == OP_LINESEQ) { 5666 OP *kid = cLISTOPo->op_first; 5667 for(; kid; kid = OpSIBLING(kid)) 5668 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) 5669 op_null(kid); 5670 } 5671 return o; 5672 } 5673 5674 /* 5675 =for apidoc block_start 5676 5677 Handles compile-time scope entry. 5678 Arranges for hints to be restored on block 5679 exit and also handles pad sequence numbers to make lexical variables scope 5680 right. Returns a savestack index for use with C<block_end>. 5681 5682 =cut 5683 */ 5684 5685 int 5686 Perl_block_start(pTHX_ int full) 5687 { 5688 const int retval = PL_savestack_ix; 5689 5690 PL_compiling.cop_seq = PL_cop_seqmax; 5691 COP_SEQMAX_INC; 5692 pad_block_start(full); 5693 SAVEHINTS(); 5694 PL_hints &= ~HINT_BLOCK_SCOPE; 5695 SAVECOMPILEWARNINGS(); 5696 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings); 5697 SAVEI32(PL_compiling.cop_seq); 5698 PL_compiling.cop_seq = 0; 5699 5700 CALL_BLOCK_HOOKS(bhk_start, full); 5701 5702 return retval; 5703 } 5704 5705 /* 5706 =for apidoc block_end 5707 5708 Handles compile-time scope exit. C<floor> 5709 is the savestack index returned by 5710 C<block_start>, and C<seq> is the body of the block. Returns the block, 5711 possibly modified. 5712 5713 =cut 5714 */ 5715 5716 OP* 5717 Perl_block_end(pTHX_ I32 floor, OP *seq) 5718 { 5719 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE; 5720 OP* retval = scalarseq(seq); 5721 OP *o; 5722 5723 /* XXX Is the null PL_parser check necessary here? */ 5724 assert(PL_parser); /* Let’s find out under debugging builds. */ 5725 if (PL_parser && PL_parser->parsed_sub) { 5726 o = newSTATEOP(0, NULL, NULL); 5727 op_null(o); 5728 retval = op_append_elem(OP_LINESEQ, retval, o); 5729 } 5730 5731 CALL_BLOCK_HOOKS(bhk_pre_end, &retval); 5732 5733 LEAVE_SCOPE(floor); 5734 if (needblockscope) 5735 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */ 5736 o = pad_leavemy(); 5737 5738 if (o) { 5739 /* pad_leavemy has created a sequence of introcv ops for all my 5740 subs declared in the block. We have to replicate that list with 5741 clonecv ops, to deal with this situation: 5742 5743 sub { 5744 my sub s1; 5745 my sub s2; 5746 sub s1 { state sub foo { \&s2 } } 5747 }->() 5748 5749 Originally, I was going to have introcv clone the CV and turn 5750 off the stale flag. Since &s1 is declared before &s2, the 5751 introcv op for &s1 is executed (on sub entry) before the one for 5752 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is 5753 cloned, since it is a state sub) closes over &s2 and expects 5754 to see it in its outer CV’s pad. If the introcv op clones &s1, 5755 then &s2 is still marked stale. Since &s1 is not active, and 5756 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia- 5757 ble will not stay shared’ warning. Because it is the same stub 5758 that will be used when the introcv op for &s2 is executed, clos- 5759 ing over it is safe. Hence, we have to turn off the stale flag 5760 on all lexical subs in the block before we clone any of them. 5761 Hence, having introcv clone the sub cannot work. So we create a 5762 list of ops like this: 5763 5764 lineseq 5765 | 5766 +-- introcv 5767 | 5768 +-- introcv 5769 | 5770 +-- introcv 5771 | 5772 . 5773 . 5774 . 5775 | 5776 +-- clonecv 5777 | 5778 +-- clonecv 5779 | 5780 +-- clonecv 5781 | 5782 . 5783 . 5784 . 5785 */ 5786 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o; 5787 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o; 5788 for (;; kid = OpSIBLING(kid)) { 5789 OP *newkid = newOP(OP_CLONECV, 0); 5790 newkid->op_targ = kid->op_targ; 5791 o = op_append_elem(OP_LINESEQ, o, newkid); 5792 if (kid == last) break; 5793 } 5794 retval = op_prepend_elem(OP_LINESEQ, o, retval); 5795 } 5796 5797 CALL_BLOCK_HOOKS(bhk_post_end, &retval); 5798 5799 return retval; 5800 } 5801 5802 /* 5803 =head1 Compile-time scope hooks 5804 5805 =for apidoc blockhook_register 5806 5807 Register a set of hooks to be called when the Perl lexical scope changes 5808 at compile time. See L<perlguts/"Compile-time scope hooks">. 5809 5810 =cut 5811 */ 5812 5813 void 5814 Perl_blockhook_register(pTHX_ BHK *hk) 5815 { 5816 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER; 5817 5818 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk))); 5819 } 5820 5821 void 5822 Perl_newPROG(pTHX_ OP *o) 5823 { 5824 OP *start; 5825 5826 PERL_ARGS_ASSERT_NEWPROG; 5827 5828 if (PL_in_eval) { 5829 PERL_CONTEXT *cx; 5830 I32 i; 5831 if (PL_eval_root) 5832 return; 5833 PL_eval_root = newUNOP(OP_LEAVEEVAL, 5834 ((PL_in_eval & EVAL_KEEPERR) 5835 ? OPf_SPECIAL : 0), o); 5836 5837 cx = CX_CUR(); 5838 assert(CxTYPE(cx) == CXt_EVAL); 5839 5840 if ((cx->blk_gimme & G_WANT) == G_VOID) 5841 scalarvoid(PL_eval_root); 5842 else if ((cx->blk_gimme & G_WANT) == G_ARRAY) 5843 list(PL_eval_root); 5844 else 5845 scalar(PL_eval_root); 5846 5847 start = op_linklist(PL_eval_root); 5848 PL_eval_root->op_next = 0; 5849 i = PL_savestack_ix; 5850 SAVEFREEOP(o); 5851 ENTER; 5852 S_process_optree(aTHX_ NULL, PL_eval_root, start); 5853 LEAVE; 5854 PL_savestack_ix = i; 5855 } 5856 else { 5857 if (o->op_type == OP_STUB) { 5858 /* This block is entered if nothing is compiled for the main 5859 program. This will be the case for an genuinely empty main 5860 program, or one which only has BEGIN blocks etc, so already 5861 run and freed. 5862 5863 Historically (5.000) the guard above was !o. However, commit 5864 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as 5865 c71fccf11fde0068, changed perly.y so that newPROG() is now 5866 called with the output of block_end(), which returns a new 5867 OP_STUB for the case of an empty optree. ByteLoader (and 5868 maybe other things) also take this path, because they set up 5869 PL_main_start and PL_main_root directly, without generating an 5870 optree. 5871 5872 If the parsing the main program aborts (due to parse errors, 5873 or due to BEGIN or similar calling exit), then newPROG() 5874 isn't even called, and hence this code path and its cleanups 5875 are skipped. This shouldn't make a make a difference: 5876 * a non-zero return from perl_parse is a failure, and 5877 perl_destruct() should be called immediately. 5878 * however, if exit(0) is called during the parse, then 5879 perl_parse() returns 0, and perl_run() is called. As 5880 PL_main_start will be NULL, perl_run() will return 5881 promptly, and the exit code will remain 0. 5882 */ 5883 5884 PL_comppad_name = 0; 5885 PL_compcv = 0; 5886 S_op_destroy(aTHX_ o); 5887 return; 5888 } 5889 PL_main_root = op_scope(sawparens(scalarvoid(o))); 5890 PL_curcop = &PL_compiling; 5891 start = LINKLIST(PL_main_root); 5892 PL_main_root->op_next = 0; 5893 S_process_optree(aTHX_ NULL, PL_main_root, start); 5894 if (!PL_parser->error_count) 5895 /* on error, leave CV slabbed so that ops left lying around 5896 * will eb cleaned up. Else unslab */ 5897 cv_forget_slab(PL_compcv); 5898 PL_compcv = 0; 5899 5900 /* Register with debugger */ 5901 if (PERLDB_INTER) { 5902 CV * const cv = get_cvs("DB::postponed", 0); 5903 if (cv) { 5904 dSP; 5905 PUSHMARK(SP); 5906 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling))); 5907 PUTBACK; 5908 call_sv(MUTABLE_SV(cv), G_DISCARD); 5909 } 5910 } 5911 } 5912 } 5913 5914 OP * 5915 Perl_localize(pTHX_ OP *o, I32 lex) 5916 { 5917 PERL_ARGS_ASSERT_LOCALIZE; 5918 5919 if (o->op_flags & OPf_PARENS) 5920 /* [perl #17376]: this appears to be premature, and results in code such as 5921 C< our(%x); > executing in list mode rather than void mode */ 5922 #if 0 5923 list(o); 5924 #else 5925 NOOP; 5926 #endif 5927 else { 5928 if ( PL_parser->bufptr > PL_parser->oldbufptr 5929 && PL_parser->bufptr[-1] == ',' 5930 && ckWARN(WARN_PARENTHESIS)) 5931 { 5932 char *s = PL_parser->bufptr; 5933 bool sigil = FALSE; 5934 5935 /* some heuristics to detect a potential error */ 5936 while (*s && (memCHRs(", \t\n", *s))) 5937 s++; 5938 5939 while (1) { 5940 if (*s && (memCHRs("@$%", *s) || (!lex && *s == '*')) 5941 && *++s 5942 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) { 5943 s++; 5944 sigil = TRUE; 5945 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) 5946 s++; 5947 while (*s && (memCHRs(", \t\n", *s))) 5948 s++; 5949 } 5950 else 5951 break; 5952 } 5953 if (sigil && (*s == ';' || *s == '=')) { 5954 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS), 5955 "Parentheses missing around \"%s\" list", 5956 lex 5957 ? (PL_parser->in_my == KEY_our 5958 ? "our" 5959 : PL_parser->in_my == KEY_state 5960 ? "state" 5961 : "my") 5962 : "local"); 5963 } 5964 } 5965 } 5966 if (lex) 5967 o = my(o); 5968 else 5969 o = op_lvalue(o, OP_NULL); /* a bit kludgey */ 5970 PL_parser->in_my = FALSE; 5971 PL_parser->in_my_stash = NULL; 5972 return o; 5973 } 5974 5975 OP * 5976 Perl_jmaybe(pTHX_ OP *o) 5977 { 5978 PERL_ARGS_ASSERT_JMAYBE; 5979 5980 if (o->op_type == OP_LIST) { 5981 OP * const o2 5982 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV))); 5983 o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o)); 5984 } 5985 return o; 5986 } 5987 5988 PERL_STATIC_INLINE OP * 5989 S_op_std_init(pTHX_ OP *o) 5990 { 5991 I32 type = o->op_type; 5992 5993 PERL_ARGS_ASSERT_OP_STD_INIT; 5994 5995 if (PL_opargs[type] & OA_RETSCALAR) 5996 scalar(o); 5997 if (PL_opargs[type] & OA_TARGET && !o->op_targ) 5998 o->op_targ = pad_alloc(type, SVs_PADTMP); 5999 6000 return o; 6001 } 6002 6003 PERL_STATIC_INLINE OP * 6004 S_op_integerize(pTHX_ OP *o) 6005 { 6006 I32 type = o->op_type; 6007 6008 PERL_ARGS_ASSERT_OP_INTEGERIZE; 6009 6010 /* integerize op. */ 6011 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)) 6012 { 6013 dVAR; 6014 o->op_ppaddr = PL_ppaddr[++(o->op_type)]; 6015 } 6016 6017 if (type == OP_NEGATE) 6018 /* XXX might want a ck_negate() for this */ 6019 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT; 6020 6021 return o; 6022 } 6023 6024 /* This function exists solely to provide a scope to limit 6025 setjmp/longjmp() messing with auto variables. It cannot be inlined because 6026 it uses setjmp 6027 */ 6028 STATIC int 6029 S_fold_constants_eval(pTHX) { 6030 int ret = 0; 6031 dJMPENV; 6032 6033 JMPENV_PUSH(ret); 6034 6035 if (ret == 0) { 6036 CALLRUNOPS(aTHX); 6037 } 6038 6039 JMPENV_POP; 6040 6041 return ret; 6042 } 6043 6044 static OP * 6045 S_fold_constants(pTHX_ OP *const o) 6046 { 6047 dVAR; 6048 OP *curop; 6049 OP *newop; 6050 I32 type = o->op_type; 6051 bool is_stringify; 6052 SV *sv = NULL; 6053 int ret = 0; 6054 OP *old_next; 6055 SV * const oldwarnhook = PL_warnhook; 6056 SV * const olddiehook = PL_diehook; 6057 COP not_compiling; 6058 U8 oldwarn = PL_dowarn; 6059 I32 old_cxix; 6060 6061 PERL_ARGS_ASSERT_FOLD_CONSTANTS; 6062 6063 if (!(PL_opargs[type] & OA_FOLDCONST)) 6064 goto nope; 6065 6066 switch (type) { 6067 case OP_UCFIRST: 6068 case OP_LCFIRST: 6069 case OP_UC: 6070 case OP_LC: 6071 case OP_FC: 6072 #ifdef USE_LOCALE_CTYPE 6073 if (IN_LC_COMPILETIME(LC_CTYPE)) 6074 goto nope; 6075 #endif 6076 break; 6077 case OP_SLT: 6078 case OP_SGT: 6079 case OP_SLE: 6080 case OP_SGE: 6081 case OP_SCMP: 6082 #ifdef USE_LOCALE_COLLATE 6083 if (IN_LC_COMPILETIME(LC_COLLATE)) 6084 goto nope; 6085 #endif 6086 break; 6087 case OP_SPRINTF: 6088 /* XXX what about the numeric ops? */ 6089 #ifdef USE_LOCALE_NUMERIC 6090 if (IN_LC_COMPILETIME(LC_NUMERIC)) 6091 goto nope; 6092 #endif 6093 break; 6094 case OP_PACK: 6095 if (!OpHAS_SIBLING(cLISTOPo->op_first) 6096 || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST) 6097 goto nope; 6098 { 6099 SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first)); 6100 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope; 6101 { 6102 const char *s = SvPVX_const(sv); 6103 while (s < SvEND(sv)) { 6104 if (isALPHA_FOLD_EQ(*s, 'p')) goto nope; 6105 s++; 6106 } 6107 } 6108 } 6109 break; 6110 case OP_REPEAT: 6111 if (o->op_private & OPpREPEAT_DOLIST) goto nope; 6112 break; 6113 case OP_SREFGEN: 6114 if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST 6115 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first))) 6116 goto nope; 6117 } 6118 6119 if (PL_parser && PL_parser->error_count) 6120 goto nope; /* Don't try to run w/ errors */ 6121 6122 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) { 6123 switch (curop->op_type) { 6124 case OP_CONST: 6125 if ( (curop->op_private & OPpCONST_BARE) 6126 && (curop->op_private & OPpCONST_STRICT)) { 6127 no_bareword_allowed(curop); 6128 goto nope; 6129 } 6130 /* FALLTHROUGH */ 6131 case OP_LIST: 6132 case OP_SCALAR: 6133 case OP_NULL: 6134 case OP_PUSHMARK: 6135 /* Foldable; move to next op in list */ 6136 break; 6137 6138 default: 6139 /* No other op types are considered foldable */ 6140 goto nope; 6141 } 6142 } 6143 6144 curop = LINKLIST(o); 6145 old_next = o->op_next; 6146 o->op_next = 0; 6147 PL_op = curop; 6148 6149 old_cxix = cxstack_ix; 6150 create_eval_scope(NULL, G_FAKINGEVAL); 6151 6152 /* Verify that we don't need to save it: */ 6153 assert(PL_curcop == &PL_compiling); 6154 StructCopy(&PL_compiling, ¬_compiling, COP); 6155 PL_curcop = ¬_compiling; 6156 /* The above ensures that we run with all the correct hints of the 6157 currently compiling COP, but that IN_PERL_RUNTIME is true. */ 6158 assert(IN_PERL_RUNTIME); 6159 PL_warnhook = PERL_WARNHOOK_FATAL; 6160 PL_diehook = NULL; 6161 6162 /* Effective $^W=1. */ 6163 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) 6164 PL_dowarn |= G_WARN_ON; 6165 6166 ret = S_fold_constants_eval(aTHX); 6167 6168 switch (ret) { 6169 case 0: 6170 sv = *(PL_stack_sp--); 6171 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */ 6172 pad_swipe(o->op_targ, FALSE); 6173 } 6174 else if (SvTEMP(sv)) { /* grab mortal temp? */ 6175 SvREFCNT_inc_simple_void(sv); 6176 SvTEMP_off(sv); 6177 } 6178 else { assert(SvIMMORTAL(sv)); } 6179 break; 6180 case 3: 6181 /* Something tried to die. Abandon constant folding. */ 6182 /* Pretend the error never happened. */ 6183 CLEAR_ERRSV(); 6184 o->op_next = old_next; 6185 break; 6186 default: 6187 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */ 6188 PL_warnhook = oldwarnhook; 6189 PL_diehook = olddiehook; 6190 /* XXX note that this croak may fail as we've already blown away 6191 * the stack - eg any nested evals */ 6192 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret); 6193 } 6194 PL_dowarn = oldwarn; 6195 PL_warnhook = oldwarnhook; 6196 PL_diehook = olddiehook; 6197 PL_curcop = &PL_compiling; 6198 6199 /* if we croaked, depending on how we croaked the eval scope 6200 * may or may not have already been popped */ 6201 if (cxstack_ix > old_cxix) { 6202 assert(cxstack_ix == old_cxix + 1); 6203 assert(CxTYPE(CX_CUR()) == CXt_EVAL); 6204 delete_eval_scope(); 6205 } 6206 if (ret) 6207 goto nope; 6208 6209 /* OP_STRINGIFY and constant folding are used to implement qq. 6210 Here the constant folding is an implementation detail that we 6211 want to hide. If the stringify op is itself already marked 6212 folded, however, then it is actually a folded join. */ 6213 is_stringify = type == OP_STRINGIFY && !o->op_folded; 6214 op_free(o); 6215 assert(sv); 6216 if (is_stringify) 6217 SvPADTMP_off(sv); 6218 else if (!SvIMMORTAL(sv)) { 6219 SvPADTMP_on(sv); 6220 SvREADONLY_on(sv); 6221 } 6222 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv)); 6223 if (!is_stringify) newop->op_folded = 1; 6224 return newop; 6225 6226 nope: 6227 return o; 6228 } 6229 6230 /* convert a constant range in list context into an OP_RV2AV, OP_CONST pair; 6231 * the constant value being an AV holding the flattened range. 6232 */ 6233 6234 static void 6235 S_gen_constant_list(pTHX_ OP *o) 6236 { 6237 dVAR; 6238 OP *curop, *old_next; 6239 SV * const oldwarnhook = PL_warnhook; 6240 SV * const olddiehook = PL_diehook; 6241 COP *old_curcop; 6242 U8 oldwarn = PL_dowarn; 6243 SV **svp; 6244 AV *av; 6245 I32 old_cxix; 6246 COP not_compiling; 6247 int ret = 0; 6248 dJMPENV; 6249 bool op_was_null; 6250 6251 list(o); 6252 if (PL_parser && PL_parser->error_count) 6253 return; /* Don't attempt to run with errors */ 6254 6255 curop = LINKLIST(o); 6256 old_next = o->op_next; 6257 o->op_next = 0; 6258 op_was_null = o->op_type == OP_NULL; 6259 if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */ 6260 o->op_type = OP_CUSTOM; 6261 CALL_PEEP(curop); 6262 if (op_was_null) 6263 o->op_type = OP_NULL; 6264 S_prune_chain_head(&curop); 6265 PL_op = curop; 6266 6267 old_cxix = cxstack_ix; 6268 create_eval_scope(NULL, G_FAKINGEVAL); 6269 6270 old_curcop = PL_curcop; 6271 StructCopy(old_curcop, ¬_compiling, COP); 6272 PL_curcop = ¬_compiling; 6273 /* The above ensures that we run with all the correct hints of the 6274 current COP, but that IN_PERL_RUNTIME is true. */ 6275 assert(IN_PERL_RUNTIME); 6276 PL_warnhook = PERL_WARNHOOK_FATAL; 6277 PL_diehook = NULL; 6278 JMPENV_PUSH(ret); 6279 6280 /* Effective $^W=1. */ 6281 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) 6282 PL_dowarn |= G_WARN_ON; 6283 6284 switch (ret) { 6285 case 0: 6286 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY 6287 PL_curstackinfo->si_stack_hwm = 0; /* stop valgrind complaining */ 6288 #endif 6289 Perl_pp_pushmark(aTHX); 6290 CALLRUNOPS(aTHX); 6291 PL_op = curop; 6292 assert (!(curop->op_flags & OPf_SPECIAL)); 6293 assert(curop->op_type == OP_RANGE); 6294 Perl_pp_anonlist(aTHX); 6295 break; 6296 case 3: 6297 CLEAR_ERRSV(); 6298 o->op_next = old_next; 6299 break; 6300 default: 6301 JMPENV_POP; 6302 PL_warnhook = oldwarnhook; 6303 PL_diehook = olddiehook; 6304 Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d", 6305 ret); 6306 } 6307 6308 JMPENV_POP; 6309 PL_dowarn = oldwarn; 6310 PL_warnhook = oldwarnhook; 6311 PL_diehook = olddiehook; 6312 PL_curcop = old_curcop; 6313 6314 if (cxstack_ix > old_cxix) { 6315 assert(cxstack_ix == old_cxix + 1); 6316 assert(CxTYPE(CX_CUR()) == CXt_EVAL); 6317 delete_eval_scope(); 6318 } 6319 if (ret) 6320 return; 6321 6322 OpTYPE_set(o, OP_RV2AV); 6323 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */ 6324 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */ 6325 o->op_opt = 0; /* needs to be revisited in rpeep() */ 6326 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--); 6327 6328 /* replace subtree with an OP_CONST */ 6329 curop = ((UNOP*)o)->op_first; 6330 op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av)); 6331 op_free(curop); 6332 6333 if (AvFILLp(av) != -1) 6334 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp) 6335 { 6336 SvPADTMP_on(*svp); 6337 SvREADONLY_on(*svp); 6338 } 6339 LINKLIST(o); 6340 list(o); 6341 return; 6342 } 6343 6344 /* 6345 =head1 Optree Manipulation Functions 6346 */ 6347 6348 /* List constructors */ 6349 6350 /* 6351 =for apidoc op_append_elem 6352 6353 Append an item to the list of ops contained directly within a list-type 6354 op, returning the lengthened list. C<first> is the list-type op, 6355 and C<last> is the op to append to the list. C<optype> specifies the 6356 intended opcode for the list. If C<first> is not already a list of the 6357 right type, it will be upgraded into one. If either C<first> or C<last> 6358 is null, the other is returned unchanged. 6359 6360 =cut 6361 */ 6362 6363 OP * 6364 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last) 6365 { 6366 if (!first) 6367 return last; 6368 6369 if (!last) 6370 return first; 6371 6372 if (first->op_type != (unsigned)type 6373 || (type == OP_LIST && (first->op_flags & OPf_PARENS))) 6374 { 6375 return newLISTOP(type, 0, first, last); 6376 } 6377 6378 op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last); 6379 first->op_flags |= OPf_KIDS; 6380 return first; 6381 } 6382 6383 /* 6384 =for apidoc op_append_list 6385 6386 Concatenate the lists of ops contained directly within two list-type ops, 6387 returning the combined list. C<first> and C<last> are the list-type ops 6388 to concatenate. C<optype> specifies the intended opcode for the list. 6389 If either C<first> or C<last> is not already a list of the right type, 6390 it will be upgraded into one. If either C<first> or C<last> is null, 6391 the other is returned unchanged. 6392 6393 =cut 6394 */ 6395 6396 OP * 6397 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last) 6398 { 6399 if (!first) 6400 return last; 6401 6402 if (!last) 6403 return first; 6404 6405 if (first->op_type != (unsigned)type) 6406 return op_prepend_elem(type, first, last); 6407 6408 if (last->op_type != (unsigned)type) 6409 return op_append_elem(type, first, last); 6410 6411 OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first); 6412 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last; 6413 OpLASTSIB_set(((LISTOP*)first)->op_last, first); 6414 first->op_flags |= (last->op_flags & OPf_KIDS); 6415 6416 S_op_destroy(aTHX_ last); 6417 6418 return first; 6419 } 6420 6421 /* 6422 =for apidoc op_prepend_elem 6423 6424 Prepend an item to the list of ops contained directly within a list-type 6425 op, returning the lengthened list. C<first> is the op to prepend to the 6426 list, and C<last> is the list-type op. C<optype> specifies the intended 6427 opcode for the list. If C<last> is not already a list of the right type, 6428 it will be upgraded into one. If either C<first> or C<last> is null, 6429 the other is returned unchanged. 6430 6431 =cut 6432 */ 6433 6434 OP * 6435 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last) 6436 { 6437 if (!first) 6438 return last; 6439 6440 if (!last) 6441 return first; 6442 6443 if (last->op_type == (unsigned)type) { 6444 if (type == OP_LIST) { /* already a PUSHMARK there */ 6445 /* insert 'first' after pushmark */ 6446 op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first); 6447 if (!(first->op_flags & OPf_PARENS)) 6448 last->op_flags &= ~OPf_PARENS; 6449 } 6450 else 6451 op_sibling_splice(last, NULL, 0, first); 6452 last->op_flags |= OPf_KIDS; 6453 return last; 6454 } 6455 6456 return newLISTOP(type, 0, first, last); 6457 } 6458 6459 /* 6460 =for apidoc op_convert_list 6461 6462 Converts C<o> into a list op if it is not one already, and then converts it 6463 into the specified C<type>, calling its check function, allocating a target if 6464 it needs one, and folding constants. 6465 6466 A list-type op is usually constructed one kid at a time via C<newLISTOP>, 6467 C<op_prepend_elem> and C<op_append_elem>. Then finally it is passed to 6468 C<op_convert_list> to make it the right type. 6469 6470 =cut 6471 */ 6472 6473 OP * 6474 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o) 6475 { 6476 dVAR; 6477 if (type < 0) type = -type, flags |= OPf_SPECIAL; 6478 if (!o || o->op_type != OP_LIST) 6479 o = force_list(o, 0); 6480 else 6481 { 6482 o->op_flags &= ~OPf_WANT; 6483 o->op_private &= ~OPpLVAL_INTRO; 6484 } 6485 6486 if (!(PL_opargs[type] & OA_MARK)) 6487 op_null(cLISTOPo->op_first); 6488 else { 6489 OP * const kid2 = OpSIBLING(cLISTOPo->op_first); 6490 if (kid2 && kid2->op_type == OP_COREARGS) { 6491 op_null(cLISTOPo->op_first); 6492 kid2->op_private |= OPpCOREARGS_PUSHMARK; 6493 } 6494 } 6495 6496 if (type != OP_SPLIT) 6497 /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let 6498 * ck_split() create a real PMOP and leave the op's type as listop 6499 * for now. Otherwise op_free() etc will crash. 6500 */ 6501 OpTYPE_set(o, type); 6502 6503 o->op_flags |= flags; 6504 if (flags & OPf_FOLDED) 6505 o->op_folded = 1; 6506 6507 o = CHECKOP(type, o); 6508 if (o->op_type != (unsigned)type) 6509 return o; 6510 6511 return fold_constants(op_integerize(op_std_init(o))); 6512 } 6513 6514 /* Constructors */ 6515 6516 6517 /* 6518 =head1 Optree construction 6519 6520 =for apidoc newNULLLIST 6521 6522 Constructs, checks, and returns a new C<stub> op, which represents an 6523 empty list expression. 6524 6525 =cut 6526 */ 6527 6528 OP * 6529 Perl_newNULLLIST(pTHX) 6530 { 6531 return newOP(OP_STUB, 0); 6532 } 6533 6534 /* promote o and any siblings to be a list if its not already; i.e. 6535 * 6536 * o - A - B 6537 * 6538 * becomes 6539 * 6540 * list 6541 * | 6542 * pushmark - o - A - B 6543 * 6544 * If nullit it true, the list op is nulled. 6545 */ 6546 6547 static OP * 6548 S_force_list(pTHX_ OP *o, bool nullit) 6549 { 6550 if (!o || o->op_type != OP_LIST) { 6551 OP *rest = NULL; 6552 if (o) { 6553 /* manually detach any siblings then add them back later */ 6554 rest = OpSIBLING(o); 6555 OpLASTSIB_set(o, NULL); 6556 } 6557 o = newLISTOP(OP_LIST, 0, o, NULL); 6558 if (rest) 6559 op_sibling_splice(o, cLISTOPo->op_last, 0, rest); 6560 } 6561 if (nullit) 6562 op_null(o); 6563 return o; 6564 } 6565 6566 /* 6567 =for apidoc newLISTOP 6568 6569 Constructs, checks, and returns an op of any list type. C<type> is 6570 the opcode. C<flags> gives the eight bits of C<op_flags>, except that 6571 C<OPf_KIDS> will be set automatically if required. C<first> and C<last> 6572 supply up to two ops to be direct children of the list op; they are 6573 consumed by this function and become part of the constructed op tree. 6574 6575 For most list operators, the check function expects all the kid ops to be 6576 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not 6577 appropriate. What you want to do in that case is create an op of type 6578 C<OP_LIST>, append more children to it, and then call L</op_convert_list>. 6579 See L</op_convert_list> for more information. 6580 6581 6582 =cut 6583 */ 6584 6585 OP * 6586 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) 6587 { 6588 dVAR; 6589 LISTOP *listop; 6590 /* Note that allocating an OP_PUSHMARK can die under Safe.pm if 6591 * pushmark is banned. So do it now while existing ops are in a 6592 * consistent state, in case they suddenly get freed */ 6593 OP* const pushop = type == OP_LIST ? newOP(OP_PUSHMARK, 0) : NULL; 6594 6595 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP 6596 || type == OP_CUSTOM); 6597 6598 NewOp(1101, listop, 1, LISTOP); 6599 OpTYPE_set(listop, type); 6600 if (first || last) 6601 flags |= OPf_KIDS; 6602 listop->op_flags = (U8)flags; 6603 6604 if (!last && first) 6605 last = first; 6606 else if (!first && last) 6607 first = last; 6608 else if (first) 6609 OpMORESIB_set(first, last); 6610 listop->op_first = first; 6611 listop->op_last = last; 6612 6613 if (pushop) { 6614 OpMORESIB_set(pushop, first); 6615 listop->op_first = pushop; 6616 listop->op_flags |= OPf_KIDS; 6617 if (!last) 6618 listop->op_last = pushop; 6619 } 6620 if (listop->op_last) 6621 OpLASTSIB_set(listop->op_last, (OP*)listop); 6622 6623 return CHECKOP(type, listop); 6624 } 6625 6626 /* 6627 =for apidoc newOP 6628 6629 Constructs, checks, and returns an op of any base type (any type that 6630 has no extra fields). C<type> is the opcode. C<flags> gives the 6631 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits 6632 of C<op_private>. 6633 6634 =cut 6635 */ 6636 6637 OP * 6638 Perl_newOP(pTHX_ I32 type, I32 flags) 6639 { 6640 dVAR; 6641 OP *o; 6642 6643 if (type == -OP_ENTEREVAL) { 6644 type = OP_ENTEREVAL; 6645 flags |= OPpEVAL_BYTES<<8; 6646 } 6647 6648 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP 6649 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP 6650 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP 6651 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP); 6652 6653 NewOp(1101, o, 1, OP); 6654 OpTYPE_set(o, type); 6655 o->op_flags = (U8)flags; 6656 6657 o->op_next = o; 6658 o->op_private = (U8)(0 | (flags >> 8)); 6659 if (PL_opargs[type] & OA_RETSCALAR) 6660 scalar(o); 6661 if (PL_opargs[type] & OA_TARGET) 6662 o->op_targ = pad_alloc(type, SVs_PADTMP); 6663 return CHECKOP(type, o); 6664 } 6665 6666 /* 6667 =for apidoc newUNOP 6668 6669 Constructs, checks, and returns an op of any unary type. C<type> is 6670 the opcode. C<flags> gives the eight bits of C<op_flags>, except that 6671 C<OPf_KIDS> will be set automatically if required, and, shifted up eight 6672 bits, the eight bits of C<op_private>, except that the bit with value 1 6673 is automatically set. C<first> supplies an optional op to be the direct 6674 child of the unary op; it is consumed by this function and become part 6675 of the constructed op tree. 6676 6677 =for apidoc Amnh||OPf_KIDS 6678 6679 =cut 6680 */ 6681 6682 OP * 6683 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) 6684 { 6685 dVAR; 6686 UNOP *unop; 6687 6688 if (type == -OP_ENTEREVAL) { 6689 type = OP_ENTEREVAL; 6690 flags |= OPpEVAL_BYTES<<8; 6691 } 6692 6693 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP 6694 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP 6695 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP 6696 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP 6697 || type == OP_SASSIGN 6698 || type == OP_ENTERTRY 6699 || type == OP_CUSTOM 6700 || type == OP_NULL ); 6701 6702 if (!first) 6703 first = newOP(OP_STUB, 0); 6704 if (PL_opargs[type] & OA_MARK) 6705 first = force_list(first, 1); 6706 6707 NewOp(1101, unop, 1, UNOP); 6708 OpTYPE_set(unop, type); 6709 unop->op_first = first; 6710 unop->op_flags = (U8)(flags | OPf_KIDS); 6711 unop->op_private = (U8)(1 | (flags >> 8)); 6712 6713 if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */ 6714 OpLASTSIB_set(first, (OP*)unop); 6715 6716 unop = (UNOP*) CHECKOP(type, unop); 6717 if (unop->op_next) 6718 return (OP*)unop; 6719 6720 return fold_constants(op_integerize(op_std_init((OP *) unop))); 6721 } 6722 6723 /* 6724 =for apidoc newUNOP_AUX 6725 6726 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux> 6727 initialised to C<aux> 6728 6729 =cut 6730 */ 6731 6732 OP * 6733 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux) 6734 { 6735 dVAR; 6736 UNOP_AUX *unop; 6737 6738 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX 6739 || type == OP_CUSTOM); 6740 6741 NewOp(1101, unop, 1, UNOP_AUX); 6742 unop->op_type = (OPCODE)type; 6743 unop->op_ppaddr = PL_ppaddr[type]; 6744 unop->op_first = first; 6745 unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0)); 6746 unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8)); 6747 unop->op_aux = aux; 6748 6749 if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */ 6750 OpLASTSIB_set(first, (OP*)unop); 6751 6752 unop = (UNOP_AUX*) CHECKOP(type, unop); 6753 6754 return op_std_init((OP *) unop); 6755 } 6756 6757 /* 6758 =for apidoc newMETHOP 6759 6760 Constructs, checks, and returns an op of method type with a method name 6761 evaluated at runtime. C<type> is the opcode. C<flags> gives the eight 6762 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically, 6763 and, shifted up eight bits, the eight bits of C<op_private>, except that 6764 the bit with value 1 is automatically set. C<dynamic_meth> supplies an 6765 op which evaluates method name; it is consumed by this function and 6766 become part of the constructed op tree. 6767 Supported optypes: C<OP_METHOD>. 6768 6769 =cut 6770 */ 6771 6772 static OP* 6773 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) { 6774 dVAR; 6775 METHOP *methop; 6776 6777 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP 6778 || type == OP_CUSTOM); 6779 6780 NewOp(1101, methop, 1, METHOP); 6781 if (dynamic_meth) { 6782 if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1); 6783 methop->op_flags = (U8)(flags | OPf_KIDS); 6784 methop->op_u.op_first = dynamic_meth; 6785 methop->op_private = (U8)(1 | (flags >> 8)); 6786 6787 if (!OpHAS_SIBLING(dynamic_meth)) 6788 OpLASTSIB_set(dynamic_meth, (OP*)methop); 6789 } 6790 else { 6791 assert(const_meth); 6792 methop->op_flags = (U8)(flags & ~OPf_KIDS); 6793 methop->op_u.op_meth_sv = const_meth; 6794 methop->op_private = (U8)(0 | (flags >> 8)); 6795 methop->op_next = (OP*)methop; 6796 } 6797 6798 #ifdef USE_ITHREADS 6799 methop->op_rclass_targ = 0; 6800 #else 6801 methop->op_rclass_sv = NULL; 6802 #endif 6803 6804 OpTYPE_set(methop, type); 6805 return CHECKOP(type, methop); 6806 } 6807 6808 OP * 6809 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) { 6810 PERL_ARGS_ASSERT_NEWMETHOP; 6811 return newMETHOP_internal(type, flags, dynamic_meth, NULL); 6812 } 6813 6814 /* 6815 =for apidoc newMETHOP_named 6816 6817 Constructs, checks, and returns an op of method type with a constant 6818 method name. C<type> is the opcode. C<flags> gives the eight bits of 6819 C<op_flags>, and, shifted up eight bits, the eight bits of 6820 C<op_private>. C<const_meth> supplies a constant method name; 6821 it must be a shared COW string. 6822 Supported optypes: C<OP_METHOD_NAMED>. 6823 6824 =cut 6825 */ 6826 6827 OP * 6828 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) { 6829 PERL_ARGS_ASSERT_NEWMETHOP_NAMED; 6830 return newMETHOP_internal(type, flags, NULL, const_meth); 6831 } 6832 6833 /* 6834 =for apidoc newBINOP 6835 6836 Constructs, checks, and returns an op of any binary type. C<type> 6837 is the opcode. C<flags> gives the eight bits of C<op_flags>, except 6838 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits, 6839 the eight bits of C<op_private>, except that the bit with value 1 or 6840 2 is automatically set as required. C<first> and C<last> supply up to 6841 two ops to be the direct children of the binary op; they are consumed 6842 by this function and become part of the constructed op tree. 6843 6844 =cut 6845 */ 6846 6847 OP * 6848 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) 6849 { 6850 dVAR; 6851 BINOP *binop; 6852 6853 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP 6854 || type == OP_NULL || type == OP_CUSTOM); 6855 6856 NewOp(1101, binop, 1, BINOP); 6857 6858 if (!first) 6859 first = newOP(OP_NULL, 0); 6860 6861 OpTYPE_set(binop, type); 6862 binop->op_first = first; 6863 binop->op_flags = (U8)(flags | OPf_KIDS); 6864 if (!last) { 6865 last = first; 6866 binop->op_private = (U8)(1 | (flags >> 8)); 6867 } 6868 else { 6869 binop->op_private = (U8)(2 | (flags >> 8)); 6870 OpMORESIB_set(first, last); 6871 } 6872 6873 if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */ 6874 OpLASTSIB_set(last, (OP*)binop); 6875 6876 binop->op_last = OpSIBLING(binop->op_first); 6877 if (binop->op_last) 6878 OpLASTSIB_set(binop->op_last, (OP*)binop); 6879 6880 binop = (BINOP*)CHECKOP(type, binop); 6881 if (binop->op_next || binop->op_type != (OPCODE)type) 6882 return (OP*)binop; 6883 6884 return fold_constants(op_integerize(op_std_init((OP *)binop))); 6885 } 6886 6887 void 6888 Perl_invmap_dump(pTHX_ SV* invlist, UV *map) 6889 { 6890 const char indent[] = " "; 6891 6892 UV len = _invlist_len(invlist); 6893 UV * array = invlist_array(invlist); 6894 UV i; 6895 6896 PERL_ARGS_ASSERT_INVMAP_DUMP; 6897 6898 for (i = 0; i < len; i++) { 6899 UV start = array[i]; 6900 UV end = (i + 1 < len) ? array[i+1] - 1 : IV_MAX; 6901 6902 PerlIO_printf(Perl_debug_log, "%s[%" UVuf "] 0x%04" UVXf, indent, i, start); 6903 if (end == IV_MAX) { 6904 PerlIO_printf(Perl_debug_log, " .. INFTY"); 6905 } 6906 else if (end != start) { 6907 PerlIO_printf(Perl_debug_log, " .. 0x%04" UVXf, end); 6908 } 6909 else { 6910 PerlIO_printf(Perl_debug_log, " "); 6911 } 6912 6913 PerlIO_printf(Perl_debug_log, "\t"); 6914 6915 if (map[i] == TR_UNLISTED) { 6916 PerlIO_printf(Perl_debug_log, "TR_UNLISTED\n"); 6917 } 6918 else if (map[i] == TR_SPECIAL_HANDLING) { 6919 PerlIO_printf(Perl_debug_log, "TR_SPECIAL_HANDLING\n"); 6920 } 6921 else { 6922 PerlIO_printf(Perl_debug_log, "0x%04" UVXf "\n", map[i]); 6923 } 6924 } 6925 } 6926 6927 /* Given an OP_TRANS / OP_TRANSR op o, plus OP_CONST ops expr and repl 6928 * containing the search and replacement strings, assemble into 6929 * a translation table attached as o->op_pv. 6930 * Free expr and repl. 6931 * It expects the toker to have already set the 6932 * OPpTRANS_COMPLEMENT 6933 * OPpTRANS_SQUASH 6934 * OPpTRANS_DELETE 6935 * flags as appropriate; this function may add 6936 * OPpTRANS_USE_SVOP 6937 * OPpTRANS_CAN_FORCE_UTF8 6938 * OPpTRANS_IDENTICAL 6939 * OPpTRANS_GROWS 6940 * flags 6941 */ 6942 6943 static OP * 6944 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) 6945 { 6946 /* This function compiles a tr///, from data gathered from toke.c, into a 6947 * form suitable for use by do_trans() in doop.c at runtime. 6948 * 6949 * It first normalizes the data, while discarding extraneous inputs; then 6950 * writes out the compiled data. The normalization allows for complete 6951 * analysis, and avoids some false negatives and positives earlier versions 6952 * of this code had. 6953 * 6954 * The normalization form is an inversion map (described below in detail). 6955 * This is essentially the compiled form for tr///'s that require UTF-8, 6956 * and its easy to use it to write the 257-byte table for tr///'s that 6957 * don't need UTF-8. That table is identical to what's been in use for 6958 * many perl versions, except that it doesn't handle some edge cases that 6959 * it used to, involving code points above 255. The UTF-8 form now handles 6960 * these. (This could be changed with extra coding should it shown to be 6961 * desirable.) 6962 * 6963 * If the complement (/c) option is specified, the lhs string (tstr) is 6964 * parsed into an inversion list. Complementing these is trivial. Then a 6965 * complemented tstr is built from that, and used thenceforth. This hides 6966 * the fact that it was complemented from almost all successive code. 6967 * 6968 * One of the important characteristics to know about the input is whether 6969 * the transliteration may be done in place, or does a temporary need to be 6970 * allocated, then copied. If the replacement for every character in every 6971 * possible string takes up no more bytes than the character it 6972 * replaces, then it can be edited in place. Otherwise the replacement 6973 * could overwrite a byte we are about to read, depending on the strings 6974 * being processed. The comments and variable names here refer to this as 6975 * "growing". Some inputs won't grow, and might even shrink under /d, but 6976 * some inputs could grow, so we have to assume any given one might grow. 6977 * On very long inputs, the temporary could eat up a lot of memory, so we 6978 * want to avoid it if possible. For non-UTF-8 inputs, everything is 6979 * single-byte, so can be edited in place, unless there is something in the 6980 * pattern that could force it into UTF-8. The inversion map makes it 6981 * feasible to determine this. Previous versions of this code pretty much 6982 * punted on determining if UTF-8 could be edited in place. Now, this code 6983 * is rigorous in making that determination. 6984 * 6985 * Another characteristic we need to know is whether the lhs and rhs are 6986 * identical. If so, and no other flags are present, the only effect of 6987 * the tr/// is to count the characters present in the input that are 6988 * mentioned in the lhs string. The implementation of that is easier and 6989 * runs faster than the more general case. Normalizing here allows for 6990 * accurate determination of this. Previously there were false negatives 6991 * possible. 6992 * 6993 * Instead of 'transliterated', the comments here use 'unmapped' for the 6994 * characters that are left unchanged by the operation; otherwise they are 6995 * 'mapped' 6996 * 6997 * The lhs of the tr/// is here referred to as the t side. 6998 * The rhs of the tr/// is here referred to as the r side. 6999 */ 7000 7001 SV * const tstr = ((SVOP*)expr)->op_sv; 7002 SV * const rstr = ((SVOP*)repl)->op_sv; 7003 STRLEN tlen; 7004 STRLEN rlen; 7005 const U8 * t0 = (U8*)SvPV_const(tstr, tlen); 7006 const U8 * r0 = (U8*)SvPV_const(rstr, rlen); 7007 const U8 * t = t0; 7008 const U8 * r = r0; 7009 UV t_count = 0, r_count = 0; /* Number of characters in search and 7010 replacement lists */ 7011 7012 /* khw thinks some of the private flags for this op are quaintly named. 7013 * OPpTRANS_GROWS for example is TRUE if the replacement for some lhs 7014 * character when represented in UTF-8 is longer than the original 7015 * character's UTF-8 representation */ 7016 const bool complement = cBOOL(o->op_private & OPpTRANS_COMPLEMENT); 7017 const bool squash = cBOOL(o->op_private & OPpTRANS_SQUASH); 7018 const bool del = cBOOL(o->op_private & OPpTRANS_DELETE); 7019 7020 /* Set to true if there is some character < 256 in the lhs that maps to 7021 * above 255. If so, a non-UTF-8 match string can be forced into being in 7022 * UTF-8 by a tr/// operation. */ 7023 bool can_force_utf8 = FALSE; 7024 7025 /* What is the maximum expansion factor in UTF-8 transliterations. If a 7026 * 2-byte UTF-8 encoded character is to be replaced by a 3-byte one, its 7027 * expansion factor is 1.5. This number is used at runtime to calculate 7028 * how much space to allocate for non-inplace transliterations. Without 7029 * this number, the worst case is 14, which is extremely unlikely to happen 7030 * in real life, and could require significant memory overhead. */ 7031 NV max_expansion = 1.; 7032 7033 UV t_range_count, r_range_count, min_range_count; 7034 UV* t_array; 7035 SV* t_invlist; 7036 UV* r_map; 7037 UV r_cp, t_cp; 7038 UV t_cp_end = (UV) -1; 7039 UV r_cp_end; 7040 Size_t len; 7041 AV* invmap; 7042 UV final_map = TR_UNLISTED; /* The final character in the replacement 7043 list, updated as we go along. Initialize 7044 to something illegal */ 7045 7046 bool rstr_utf8 = cBOOL(SvUTF8(rstr)); 7047 bool tstr_utf8 = cBOOL(SvUTF8(tstr)); 7048 7049 const U8* tend = t + tlen; 7050 const U8* rend = r + rlen; 7051 7052 SV * inverted_tstr = NULL; 7053 7054 Size_t i; 7055 unsigned int pass2; 7056 7057 /* This routine implements detection of a transliteration having a longer 7058 * UTF-8 representation than its source, by partitioning all the possible 7059 * code points of the platform into equivalence classes of the same UTF-8 7060 * byte length in the first pass. As it constructs the mappings, it carves 7061 * these up into smaller chunks, but doesn't merge any together. This 7062 * makes it easy to find the instances it's looking for. A second pass is 7063 * done after this has been determined which merges things together to 7064 * shrink the table for runtime. The table below is used for both ASCII 7065 * and EBCDIC platforms. On EBCDIC, the byte length is not monotonically 7066 * increasing for code points below 256. To correct for that, the macro 7067 * CP_ADJUST defined below converts those code points to ASCII in the first 7068 * pass, and we use the ASCII partition values. That works because the 7069 * growth factor will be unaffected, which is all that is calculated during 7070 * the first pass. */ 7071 UV PL_partition_by_byte_length[] = { 7072 0, 7073 0x80, /* Below this is 1 byte representations */ 7074 (32 * (1UL << ( UTF_ACCUMULATION_SHIFT))), /* 2 bytes below this */ 7075 (16 * (1UL << (2 * UTF_ACCUMULATION_SHIFT))), /* 3 bytes below this */ 7076 ( 8 * (1UL << (3 * UTF_ACCUMULATION_SHIFT))), /* 4 bytes below this */ 7077 ( 4 * (1UL << (4 * UTF_ACCUMULATION_SHIFT))), /* 5 bytes below this */ 7078 ( 2 * (1UL << (5 * UTF_ACCUMULATION_SHIFT))) /* 6 bytes below this */ 7079 7080 # ifdef UV_IS_QUAD 7081 , 7082 ( ((UV) 1U << (6 * UTF_ACCUMULATION_SHIFT))) /* 7 bytes below this */ 7083 # endif 7084 7085 }; 7086 7087 PERL_ARGS_ASSERT_PMTRANS; 7088 7089 PL_hints |= HINT_BLOCK_SCOPE; 7090 7091 /* If /c, the search list is sorted and complemented. This is now done by 7092 * creating an inversion list from it, and then trivially inverting that. 7093 * The previous implementation used qsort, but creating the list 7094 * automatically keeps it sorted as we go along */ 7095 if (complement) { 7096 UV start, end; 7097 SV * inverted_tlist = _new_invlist(tlen); 7098 Size_t temp_len; 7099 7100 DEBUG_y(PerlIO_printf(Perl_debug_log, 7101 "%s: %d: tstr before inversion=\n%s\n", 7102 __FILE__, __LINE__, _byte_dump_string(t, tend - t, 0))); 7103 7104 while (t < tend) { 7105 7106 /* Non-utf8 strings don't have ranges, so each character is listed 7107 * out */ 7108 if (! tstr_utf8) { 7109 inverted_tlist = add_cp_to_invlist(inverted_tlist, *t); 7110 t++; 7111 } 7112 else { /* But UTF-8 strings have been parsed in toke.c to have 7113 * ranges if appropriate. */ 7114 UV t_cp; 7115 Size_t t_char_len; 7116 7117 /* Get the first character */ 7118 t_cp = valid_utf8_to_uvchr(t, &t_char_len); 7119 t += t_char_len; 7120 7121 /* If the next byte indicates that this wasn't the first 7122 * element of a range, the range is just this one */ 7123 if (t >= tend || *t != RANGE_INDICATOR) { 7124 inverted_tlist = add_cp_to_invlist(inverted_tlist, t_cp); 7125 } 7126 else { /* Otherwise, ignore the indicator byte, and get the 7127 final element, and add the whole range */ 7128 t++; 7129 t_cp_end = valid_utf8_to_uvchr(t, &t_char_len); 7130 t += t_char_len; 7131 7132 inverted_tlist = _add_range_to_invlist(inverted_tlist, 7133 t_cp, t_cp_end); 7134 } 7135 } 7136 } /* End of parse through tstr */ 7137 7138 /* The inversion list is done; now invert it */ 7139 _invlist_invert(inverted_tlist); 7140 7141 /* Now go through the inverted list and create a new tstr for the rest 7142 * of the routine to use. Since the UTF-8 version can have ranges, and 7143 * can be much more compact than the non-UTF-8 version, we create the 7144 * string in UTF-8 even if not necessary. (This is just an intermediate 7145 * value that gets thrown away anyway.) */ 7146 invlist_iterinit(inverted_tlist); 7147 inverted_tstr = newSVpvs(""); 7148 while (invlist_iternext(inverted_tlist, &start, &end)) { 7149 U8 temp[UTF8_MAXBYTES]; 7150 U8 * temp_end_pos; 7151 7152 /* IV_MAX keeps things from going out of bounds */ 7153 start = MIN(IV_MAX, start); 7154 end = MIN(IV_MAX, end); 7155 7156 temp_end_pos = uvchr_to_utf8(temp, start); 7157 sv_catpvn(inverted_tstr, (char *) temp, temp_end_pos - temp); 7158 7159 if (start != end) { 7160 Perl_sv_catpvf(aTHX_ inverted_tstr, "%c", RANGE_INDICATOR); 7161 temp_end_pos = uvchr_to_utf8(temp, end); 7162 sv_catpvn(inverted_tstr, (char *) temp, temp_end_pos - temp); 7163 } 7164 } 7165 7166 /* Set up so the remainder of the routine uses this complement, instead 7167 * of the actual input */ 7168 t0 = t = (U8*)SvPV_const(inverted_tstr, temp_len); 7169 tend = t0 + temp_len; 7170 tstr_utf8 = TRUE; 7171 7172 SvREFCNT_dec_NN(inverted_tlist); 7173 } 7174 7175 /* For non-/d, an empty rhs means to use the lhs */ 7176 if (rlen == 0 && ! del) { 7177 r0 = t0; 7178 rend = tend; 7179 rstr_utf8 = tstr_utf8; 7180 } 7181 7182 t_invlist = _new_invlist(1); 7183 7184 /* Initialize to a single range */ 7185 t_invlist = _add_range_to_invlist(t_invlist, 0, UV_MAX); 7186 7187 /* For the first pass, the lhs is partitioned such that the 7188 * number of UTF-8 bytes required to represent a code point in each 7189 * partition is the same as the number for any other code point in 7190 * that partion. We copy the pre-compiled partion. */ 7191 len = C_ARRAY_LENGTH(PL_partition_by_byte_length); 7192 invlist_extend(t_invlist, len); 7193 t_array = invlist_array(t_invlist); 7194 Copy(PL_partition_by_byte_length, t_array, len, UV); 7195 invlist_set_len(t_invlist, len, *(get_invlist_offset_addr(t_invlist))); 7196 Newx(r_map, len + 1, UV); 7197 7198 /* Parse the (potentially adjusted) input, creating the inversion map. 7199 * This is done in two passes. The first pass is to determine if the 7200 * transliteration can be done in place. The inversion map it creates 7201 * could be used, but generally would be larger and slower to run than the 7202 * output of the second pass, which starts with a more compact table and 7203 * allows more ranges to be merged */ 7204 for (pass2 = 0; pass2 < 2; pass2++) { 7205 if (pass2) { 7206 /* Initialize to a single range */ 7207 t_invlist = _add_range_to_invlist(t_invlist, 0, UV_MAX); 7208 7209 /* In the second pass, we just have the single range */ 7210 len = 1; 7211 t_array = invlist_array(t_invlist); 7212 } 7213 7214 /* As noted earlier, we convert EBCDIC code points to Unicode in the first pass 7215 * so as to get the well-behaved length 1 vs length 2 boundary. Only code 7216 * points below 256 differ between the two character sets in this regard. For 7217 * these, we also can't have any ranges, as they have to be individually 7218 * converted. */ 7219 #ifdef EBCDIC 7220 # define CP_ADJUST(x) ((pass2) ? (x) : NATIVE_TO_UNI(x)) 7221 # define FORCE_RANGE_LEN_1(x) ((pass2) ? 0 : ((x) < 256)) 7222 # define CP_SKIP(x) ((pass2) ? UVCHR_SKIP(x) : OFFUNISKIP(x)) 7223 #else 7224 # define CP_ADJUST(x) (x) 7225 # define FORCE_RANGE_LEN_1(x) 0 7226 # define CP_SKIP(x) UVCHR_SKIP(x) 7227 #endif 7228 7229 /* And the mapping of each of the ranges is initialized. Initially, 7230 * everything is TR_UNLISTED. */ 7231 for (i = 0; i < len; i++) { 7232 r_map[i] = TR_UNLISTED; 7233 } 7234 7235 t = t0; 7236 t_count = 0; 7237 r = r0; 7238 r_count = 0; 7239 t_range_count = r_range_count = 0; 7240 7241 DEBUG_y(PerlIO_printf(Perl_debug_log, "%s: %d:\ntstr=%s\n", 7242 __FILE__, __LINE__, _byte_dump_string(t, tend - t, 0))); 7243 DEBUG_y(PerlIO_printf(Perl_debug_log, "rstr=%s\n", 7244 _byte_dump_string(r, rend - r, 0))); 7245 DEBUG_y(PerlIO_printf(Perl_debug_log, "/c=%d; /s=%d; /d=%d\n", 7246 complement, squash, del)); 7247 DEBUG_y(invmap_dump(t_invlist, r_map)); 7248 7249 /* Now go through the search list constructing an inversion map. The 7250 * input is not necessarily in any particular order. Making it an 7251 * inversion map orders it, potentially simplifying, and makes it easy 7252 * to deal with at run time. This is the only place in core that 7253 * generates an inversion map; if others were introduced, it might be 7254 * better to create general purpose routines to handle them. 7255 * (Inversion maps are created in perl in other places.) 7256 * 7257 * An inversion map consists of two parallel arrays. One is 7258 * essentially an inversion list: an ordered list of code points such 7259 * that each element gives the first code point of a range of 7260 * consecutive code points that map to the element in the other array 7261 * that has the same index as this one (in other words, the 7262 * corresponding element). Thus the range extends up to (but not 7263 * including) the code point given by the next higher element. In a 7264 * true inversion map, the corresponding element in the other array 7265 * gives the mapping of the first code point in the range, with the 7266 * understanding that the next higher code point in the inversion 7267 * list's range will map to the next higher code point in the map. 7268 * 7269 * So if at element [i], let's say we have: 7270 * 7271 * t_invlist r_map 7272 * [i] A a 7273 * 7274 * This means that A => a, B => b, C => c.... Let's say that the 7275 * situation is such that: 7276 * 7277 * [i+1] L -1 7278 * 7279 * This means the sequence that started at [i] stops at K => k. This 7280 * illustrates that you need to look at the next element to find where 7281 * a sequence stops. Except, the highest element in the inversion list 7282 * begins a range that is understood to extend to the platform's 7283 * infinity. 7284 * 7285 * This routine modifies traditional inversion maps to reserve two 7286 * mappings: 7287 * 7288 * TR_UNLISTED (or -1) indicates that no code point in the range 7289 * is listed in the tr/// searchlist. At runtime, these are 7290 * always passed through unchanged. In the inversion map, all 7291 * points in the range are mapped to -1, instead of increasing, 7292 * like the 'L' in the example above. 7293 * 7294 * We start the parse with every code point mapped to this, and as 7295 * we parse and find ones that are listed in the search list, we 7296 * carve out ranges as we go along that override that. 7297 * 7298 * TR_SPECIAL_HANDLING (or -2) indicates that every code point in the 7299 * range needs special handling. Again, all code points in the 7300 * range are mapped to -2, instead of increasing. 7301 * 7302 * Under /d this value means the code point should be deleted from 7303 * the transliteration when encountered. 7304 * 7305 * Otherwise, it marks that every code point in the range is to 7306 * map to the final character in the replacement list. This 7307 * happens only when the replacement list is shorter than the 7308 * search one, so there are things in the search list that have no 7309 * correspondence in the replacement list. For example, in 7310 * tr/a-z/A/, 'A' is the final value, and the inversion map 7311 * generated for this would be like this: 7312 * \0 => -1 7313 * a => A 7314 * b-z => -2 7315 * z+1 => -1 7316 * 'A' appears once, then the remainder of the range maps to -2. 7317 * The use of -2 isn't strictly necessary, as an inversion map is 7318 * capable of representing this situation, but not nearly so 7319 * compactly, and this is actually quite commonly encountered. 7320 * Indeed, the original design of this code used a full inversion 7321 * map for this. But things like 7322 * tr/\0-\x{FFFF}/A/ 7323 * generated huge data structures, slowly, and the execution was 7324 * also slow. So the current scheme was implemented. 7325 * 7326 * So, if the next element in our example is: 7327 * 7328 * [i+2] Q q 7329 * 7330 * Then all of L, M, N, O, and P map to TR_UNLISTED. If the next 7331 * elements are 7332 * 7333 * [i+3] R z 7334 * [i+4] S TR_UNLISTED 7335 * 7336 * Then Q => q; R => z; and S => TR_UNLISTED. If [i+4] (the 'S') is 7337 * the final element in the arrays, every code point from S to infinity 7338 * maps to TR_UNLISTED. 7339 * 7340 */ 7341 /* Finish up range started in what otherwise would 7342 * have been the final iteration */ 7343 while (t < tend || t_range_count > 0) { 7344 bool adjacent_to_range_above = FALSE; 7345 bool adjacent_to_range_below = FALSE; 7346 7347 bool merge_with_range_above = FALSE; 7348 bool merge_with_range_below = FALSE; 7349 7350 UV span, invmap_range_length_remaining; 7351 SSize_t j; 7352 Size_t i; 7353 7354 /* If we are in the middle of processing a range in the 'target' 7355 * side, the previous iteration has set us up. Otherwise, look at 7356 * the next character in the search list */ 7357 if (t_range_count <= 0) { 7358 if (! tstr_utf8) { 7359 7360 /* Here, not in the middle of a range, and not UTF-8. The 7361 * next code point is the single byte where we're at */ 7362 t_cp = CP_ADJUST(*t); 7363 t_range_count = 1; 7364 t++; 7365 } 7366 else { 7367 Size_t t_char_len; 7368 7369 /* Here, not in the middle of a range, and is UTF-8. The 7370 * next code point is the next UTF-8 char in the input. We 7371 * know the input is valid, because the toker constructed 7372 * it */ 7373 t_cp = CP_ADJUST(valid_utf8_to_uvchr(t, &t_char_len)); 7374 t += t_char_len; 7375 7376 /* UTF-8 strings (only) have been parsed in toke.c to have 7377 * ranges. See if the next byte indicates that this was 7378 * the first element of a range. If so, get the final 7379 * element and calculate the range size. If not, the range 7380 * size is 1 */ 7381 if ( t < tend && *t == RANGE_INDICATOR 7382 && ! FORCE_RANGE_LEN_1(t_cp)) 7383 { 7384 t++; 7385 t_range_count = valid_utf8_to_uvchr(t, &t_char_len) 7386 - t_cp + 1; 7387 t += t_char_len; 7388 } 7389 else { 7390 t_range_count = 1; 7391 } 7392 } 7393 7394 /* Count the total number of listed code points * */ 7395 t_count += t_range_count; 7396 } 7397 7398 /* Similarly, get the next character in the replacement list */ 7399 if (r_range_count <= 0) { 7400 if (r >= rend) { 7401 7402 /* But if we've exhausted the rhs, there is nothing to map 7403 * to, except the special handling one, and we make the 7404 * range the same size as the lhs one. */ 7405 r_cp = TR_SPECIAL_HANDLING; 7406 r_range_count = t_range_count; 7407 7408 if (! del) { 7409 DEBUG_yv(PerlIO_printf(Perl_debug_log, 7410 "final_map =%" UVXf "\n", final_map)); 7411 } 7412 } 7413 else { 7414 if (! rstr_utf8) { 7415 r_cp = CP_ADJUST(*r); 7416 r_range_count = 1; 7417 r++; 7418 } 7419 else { 7420 Size_t r_char_len; 7421 7422 r_cp = CP_ADJUST(valid_utf8_to_uvchr(r, &r_char_len)); 7423 r += r_char_len; 7424 if ( r < rend && *r == RANGE_INDICATOR 7425 && ! FORCE_RANGE_LEN_1(r_cp)) 7426 { 7427 r++; 7428 r_range_count = valid_utf8_to_uvchr(r, 7429 &r_char_len) - r_cp + 1; 7430 r += r_char_len; 7431 } 7432 else { 7433 r_range_count = 1; 7434 } 7435 } 7436 7437 if (r_cp == TR_SPECIAL_HANDLING) { 7438 r_range_count = t_range_count; 7439 } 7440 7441 /* This is the final character so far */ 7442 final_map = r_cp + r_range_count - 1; 7443 7444 r_count += r_range_count; 7445 } 7446 } 7447 7448 /* Here, we have the next things ready in both sides. They are 7449 * potentially ranges. We try to process as big a chunk as 7450 * possible at once, but the lhs and rhs must be synchronized, so 7451 * things like tr/A-Z/a-ij-z/ will need to be processed in 2 chunks 7452 * */ 7453 min_range_count = MIN(t_range_count, r_range_count); 7454 7455 /* Search the inversion list for the entry that contains the input 7456 * code point <cp>. The inversion map was initialized to cover the 7457 * entire range of possible inputs, so this should not fail. So 7458 * the return value is the index into the list's array of the range 7459 * that contains <cp>, that is, 'i' such that array[i] <= cp < 7460 * array[i+1] */ 7461 j = _invlist_search(t_invlist, t_cp); 7462 assert(j >= 0); 7463 i = j; 7464 7465 /* Here, the data structure might look like: 7466 * 7467 * index t r Meaning 7468 * [i-1] J j # J-L => j-l 7469 * [i] M -1 # M => default; as do N, O, P, Q 7470 * [i+1] R x # R => x, S => x+1, T => x+2 7471 * [i+2] U y # U => y, V => y+1, ... 7472 * ... 7473 * [-1] Z -1 # Z => default; as do Z+1, ... infinity 7474 * 7475 * where 'x' and 'y' above are not to be taken literally. 7476 * 7477 * The maximum chunk we can handle in this loop iteration, is the 7478 * smallest of the three components: the lhs 't_', the rhs 'r_', 7479 * and the remainder of the range in element [i]. (In pass 1, that 7480 * range will have everything in it be of the same class; we can't 7481 * cross into another class.) 'min_range_count' already contains 7482 * the smallest of the first two values. The final one is 7483 * irrelevant if the map is to the special indicator */ 7484 7485 invmap_range_length_remaining = (i + 1 < len) 7486 ? t_array[i+1] - t_cp 7487 : IV_MAX - t_cp; 7488 span = MAX(1, MIN(min_range_count, invmap_range_length_remaining)); 7489 7490 /* The end point of this chunk is where we are, plus the span, but 7491 * never larger than the platform's infinity */ 7492 t_cp_end = MIN(IV_MAX, t_cp + span - 1); 7493 7494 if (r_cp == TR_SPECIAL_HANDLING) { 7495 7496 /* If unmatched lhs code points map to the final map, use that 7497 * value. This being set to TR_SPECIAL_HANDLING indicates that 7498 * we don't have a final map: unmatched lhs code points are 7499 * simply deleted */ 7500 r_cp_end = (del) ? TR_SPECIAL_HANDLING : final_map; 7501 } 7502 else { 7503 r_cp_end = MIN(IV_MAX, r_cp + span - 1); 7504 7505 /* If something on the lhs is below 256, and something on the 7506 * rhs is above, there is a potential mapping here across that 7507 * boundary. Indeed the only way there isn't is if both sides 7508 * start at the same point. That means they both cross at the 7509 * same time. But otherwise one crosses before the other */ 7510 if (t_cp < 256 && r_cp_end > 255 && r_cp != t_cp) { 7511 can_force_utf8 = TRUE; 7512 } 7513 } 7514 7515 /* If a character appears in the search list more than once, the 7516 * 2nd and succeeding occurrences are ignored, so only do this 7517 * range if haven't already processed this character. (The range 7518 * has been set up so that all members in it will be of the same 7519 * ilk) */ 7520 if (r_map[i] == TR_UNLISTED) { 7521 DEBUG_yv(PerlIO_printf(Perl_debug_log, 7522 "Processing %" UVxf "-%" UVxf " => %" UVxf "-%" UVxf "\n", 7523 t_cp, t_cp_end, r_cp, r_cp_end)); 7524 7525 /* This is the first definition for this chunk, hence is valid 7526 * and needs to be processed. Here and in the comments below, 7527 * we use the above sample data. The t_cp chunk must be any 7528 * contiguous subset of M, N, O, P, and/or Q. 7529 * 7530 * In the first pass, calculate if there is any possible input 7531 * string that has a character whose transliteration will be 7532 * longer than it. If none, the transliteration may be done 7533 * in-place, as it can't write over a so-far unread byte. 7534 * Otherwise, a copy must first be made. This could be 7535 * expensive for long inputs. 7536 * 7537 * In the first pass, the t_invlist has been partitioned so 7538 * that all elements in any single range have the same number 7539 * of bytes in their UTF-8 representations. And the r space is 7540 * either a single byte, or a range of strictly monotonically 7541 * increasing code points. So the final element in the range 7542 * will be represented by no fewer bytes than the initial one. 7543 * That means that if the final code point in the t range has 7544 * at least as many bytes as the final code point in the r, 7545 * then all code points in the t range have at least as many 7546 * bytes as their corresponding r range element. But if that's 7547 * not true, the transliteration of at least the final code 7548 * point grows in length. As an example, suppose we had 7549 * tr/\x{fff0}-\x{fff1}/\x{ffff}-\x{10000}/ 7550 * The UTF-8 for all but 10000 occupies 3 bytes on ASCII 7551 * platforms. We have deliberately set up the data structure 7552 * so that any range in the lhs gets split into chunks for 7553 * processing, such that every code point in a chunk has the 7554 * same number of UTF-8 bytes. We only have to check the final 7555 * code point in the rhs against any code point in the lhs. */ 7556 if ( ! pass2 7557 && r_cp_end != TR_SPECIAL_HANDLING 7558 && CP_SKIP(t_cp_end) < CP_SKIP(r_cp_end)) 7559 { 7560 /* Here, we will need to make a copy of the input string 7561 * before doing the transliteration. The worst possible 7562 * case is an expansion ratio of 14:1. This is rare, and 7563 * we'd rather allocate only the necessary amount of extra 7564 * memory for that copy. We can calculate the worst case 7565 * for this particular transliteration is by keeping track 7566 * of the expansion factor for each range. 7567 * 7568 * Consider tr/\xCB/\X{E000}/. The maximum expansion 7569 * factor is 1 byte going to 3 if the target string is not 7570 * UTF-8, but 2 bytes going to 3 if it is in UTF-8. We 7571 * could pass two different values so doop could choose 7572 * based on the UTF-8ness of the target. But khw thinks 7573 * (perhaps wrongly) that is overkill. It is used only to 7574 * make sure we malloc enough space. 7575 * 7576 * If no target string can force the result to be UTF-8, 7577 * then we don't have to worry about the case of the target 7578 * string not being UTF-8 */ 7579 NV t_size = (can_force_utf8 && t_cp < 256) 7580 ? 1 7581 : CP_SKIP(t_cp_end); 7582 NV ratio = CP_SKIP(r_cp_end) / t_size; 7583 7584 o->op_private |= OPpTRANS_GROWS; 7585 7586 /* Now that we know it grows, we can keep track of the 7587 * largest ratio */ 7588 if (ratio > max_expansion) { 7589 max_expansion = ratio; 7590 DEBUG_y(PerlIO_printf(Perl_debug_log, 7591 "New expansion factor: %" NVgf "\n", 7592 max_expansion)); 7593 } 7594 } 7595 7596 /* The very first range is marked as adjacent to the 7597 * non-existent range below it, as it causes things to "just 7598 * work" (TradeMark) 7599 * 7600 * If the lowest code point in this chunk is M, it adjoins the 7601 * J-L range */ 7602 if (t_cp == t_array[i]) { 7603 adjacent_to_range_below = TRUE; 7604 7605 /* And if the map has the same offset from the beginning of 7606 * the range as does this new code point (or both are for 7607 * TR_SPECIAL_HANDLING), this chunk can be completely 7608 * merged with the range below. EXCEPT, in the first pass, 7609 * we don't merge ranges whose UTF-8 byte representations 7610 * have different lengths, so that we can more easily 7611 * detect if a replacement is longer than the source, that 7612 * is if it 'grows'. But in the 2nd pass, there's no 7613 * reason to not merge */ 7614 if ( (i > 0 && ( pass2 7615 || CP_SKIP(t_array[i-1]) 7616 == CP_SKIP(t_cp))) 7617 && ( ( r_cp == TR_SPECIAL_HANDLING 7618 && r_map[i-1] == TR_SPECIAL_HANDLING) 7619 || ( r_cp != TR_SPECIAL_HANDLING 7620 && r_cp - r_map[i-1] == t_cp - t_array[i-1]))) 7621 { 7622 merge_with_range_below = TRUE; 7623 } 7624 } 7625 7626 /* Similarly, if the highest code point in this chunk is 'Q', 7627 * it adjoins the range above, and if the map is suitable, can 7628 * be merged with it */ 7629 if ( t_cp_end >= IV_MAX - 1 7630 || ( i + 1 < len 7631 && t_cp_end + 1 == t_array[i+1])) 7632 { 7633 adjacent_to_range_above = TRUE; 7634 if (i + 1 < len) 7635 if ( ( pass2 7636 || CP_SKIP(t_cp) == CP_SKIP(t_array[i+1])) 7637 && ( ( r_cp == TR_SPECIAL_HANDLING 7638 && r_map[i+1] == (UV) TR_SPECIAL_HANDLING) 7639 || ( r_cp != TR_SPECIAL_HANDLING 7640 && r_cp_end == r_map[i+1] - 1))) 7641 { 7642 merge_with_range_above = TRUE; 7643 } 7644 } 7645 7646 if (merge_with_range_below && merge_with_range_above) { 7647 7648 /* Here the new chunk looks like M => m, ... Q => q; and 7649 * the range above is like R => r, .... Thus, the [i-1] 7650 * and [i+1] ranges should be seamlessly melded so the 7651 * result looks like 7652 * 7653 * [i-1] J j # J-T => j-t 7654 * [i] U y # U => y, V => y+1, ... 7655 * ... 7656 * [-1] Z -1 # Z => default; as do Z+1, ... infinity 7657 */ 7658 Move(t_array + i + 2, t_array + i, len - i - 2, UV); 7659 Move(r_map + i + 2, r_map + i, len - i - 2, UV); 7660 len -= 2; 7661 invlist_set_len(t_invlist, 7662 len, 7663 *(get_invlist_offset_addr(t_invlist))); 7664 } 7665 else if (merge_with_range_below) { 7666 7667 /* Here the new chunk looks like M => m, .... But either 7668 * (or both) it doesn't extend all the way up through Q; or 7669 * the range above doesn't start with R => r. */ 7670 if (! adjacent_to_range_above) { 7671 7672 /* In the first case, let's say the new chunk extends 7673 * through O. We then want: 7674 * 7675 * [i-1] J j # J-O => j-o 7676 * [i] P -1 # P => -1, Q => -1 7677 * [i+1] R x # R => x, S => x+1, T => x+2 7678 * [i+2] U y # U => y, V => y+1, ... 7679 * ... 7680 * [-1] Z -1 # Z => default; as do Z+1, ... 7681 * infinity 7682 */ 7683 t_array[i] = t_cp_end + 1; 7684 r_map[i] = TR_UNLISTED; 7685 } 7686 else { /* Adjoins the range above, but can't merge with it 7687 (because 'x' is not the next map after q) */ 7688 /* 7689 * [i-1] J j # J-Q => j-q 7690 * [i] R x # R => x, S => x+1, T => x+2 7691 * [i+1] U y # U => y, V => y+1, ... 7692 * ... 7693 * [-1] Z -1 # Z => default; as do Z+1, ... 7694 * infinity 7695 */ 7696 7697 Move(t_array + i + 1, t_array + i, len - i - 1, UV); 7698 Move(r_map + i + 1, r_map + i, len - i - 1, UV); 7699 len--; 7700 invlist_set_len(t_invlist, len, 7701 *(get_invlist_offset_addr(t_invlist))); 7702 } 7703 } 7704 else if (merge_with_range_above) { 7705 7706 /* Here the new chunk ends with Q => q, and the range above 7707 * must start with R => r, so the two can be merged. But 7708 * either (or both) the new chunk doesn't extend all the 7709 * way down to M; or the mapping of the final code point 7710 * range below isn't m */ 7711 if (! adjacent_to_range_below) { 7712 7713 /* In the first case, let's assume the new chunk starts 7714 * with P => p. Then, because it's merge-able with the 7715 * range above, that range must be R => r. We want: 7716 * 7717 * [i-1] J j # J-L => j-l 7718 * [i] M -1 # M => -1, N => -1 7719 * [i+1] P p # P-T => p-t 7720 * [i+2] U y # U => y, V => y+1, ... 7721 * ... 7722 * [-1] Z -1 # Z => default; as do Z+1, ... 7723 * infinity 7724 */ 7725 t_array[i+1] = t_cp; 7726 r_map[i+1] = r_cp; 7727 } 7728 else { /* Adjoins the range below, but can't merge with it 7729 */ 7730 /* 7731 * [i-1] J j # J-L => j-l 7732 * [i] M x # M-T => x-5 .. x+2 7733 * [i+1] U y # U => y, V => y+1, ... 7734 * ... 7735 * [-1] Z -1 # Z => default; as do Z+1, ... 7736 * infinity 7737 */ 7738 Move(t_array + i + 1, t_array + i, len - i - 1, UV); 7739 Move(r_map + i + 1, r_map + i, len - i - 1, UV); 7740 len--; 7741 t_array[i] = t_cp; 7742 r_map[i] = r_cp; 7743 invlist_set_len(t_invlist, len, 7744 *(get_invlist_offset_addr(t_invlist))); 7745 } 7746 } 7747 else if (adjacent_to_range_below && adjacent_to_range_above) { 7748 /* The new chunk completely fills the gap between the 7749 * ranges on either side, but can't merge with either of 7750 * them. 7751 * 7752 * [i-1] J j # J-L => j-l 7753 * [i] M z # M => z, N => z+1 ... Q => z+4 7754 * [i+1] R x # R => x, S => x+1, T => x+2 7755 * [i+2] U y # U => y, V => y+1, ... 7756 * ... 7757 * [-1] Z -1 # Z => default; as do Z+1, ... infinity 7758 */ 7759 r_map[i] = r_cp; 7760 } 7761 else if (adjacent_to_range_below) { 7762 /* The new chunk adjoins the range below, but not the range 7763 * above, and can't merge. Let's assume the chunk ends at 7764 * O. 7765 * 7766 * [i-1] J j # J-L => j-l 7767 * [i] M z # M => z, N => z+1, O => z+2 7768 * [i+1] P -1 # P => -1, Q => -1 7769 * [i+2] R x # R => x, S => x+1, T => x+2 7770 * [i+3] U y # U => y, V => y+1, ... 7771 * ... 7772 * [-w] Z -1 # Z => default; as do Z+1, ... infinity 7773 */ 7774 invlist_extend(t_invlist, len + 1); 7775 t_array = invlist_array(t_invlist); 7776 Renew(r_map, len + 1, UV); 7777 7778 Move(t_array + i + 1, t_array + i + 2, len - i - 1, UV); 7779 Move(r_map + i + 1, r_map + i + 2, len - i - 1, UV); 7780 r_map[i] = r_cp; 7781 t_array[i+1] = t_cp_end + 1; 7782 r_map[i+1] = TR_UNLISTED; 7783 len++; 7784 invlist_set_len(t_invlist, len, 7785 *(get_invlist_offset_addr(t_invlist))); 7786 } 7787 else if (adjacent_to_range_above) { 7788 /* The new chunk adjoins the range above, but not the range 7789 * below, and can't merge. Let's assume the new chunk 7790 * starts at O 7791 * 7792 * [i-1] J j # J-L => j-l 7793 * [i] M -1 # M => default, N => default 7794 * [i+1] O z # O => z, P => z+1, Q => z+2 7795 * [i+2] R x # R => x, S => x+1, T => x+2 7796 * [i+3] U y # U => y, V => y+1, ... 7797 * ... 7798 * [-1] Z -1 # Z => default; as do Z+1, ... infinity 7799 */ 7800 invlist_extend(t_invlist, len + 1); 7801 t_array = invlist_array(t_invlist); 7802 Renew(r_map, len + 1, UV); 7803 7804 Move(t_array + i + 1, t_array + i + 2, len - i - 1, UV); 7805 Move(r_map + i + 1, r_map + i + 2, len - i - 1, UV); 7806 t_array[i+1] = t_cp; 7807 r_map[i+1] = r_cp; 7808 len++; 7809 invlist_set_len(t_invlist, len, 7810 *(get_invlist_offset_addr(t_invlist))); 7811 } 7812 else { 7813 /* The new chunk adjoins neither the range above, nor the 7814 * range below. Lets assume it is N..P => n..p 7815 * 7816 * [i-1] J j # J-L => j-l 7817 * [i] M -1 # M => default 7818 * [i+1] N n # N..P => n..p 7819 * [i+2] Q -1 # Q => default 7820 * [i+3] R x # R => x, S => x+1, T => x+2 7821 * [i+4] U y # U => y, V => y+1, ... 7822 * ... 7823 * [-1] Z -1 # Z => default; as do Z+1, ... infinity 7824 */ 7825 7826 DEBUG_yv(PerlIO_printf(Perl_debug_log, 7827 "Before fixing up: len=%d, i=%d\n", 7828 (int) len, (int) i)); 7829 DEBUG_yv(invmap_dump(t_invlist, r_map)); 7830 7831 invlist_extend(t_invlist, len + 2); 7832 t_array = invlist_array(t_invlist); 7833 Renew(r_map, len + 2, UV); 7834 7835 Move(t_array + i + 1, 7836 t_array + i + 2 + 1, len - i - (2 - 1), UV); 7837 Move(r_map + i + 1, 7838 r_map + i + 2 + 1, len - i - (2 - 1), UV); 7839 7840 len += 2; 7841 invlist_set_len(t_invlist, len, 7842 *(get_invlist_offset_addr(t_invlist))); 7843 7844 t_array[i+1] = t_cp; 7845 r_map[i+1] = r_cp; 7846 7847 t_array[i+2] = t_cp_end + 1; 7848 r_map[i+2] = TR_UNLISTED; 7849 } 7850 DEBUG_yv(PerlIO_printf(Perl_debug_log, 7851 "After iteration: span=%" UVuf ", t_range_count=%" 7852 UVuf " r_range_count=%" UVuf "\n", 7853 span, t_range_count, r_range_count)); 7854 DEBUG_yv(invmap_dump(t_invlist, r_map)); 7855 } /* End of this chunk needs to be processed */ 7856 7857 /* Done with this chunk. */ 7858 t_cp += span; 7859 if (t_cp >= IV_MAX) { 7860 break; 7861 } 7862 t_range_count -= span; 7863 if (r_cp != TR_SPECIAL_HANDLING) { 7864 r_cp += span; 7865 r_range_count -= span; 7866 } 7867 else { 7868 r_range_count = 0; 7869 } 7870 7871 } /* End of loop through the search list */ 7872 7873 /* We don't need an exact count, but we do need to know if there is 7874 * anything left over in the replacement list. So, just assume it's 7875 * one byte per character */ 7876 if (rend > r) { 7877 r_count++; 7878 } 7879 } /* End of passes */ 7880 7881 SvREFCNT_dec(inverted_tstr); 7882 7883 DEBUG_y(PerlIO_printf(Perl_debug_log, "After everything: \n")); 7884 DEBUG_y(invmap_dump(t_invlist, r_map)); 7885 7886 /* We now have normalized the input into an inversion map. 7887 * 7888 * See if the lhs and rhs are equivalent. If so, this tr/// is a no-op 7889 * except for the count, and streamlined runtime code can be used */ 7890 if (!del && !squash) { 7891 7892 /* They are identical if they point to same address, or if everything 7893 * maps to UNLISTED or to itself. This catches things that not looking 7894 * at the normalized inversion map doesn't catch, like tr/aa/ab/ or 7895 * tr/\x{100}-\x{104}/\x{100}-\x{102}\x{103}-\x{104} */ 7896 if (r0 != t0) { 7897 for (i = 0; i < len; i++) { 7898 if (r_map[i] != TR_UNLISTED && r_map[i] != t_array[i]) { 7899 goto done_identical_check; 7900 } 7901 } 7902 } 7903 7904 /* Here have gone through entire list, and didn't find any 7905 * non-identical mappings */ 7906 o->op_private |= OPpTRANS_IDENTICAL; 7907 7908 done_identical_check: ; 7909 } 7910 7911 t_array = invlist_array(t_invlist); 7912 7913 /* If has components above 255, we generally need to use the inversion map 7914 * implementation */ 7915 if ( can_force_utf8 7916 || ( len > 0 7917 && t_array[len-1] > 255 7918 /* If the final range is 0x100-INFINITY and is a special 7919 * mapping, the table implementation can handle it */ 7920 && ! ( t_array[len-1] == 256 7921 && ( r_map[len-1] == TR_UNLISTED 7922 || r_map[len-1] == TR_SPECIAL_HANDLING)))) 7923 { 7924 SV* r_map_sv; 7925 7926 /* A UTF-8 op is generated, indicated by this flag. This op is an 7927 * sv_op */ 7928 o->op_private |= OPpTRANS_USE_SVOP; 7929 7930 if (can_force_utf8) { 7931 o->op_private |= OPpTRANS_CAN_FORCE_UTF8; 7932 } 7933 7934 /* The inversion map is pushed; first the list. */ 7935 invmap = MUTABLE_AV(newAV()); 7936 av_push(invmap, t_invlist); 7937 7938 /* 2nd is the mapping */ 7939 r_map_sv = newSVpvn((char *) r_map, len * sizeof(UV)); 7940 av_push(invmap, r_map_sv); 7941 7942 /* 3rd is the max possible expansion factor */ 7943 av_push(invmap, newSVnv(max_expansion)); 7944 7945 /* Characters that are in the search list, but not in the replacement 7946 * list are mapped to the final character in the replacement list */ 7947 if (! del && r_count < t_count) { 7948 av_push(invmap, newSVuv(final_map)); 7949 } 7950 7951 #ifdef USE_ITHREADS 7952 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY); 7953 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix)); 7954 PAD_SETSV(cPADOPo->op_padix, (SV *) invmap); 7955 SvPADTMP_on(invmap); 7956 SvREADONLY_on(invmap); 7957 #else 7958 cSVOPo->op_sv = (SV *) invmap; 7959 #endif 7960 7961 } 7962 else { 7963 OPtrans_map *tbl; 7964 unsigned short i; 7965 7966 /* The OPtrans_map struct already contains one slot; hence the -1. */ 7967 SSize_t struct_size = sizeof(OPtrans_map) 7968 + (256 - 1 + 1)*sizeof(short); 7969 7970 /* Non-utf8 case: set o->op_pv to point to a simple 256+ entry lookup 7971 * table. Entries with the value TR_UNMAPPED indicate chars not to be 7972 * translated, while TR_DELETE indicates a search char without a 7973 * corresponding replacement char under /d. 7974 * 7975 * In addition, an extra slot at the end is used to store the final 7976 * repeating char, or TR_R_EMPTY under an empty replacement list, or 7977 * TR_DELETE under /d; which makes the runtime code easier. 7978 */ 7979 7980 /* Indicate this is an op_pv */ 7981 o->op_private &= ~OPpTRANS_USE_SVOP; 7982 7983 tbl = (OPtrans_map*)PerlMemShared_calloc(struct_size, 1); 7984 tbl->size = 256; 7985 cPVOPo->op_pv = (char*)tbl; 7986 7987 for (i = 0; i < len; i++) { 7988 STATIC_ASSERT_DECL(TR_SPECIAL_HANDLING == TR_DELETE); 7989 short upper = i >= len - 1 ? 256 : (short) t_array[i+1]; 7990 short to = (short) r_map[i]; 7991 short j; 7992 bool do_increment = TRUE; 7993 7994 /* Any code points above our limit should be irrelevant */ 7995 if (t_array[i] >= tbl->size) break; 7996 7997 /* Set up the map */ 7998 if (to == (short) TR_SPECIAL_HANDLING && ! del) { 7999 to = (short) final_map; 8000 do_increment = FALSE; 8001 } 8002 else if (to < 0) { 8003 do_increment = FALSE; 8004 } 8005 8006 /* Create a map for everything in this range. The value increases 8007 * except for the special cases */ 8008 for (j = (short) t_array[i]; j < upper; j++) { 8009 tbl->map[j] = to; 8010 if (do_increment) to++; 8011 } 8012 } 8013 8014 tbl->map[tbl->size] = del 8015 ? (short) TR_DELETE 8016 : (short) rlen 8017 ? (short) final_map 8018 : (short) TR_R_EMPTY; 8019 DEBUG_y(PerlIO_printf(Perl_debug_log,"%s: %d\n", __FILE__, __LINE__)); 8020 for (i = 0; i < tbl->size; i++) { 8021 if (tbl->map[i] < 0) { 8022 DEBUG_y(PerlIO_printf(Perl_debug_log," %02x=>%d", 8023 (unsigned) i, tbl->map[i])); 8024 } 8025 else { 8026 DEBUG_y(PerlIO_printf(Perl_debug_log," %02x=>%02x", 8027 (unsigned) i, tbl->map[i])); 8028 } 8029 if ((i+1) % 8 == 0 || i + 1 == (short) tbl->size) { 8030 DEBUG_y(PerlIO_printf(Perl_debug_log,"\n")); 8031 } 8032 } 8033 DEBUG_y(PerlIO_printf(Perl_debug_log,"Final map 0x%x=>%02x\n", 8034 (unsigned) tbl->size, tbl->map[tbl->size])); 8035 8036 SvREFCNT_dec(t_invlist); 8037 8038 #if 0 /* code that added excess above-255 chars at the end of the table, in 8039 case we ever want to not use the inversion map implementation for 8040 this */ 8041 8042 ASSUME(j <= rlen); 8043 excess = rlen - j; 8044 8045 if (excess) { 8046 /* More replacement chars than search chars: 8047 * store excess replacement chars at end of main table. 8048 */ 8049 8050 struct_size += excess; 8051 tbl = (OPtrans_map*)PerlMemShared_realloc(tbl, 8052 struct_size + excess * sizeof(short)); 8053 tbl->size += excess; 8054 cPVOPo->op_pv = (char*)tbl; 8055 8056 for (i = 0; i < excess; i++) 8057 tbl->map[i + 256] = r[j+i]; 8058 } 8059 else { 8060 /* no more replacement chars than search chars */ 8061 } 8062 #endif 8063 8064 } 8065 8066 DEBUG_y(PerlIO_printf(Perl_debug_log, 8067 "/d=%d, /s=%d, /c=%d, identical=%d, grows=%d," 8068 " use_svop=%d, can_force_utf8=%d,\nexpansion=%" NVgf "\n", 8069 del, squash, complement, 8070 cBOOL(o->op_private & OPpTRANS_IDENTICAL), 8071 cBOOL(o->op_private & OPpTRANS_USE_SVOP), 8072 cBOOL(o->op_private & OPpTRANS_GROWS), 8073 cBOOL(o->op_private & OPpTRANS_CAN_FORCE_UTF8), 8074 max_expansion)); 8075 8076 Safefree(r_map); 8077 8078 if(del && rlen != 0 && r_count == t_count) { 8079 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator"); 8080 } else if(r_count > t_count) { 8081 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list"); 8082 } 8083 8084 op_free(expr); 8085 op_free(repl); 8086 8087 return o; 8088 } 8089 8090 8091 /* 8092 =for apidoc newPMOP 8093 8094 Constructs, checks, and returns an op of any pattern matching type. 8095 C<type> is the opcode. C<flags> gives the eight bits of C<op_flags> 8096 and, shifted up eight bits, the eight bits of C<op_private>. 8097 8098 =cut 8099 */ 8100 8101 OP * 8102 Perl_newPMOP(pTHX_ I32 type, I32 flags) 8103 { 8104 dVAR; 8105 PMOP *pmop; 8106 8107 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP 8108 || type == OP_CUSTOM); 8109 8110 NewOp(1101, pmop, 1, PMOP); 8111 OpTYPE_set(pmop, type); 8112 pmop->op_flags = (U8)flags; 8113 pmop->op_private = (U8)(0 | (flags >> 8)); 8114 if (PL_opargs[type] & OA_RETSCALAR) 8115 scalar((OP *)pmop); 8116 8117 if (PL_hints & HINT_RE_TAINT) 8118 pmop->op_pmflags |= PMf_RETAINT; 8119 #ifdef USE_LOCALE_CTYPE 8120 if (IN_LC_COMPILETIME(LC_CTYPE)) { 8121 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET); 8122 } 8123 else 8124 #endif 8125 if (IN_UNI_8_BIT) { 8126 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET); 8127 } 8128 if (PL_hints & HINT_RE_FLAGS) { 8129 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_ 8130 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0 8131 ); 8132 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags); 8133 reflags = Perl_refcounted_he_fetch_pvn(aTHX_ 8134 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0 8135 ); 8136 if (reflags && SvOK(reflags)) { 8137 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags)); 8138 } 8139 } 8140 8141 8142 #ifdef USE_ITHREADS 8143 assert(SvPOK(PL_regex_pad[0])); 8144 if (SvCUR(PL_regex_pad[0])) { 8145 /* Pop off the "packed" IV from the end. */ 8146 SV *const repointer_list = PL_regex_pad[0]; 8147 const char *p = SvEND(repointer_list) - sizeof(IV); 8148 const IV offset = *((IV*)p); 8149 8150 assert(SvCUR(repointer_list) % sizeof(IV) == 0); 8151 8152 SvEND_set(repointer_list, p); 8153 8154 pmop->op_pmoffset = offset; 8155 /* This slot should be free, so assert this: */ 8156 assert(PL_regex_pad[offset] == &PL_sv_undef); 8157 } else { 8158 SV * const repointer = &PL_sv_undef; 8159 av_push(PL_regex_padav, repointer); 8160 pmop->op_pmoffset = av_tindex(PL_regex_padav); 8161 PL_regex_pad = AvARRAY(PL_regex_padav); 8162 } 8163 #endif 8164 8165 return CHECKOP(type, pmop); 8166 } 8167 8168 static void 8169 S_set_haseval(pTHX) 8170 { 8171 PADOFFSET i = 1; 8172 PL_cv_has_eval = 1; 8173 /* Any pad names in scope are potentially lvalues. */ 8174 for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) { 8175 PADNAME *pn = PAD_COMPNAME_SV(i); 8176 if (!pn || !PadnameLEN(pn)) 8177 continue; 8178 if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax)) 8179 S_mark_padname_lvalue(aTHX_ pn); 8180 } 8181 } 8182 8183 /* Given some sort of match op o, and an expression expr containing a 8184 * pattern, either compile expr into a regex and attach it to o (if it's 8185 * constant), or convert expr into a runtime regcomp op sequence (if it's 8186 * not) 8187 * 8188 * Flags currently has 2 bits of meaning: 8189 * 1: isreg indicates that the pattern is part of a regex construct, eg 8190 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or 8191 * split "pattern", which aren't. In the former case, expr will be a list 8192 * if the pattern contains more than one term (eg /a$b/). 8193 * 2: The pattern is for a split. 8194 * 8195 * When the pattern has been compiled within a new anon CV (for 8196 * qr/(?{...})/ ), then floor indicates the savestack level just before 8197 * the new sub was created 8198 * 8199 * tr/// is also handled. 8200 */ 8201 8202 OP * 8203 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor) 8204 { 8205 PMOP *pm; 8206 LOGOP *rcop; 8207 I32 repl_has_vars = 0; 8208 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR); 8209 bool is_compiletime; 8210 bool has_code; 8211 bool isreg = cBOOL(flags & 1); 8212 bool is_split = cBOOL(flags & 2); 8213 8214 PERL_ARGS_ASSERT_PMRUNTIME; 8215 8216 if (is_trans) { 8217 return pmtrans(o, expr, repl); 8218 } 8219 8220 /* find whether we have any runtime or code elements; 8221 * at the same time, temporarily set the op_next of each DO block; 8222 * then when we LINKLIST, this will cause the DO blocks to be excluded 8223 * from the op_next chain (and from having LINKLIST recursively 8224 * applied to them). We fix up the DOs specially later */ 8225 8226 is_compiletime = 1; 8227 has_code = 0; 8228 if (expr->op_type == OP_LIST) { 8229 OP *child; 8230 for (child = cLISTOPx(expr)->op_first; child; child = OpSIBLING(child)) { 8231 if (child->op_type == OP_NULL && (child->op_flags & OPf_SPECIAL)) { 8232 has_code = 1; 8233 assert(!child->op_next); 8234 if (UNLIKELY(!OpHAS_SIBLING(child))) { 8235 assert(PL_parser && PL_parser->error_count); 8236 /* This can happen with qr/ (?{(^{})/. Just fake up 8237 the op we were expecting to see, to avoid crashing 8238 elsewhere. */ 8239 op_sibling_splice(expr, child, 0, 8240 newSVOP(OP_CONST, 0, &PL_sv_no)); 8241 } 8242 child->op_next = OpSIBLING(child); 8243 } 8244 else if (child->op_type != OP_CONST && child->op_type != OP_PUSHMARK) 8245 is_compiletime = 0; 8246 } 8247 } 8248 else if (expr->op_type != OP_CONST) 8249 is_compiletime = 0; 8250 8251 LINKLIST(expr); 8252 8253 /* fix up DO blocks; treat each one as a separate little sub; 8254 * also, mark any arrays as LIST/REF */ 8255 8256 if (expr->op_type == OP_LIST) { 8257 OP *child; 8258 for (child = cLISTOPx(expr)->op_first; child; child = OpSIBLING(child)) { 8259 8260 if (child->op_type == OP_PADAV || child->op_type == OP_RV2AV) { 8261 assert( !(child->op_flags & OPf_WANT)); 8262 /* push the array rather than its contents. The regex 8263 * engine will retrieve and join the elements later */ 8264 child->op_flags |= (OPf_WANT_LIST | OPf_REF); 8265 continue; 8266 } 8267 8268 if (!(child->op_type == OP_NULL && (child->op_flags & OPf_SPECIAL))) 8269 continue; 8270 child->op_next = NULL; /* undo temporary hack from above */ 8271 scalar(child); 8272 LINKLIST(child); 8273 if (cLISTOPx(child)->op_first->op_type == OP_LEAVE) { 8274 LISTOP *leaveop = cLISTOPx(cLISTOPx(child)->op_first); 8275 /* skip ENTER */ 8276 assert(leaveop->op_first->op_type == OP_ENTER); 8277 assert(OpHAS_SIBLING(leaveop->op_first)); 8278 child->op_next = OpSIBLING(leaveop->op_first); 8279 /* skip leave */ 8280 assert(leaveop->op_flags & OPf_KIDS); 8281 assert(leaveop->op_last->op_next == (OP*)leaveop); 8282 leaveop->op_next = NULL; /* stop on last op */ 8283 op_null((OP*)leaveop); 8284 } 8285 else { 8286 /* skip SCOPE */ 8287 OP *scope = cLISTOPx(child)->op_first; 8288 assert(scope->op_type == OP_SCOPE); 8289 assert(scope->op_flags & OPf_KIDS); 8290 scope->op_next = NULL; /* stop on last op */ 8291 op_null(scope); 8292 } 8293 8294 /* XXX optimize_optree() must be called on o before 8295 * CALL_PEEP(), as currently S_maybe_multiconcat() can't 8296 * currently cope with a peephole-optimised optree. 8297 * Calling optimize_optree() here ensures that condition 8298 * is met, but may mean optimize_optree() is applied 8299 * to the same optree later (where hopefully it won't do any 8300 * harm as it can't convert an op to multiconcat if it's 8301 * already been converted */ 8302 optimize_optree(child); 8303 8304 /* have to peep the DOs individually as we've removed it from 8305 * the op_next chain */ 8306 CALL_PEEP(child); 8307 S_prune_chain_head(&(child->op_next)); 8308 if (is_compiletime) 8309 /* runtime finalizes as part of finalizing whole tree */ 8310 finalize_optree(child); 8311 } 8312 } 8313 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) { 8314 assert( !(expr->op_flags & OPf_WANT)); 8315 /* push the array rather than its contents. The regex 8316 * engine will retrieve and join the elements later */ 8317 expr->op_flags |= (OPf_WANT_LIST | OPf_REF); 8318 } 8319 8320 PL_hints |= HINT_BLOCK_SCOPE; 8321 pm = (PMOP*)o; 8322 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV)); 8323 8324 if (is_compiletime) { 8325 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME; 8326 regexp_engine const *eng = current_re_engine(); 8327 8328 if (is_split) { 8329 /* make engine handle split ' ' specially */ 8330 pm->op_pmflags |= PMf_SPLIT; 8331 rx_flags |= RXf_SPLIT; 8332 } 8333 8334 if (!has_code || !eng->op_comp) { 8335 /* compile-time simple constant pattern */ 8336 8337 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) { 8338 /* whoops! we guessed that a qr// had a code block, but we 8339 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv 8340 * that isn't required now. Note that we have to be pretty 8341 * confident that nothing used that CV's pad while the 8342 * regex was parsed, except maybe op targets for \Q etc. 8343 * If there were any op targets, though, they should have 8344 * been stolen by constant folding. 8345 */ 8346 #ifdef DEBUGGING 8347 SSize_t i = 0; 8348 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0); 8349 while (++i <= AvFILLp(PL_comppad)) { 8350 # ifdef USE_PAD_RESET 8351 /* under USE_PAD_RESET, pad swipe replaces a swiped 8352 * folded constant with a fresh padtmp */ 8353 assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i])); 8354 # else 8355 assert(!PL_curpad[i]); 8356 # endif 8357 } 8358 #endif 8359 /* This LEAVE_SCOPE will restore PL_compcv to point to the 8360 * outer CV (the one whose slab holds the pm op). The 8361 * inner CV (which holds expr) will be freed later, once 8362 * all the entries on the parse stack have been popped on 8363 * return from this function. Which is why its safe to 8364 * call op_free(expr) below. 8365 */ 8366 LEAVE_SCOPE(floor); 8367 pm->op_pmflags &= ~PMf_HAS_CV; 8368 } 8369 8370 /* Skip compiling if parser found an error for this pattern */ 8371 if (pm->op_pmflags & PMf_HAS_ERROR) { 8372 return o; 8373 } 8374 8375 PM_SETRE(pm, 8376 eng->op_comp 8377 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL, 8378 rx_flags, pm->op_pmflags) 8379 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL, 8380 rx_flags, pm->op_pmflags) 8381 ); 8382 op_free(expr); 8383 } 8384 else { 8385 /* compile-time pattern that includes literal code blocks */ 8386 8387 REGEXP* re; 8388 8389 /* Skip compiling if parser found an error for this pattern */ 8390 if (pm->op_pmflags & PMf_HAS_ERROR) { 8391 return o; 8392 } 8393 8394 re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL, 8395 rx_flags, 8396 (pm->op_pmflags | 8397 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0)) 8398 ); 8399 PM_SETRE(pm, re); 8400 if (pm->op_pmflags & PMf_HAS_CV) { 8401 CV *cv; 8402 /* this QR op (and the anon sub we embed it in) is never 8403 * actually executed. It's just a placeholder where we can 8404 * squirrel away expr in op_code_list without the peephole 8405 * optimiser etc processing it for a second time */ 8406 OP *qr = newPMOP(OP_QR, 0); 8407 ((PMOP*)qr)->op_code_list = expr; 8408 8409 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */ 8410 SvREFCNT_inc_simple_void(PL_compcv); 8411 cv = newATTRSUB(floor, 0, NULL, NULL, qr); 8412 ReANY(re)->qr_anoncv = cv; 8413 8414 /* attach the anon CV to the pad so that 8415 * pad_fixup_inner_anons() can find it */ 8416 (void)pad_add_anon(cv, o->op_type); 8417 SvREFCNT_inc_simple_void(cv); 8418 } 8419 else { 8420 pm->op_code_list = expr; 8421 } 8422 } 8423 } 8424 else { 8425 /* runtime pattern: build chain of regcomp etc ops */ 8426 bool reglist; 8427 PADOFFSET cv_targ = 0; 8428 8429 reglist = isreg && expr->op_type == OP_LIST; 8430 if (reglist) 8431 op_null(expr); 8432 8433 if (has_code) { 8434 pm->op_code_list = expr; 8435 /* don't free op_code_list; its ops are embedded elsewhere too */ 8436 pm->op_pmflags |= PMf_CODELIST_PRIVATE; 8437 } 8438 8439 if (is_split) 8440 /* make engine handle split ' ' specially */ 8441 pm->op_pmflags |= PMf_SPLIT; 8442 8443 /* the OP_REGCMAYBE is a placeholder in the non-threaded case 8444 * to allow its op_next to be pointed past the regcomp and 8445 * preceding stacking ops; 8446 * OP_REGCRESET is there to reset taint before executing the 8447 * stacking ops */ 8448 if (pm->op_pmflags & PMf_KEEP || TAINTING_get) 8449 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr); 8450 8451 if (pm->op_pmflags & PMf_HAS_CV) { 8452 /* we have a runtime qr with literal code. This means 8453 * that the qr// has been wrapped in a new CV, which 8454 * means that runtime consts, vars etc will have been compiled 8455 * against a new pad. So... we need to execute those ops 8456 * within the environment of the new CV. So wrap them in a call 8457 * to a new anon sub. i.e. for 8458 * 8459 * qr/a$b(?{...})/, 8460 * 8461 * we build an anon sub that looks like 8462 * 8463 * sub { "a", $b, '(?{...})' } 8464 * 8465 * and call it, passing the returned list to regcomp. 8466 * Or to put it another way, the list of ops that get executed 8467 * are: 8468 * 8469 * normal PMf_HAS_CV 8470 * ------ ------------------- 8471 * pushmark (for regcomp) 8472 * pushmark (for entersub) 8473 * anoncode 8474 * srefgen 8475 * entersub 8476 * regcreset regcreset 8477 * pushmark pushmark 8478 * const("a") const("a") 8479 * gvsv(b) gvsv(b) 8480 * const("(?{...})") const("(?{...})") 8481 * leavesub 8482 * regcomp regcomp 8483 */ 8484 8485 SvREFCNT_inc_simple_void(PL_compcv); 8486 CvLVALUE_on(PL_compcv); 8487 /* these lines are just an unrolled newANONATTRSUB */ 8488 expr = newSVOP(OP_ANONCODE, 0, 8489 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr))); 8490 cv_targ = expr->op_targ; 8491 expr = newUNOP(OP_REFGEN, 0, expr); 8492 8493 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1)); 8494 } 8495 8496 rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o); 8497 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0) 8498 | (reglist ? OPf_STACKED : 0); 8499 rcop->op_targ = cv_targ; 8500 8501 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */ 8502 if (PL_hints & HINT_RE_EVAL) 8503 S_set_haseval(aTHX); 8504 8505 /* establish postfix order */ 8506 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) { 8507 LINKLIST(expr); 8508 rcop->op_next = expr; 8509 ((UNOP*)expr)->op_first->op_next = (OP*)rcop; 8510 } 8511 else { 8512 rcop->op_next = LINKLIST(expr); 8513 expr->op_next = (OP*)rcop; 8514 } 8515 8516 op_prepend_elem(o->op_type, scalar((OP*)rcop), o); 8517 } 8518 8519 if (repl) { 8520 OP *curop = repl; 8521 bool konst; 8522 /* If we are looking at s//.../e with a single statement, get past 8523 the implicit do{}. */ 8524 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS 8525 && cUNOPx(curop)->op_first->op_type == OP_SCOPE 8526 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS) 8527 { 8528 OP *sib; 8529 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first; 8530 if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid)) 8531 && !OpHAS_SIBLING(sib)) 8532 curop = sib; 8533 } 8534 if (curop->op_type == OP_CONST) 8535 konst = TRUE; 8536 else if (( (curop->op_type == OP_RV2SV || 8537 curop->op_type == OP_RV2AV || 8538 curop->op_type == OP_RV2HV || 8539 curop->op_type == OP_RV2GV) 8540 && cUNOPx(curop)->op_first 8541 && cUNOPx(curop)->op_first->op_type == OP_GV ) 8542 || curop->op_type == OP_PADSV 8543 || curop->op_type == OP_PADAV 8544 || curop->op_type == OP_PADHV 8545 || curop->op_type == OP_PADANY) { 8546 repl_has_vars = 1; 8547 konst = TRUE; 8548 } 8549 else konst = FALSE; 8550 if (konst 8551 && !(repl_has_vars 8552 && (!PM_GETRE(pm) 8553 || !RX_PRELEN(PM_GETRE(pm)) 8554 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN))) 8555 { 8556 pm->op_pmflags |= PMf_CONST; /* const for long enough */ 8557 op_prepend_elem(o->op_type, scalar(repl), o); 8558 } 8559 else { 8560 rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o); 8561 rcop->op_private = 1; 8562 8563 /* establish postfix order */ 8564 rcop->op_next = LINKLIST(repl); 8565 repl->op_next = (OP*)rcop; 8566 8567 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop); 8568 assert(!(pm->op_pmflags & PMf_ONCE)); 8569 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop); 8570 rcop->op_next = 0; 8571 } 8572 } 8573 8574 return (OP*)pm; 8575 } 8576 8577 /* 8578 =for apidoc newSVOP 8579 8580 Constructs, checks, and returns an op of any type that involves an 8581 embedded SV. C<type> is the opcode. C<flags> gives the eight bits 8582 of C<op_flags>. C<sv> gives the SV to embed in the op; this function 8583 takes ownership of one reference to it. 8584 8585 =cut 8586 */ 8587 8588 OP * 8589 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv) 8590 { 8591 dVAR; 8592 SVOP *svop; 8593 8594 PERL_ARGS_ASSERT_NEWSVOP; 8595 8596 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP 8597 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP 8598 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP 8599 || type == OP_CUSTOM); 8600 8601 NewOp(1101, svop, 1, SVOP); 8602 OpTYPE_set(svop, type); 8603 svop->op_sv = sv; 8604 svop->op_next = (OP*)svop; 8605 svop->op_flags = (U8)flags; 8606 svop->op_private = (U8)(0 | (flags >> 8)); 8607 if (PL_opargs[type] & OA_RETSCALAR) 8608 scalar((OP*)svop); 8609 if (PL_opargs[type] & OA_TARGET) 8610 svop->op_targ = pad_alloc(type, SVs_PADTMP); 8611 return CHECKOP(type, svop); 8612 } 8613 8614 /* 8615 =for apidoc newDEFSVOP 8616 8617 Constructs and returns an op to access C<$_>. 8618 8619 =cut 8620 */ 8621 8622 OP * 8623 Perl_newDEFSVOP(pTHX) 8624 { 8625 return newSVREF(newGVOP(OP_GV, 0, PL_defgv)); 8626 } 8627 8628 #ifdef USE_ITHREADS 8629 8630 /* 8631 =for apidoc newPADOP 8632 8633 Constructs, checks, and returns an op of any type that involves a 8634 reference to a pad element. C<type> is the opcode. C<flags> gives the 8635 eight bits of C<op_flags>. A pad slot is automatically allocated, and 8636 is populated with C<sv>; this function takes ownership of one reference 8637 to it. 8638 8639 This function only exists if Perl has been compiled to use ithreads. 8640 8641 =cut 8642 */ 8643 8644 OP * 8645 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) 8646 { 8647 dVAR; 8648 PADOP *padop; 8649 8650 PERL_ARGS_ASSERT_NEWPADOP; 8651 8652 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP 8653 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP 8654 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP 8655 || type == OP_CUSTOM); 8656 8657 NewOp(1101, padop, 1, PADOP); 8658 OpTYPE_set(padop, type); 8659 padop->op_padix = 8660 pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP); 8661 SvREFCNT_dec(PAD_SVl(padop->op_padix)); 8662 PAD_SETSV(padop->op_padix, sv); 8663 assert(sv); 8664 padop->op_next = (OP*)padop; 8665 padop->op_flags = (U8)flags; 8666 if (PL_opargs[type] & OA_RETSCALAR) 8667 scalar((OP*)padop); 8668 if (PL_opargs[type] & OA_TARGET) 8669 padop->op_targ = pad_alloc(type, SVs_PADTMP); 8670 return CHECKOP(type, padop); 8671 } 8672 8673 #endif /* USE_ITHREADS */ 8674 8675 /* 8676 =for apidoc newGVOP 8677 8678 Constructs, checks, and returns an op of any type that involves an 8679 embedded reference to a GV. C<type> is the opcode. C<flags> gives the 8680 eight bits of C<op_flags>. C<gv> identifies the GV that the op should 8681 reference; calling this function does not transfer ownership of any 8682 reference to it. 8683 8684 =cut 8685 */ 8686 8687 OP * 8688 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv) 8689 { 8690 PERL_ARGS_ASSERT_NEWGVOP; 8691 8692 #ifdef USE_ITHREADS 8693 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv)); 8694 #else 8695 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv)); 8696 #endif 8697 } 8698 8699 /* 8700 =for apidoc newPVOP 8701 8702 Constructs, checks, and returns an op of any type that involves an 8703 embedded C-level pointer (PV). C<type> is the opcode. C<flags> gives 8704 the eight bits of C<op_flags>. C<pv> supplies the C-level pointer. 8705 Depending on the op type, the memory referenced by C<pv> may be freed 8706 when the op is destroyed. If the op is of a freeing type, C<pv> must 8707 have been allocated using C<PerlMemShared_malloc>. 8708 8709 =cut 8710 */ 8711 8712 OP * 8713 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv) 8714 { 8715 dVAR; 8716 const bool utf8 = cBOOL(flags & SVf_UTF8); 8717 PVOP *pvop; 8718 8719 flags &= ~SVf_UTF8; 8720 8721 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP 8722 || type == OP_RUNCV || type == OP_CUSTOM 8723 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP); 8724 8725 NewOp(1101, pvop, 1, PVOP); 8726 OpTYPE_set(pvop, type); 8727 pvop->op_pv = pv; 8728 pvop->op_next = (OP*)pvop; 8729 pvop->op_flags = (U8)flags; 8730 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0; 8731 if (PL_opargs[type] & OA_RETSCALAR) 8732 scalar((OP*)pvop); 8733 if (PL_opargs[type] & OA_TARGET) 8734 pvop->op_targ = pad_alloc(type, SVs_PADTMP); 8735 return CHECKOP(type, pvop); 8736 } 8737 8738 void 8739 Perl_package(pTHX_ OP *o) 8740 { 8741 SV *const sv = cSVOPo->op_sv; 8742 8743 PERL_ARGS_ASSERT_PACKAGE; 8744 8745 SAVEGENERICSV(PL_curstash); 8746 save_item(PL_curstname); 8747 8748 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD)); 8749 8750 sv_setsv(PL_curstname, sv); 8751 8752 PL_hints |= HINT_BLOCK_SCOPE; 8753 PL_parser->copline = NOLINE; 8754 8755 op_free(o); 8756 } 8757 8758 void 8759 Perl_package_version( pTHX_ OP *v ) 8760 { 8761 U32 savehints = PL_hints; 8762 PERL_ARGS_ASSERT_PACKAGE_VERSION; 8763 PL_hints &= ~HINT_STRICT_VARS; 8764 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv ); 8765 PL_hints = savehints; 8766 op_free(v); 8767 } 8768 8769 void 8770 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) 8771 { 8772 OP *pack; 8773 OP *imop; 8774 OP *veop; 8775 SV *use_version = NULL; 8776 8777 PERL_ARGS_ASSERT_UTILIZE; 8778 8779 if (idop->op_type != OP_CONST) 8780 Perl_croak(aTHX_ "Module name must be constant"); 8781 8782 veop = NULL; 8783 8784 if (version) { 8785 SV * const vesv = ((SVOP*)version)->op_sv; 8786 8787 if (!arg && !SvNIOKp(vesv)) { 8788 arg = version; 8789 } 8790 else { 8791 OP *pack; 8792 SV *meth; 8793 8794 if (version->op_type != OP_CONST || !SvNIOKp(vesv)) 8795 Perl_croak(aTHX_ "Version number must be a constant number"); 8796 8797 /* Make copy of idop so we don't free it twice */ 8798 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv)); 8799 8800 /* Fake up a method call to VERSION */ 8801 meth = newSVpvs_share("VERSION"); 8802 veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, 8803 op_append_elem(OP_LIST, 8804 op_prepend_elem(OP_LIST, pack, version), 8805 newMETHOP_named(OP_METHOD_NAMED, 0, meth))); 8806 } 8807 } 8808 8809 /* Fake up an import/unimport */ 8810 if (arg && arg->op_type == OP_STUB) { 8811 imop = arg; /* no import on explicit () */ 8812 } 8813 else if (SvNIOKp(((SVOP*)idop)->op_sv)) { 8814 imop = NULL; /* use 5.0; */ 8815 if (aver) 8816 use_version = ((SVOP*)idop)->op_sv; 8817 else 8818 idop->op_private |= OPpCONST_NOVER; 8819 } 8820 else { 8821 SV *meth; 8822 8823 /* Make copy of idop so we don't free it twice */ 8824 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv)); 8825 8826 /* Fake up a method call to import/unimport */ 8827 meth = aver 8828 ? newSVpvs_share("import") : newSVpvs_share("unimport"); 8829 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, 8830 op_append_elem(OP_LIST, 8831 op_prepend_elem(OP_LIST, pack, arg), 8832 newMETHOP_named(OP_METHOD_NAMED, 0, meth) 8833 )); 8834 } 8835 8836 /* Fake up the BEGIN {}, which does its thing immediately. */ 8837 newATTRSUB(floor, 8838 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")), 8839 NULL, 8840 NULL, 8841 op_append_elem(OP_LINESEQ, 8842 op_append_elem(OP_LINESEQ, 8843 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)), 8844 newSTATEOP(0, NULL, veop)), 8845 newSTATEOP(0, NULL, imop) )); 8846 8847 if (use_version) { 8848 /* Enable the 8849 * feature bundle that corresponds to the required version. */ 8850 use_version = sv_2mortal(new_version(use_version)); 8851 S_enable_feature_bundle(aTHX_ use_version); 8852 8853 /* If a version >= 5.11.0 is requested, strictures are on by default! */ 8854 if (vcmp(use_version, 8855 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) { 8856 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS)) 8857 PL_hints |= HINT_STRICT_REFS; 8858 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS)) 8859 PL_hints |= HINT_STRICT_SUBS; 8860 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS)) 8861 PL_hints |= HINT_STRICT_VARS; 8862 } 8863 /* otherwise they are off */ 8864 else { 8865 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS)) 8866 PL_hints &= ~HINT_STRICT_REFS; 8867 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS)) 8868 PL_hints &= ~HINT_STRICT_SUBS; 8869 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS)) 8870 PL_hints &= ~HINT_STRICT_VARS; 8871 } 8872 } 8873 8874 /* The "did you use incorrect case?" warning used to be here. 8875 * The problem is that on case-insensitive filesystems one 8876 * might get false positives for "use" (and "require"): 8877 * "use Strict" or "require CARP" will work. This causes 8878 * portability problems for the script: in case-strict 8879 * filesystems the script will stop working. 8880 * 8881 * The "incorrect case" warning checked whether "use Foo" 8882 * imported "Foo" to your namespace, but that is wrong, too: 8883 * there is no requirement nor promise in the language that 8884 * a Foo.pm should or would contain anything in package "Foo". 8885 * 8886 * There is very little Configure-wise that can be done, either: 8887 * the case-sensitivity of the build filesystem of Perl does not 8888 * help in guessing the case-sensitivity of the runtime environment. 8889 */ 8890 8891 PL_hints |= HINT_BLOCK_SCOPE; 8892 PL_parser->copline = NOLINE; 8893 COP_SEQMAX_INC; /* Purely for B::*'s benefit */ 8894 } 8895 8896 /* 8897 =head1 Embedding Functions 8898 8899 =for apidoc load_module 8900 8901 Loads the module whose name is pointed to by the string part of C<name>. 8902 Note that the actual module name, not its filename, should be given. 8903 Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL, 8904 provides version semantics similar to C<use Foo::Bar VERSION>. The optional 8905 trailing arguments can be used to specify arguments to the module's C<import()> 8906 method, similar to C<use Foo::Bar VERSION LIST>; their precise handling depends 8907 on the flags. The flags argument is a bitwise-ORed collection of any of 8908 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS> 8909 (or 0 for no flags). 8910 8911 If C<PERL_LOADMOD_NOIMPORT> is set, the module is loaded as if with an empty 8912 import list, as in C<use Foo::Bar ()>; this is the only circumstance in which 8913 the trailing optional arguments may be omitted entirely. Otherwise, if 8914 C<PERL_LOADMOD_IMPORT_OPS> is set, the trailing arguments must consist of 8915 exactly one C<OP*>, containing the op tree that produces the relevant import 8916 arguments. Otherwise, the trailing arguments must all be C<SV*> values that 8917 will be used as import arguments; and the list must be terminated with C<(SV*) 8918 NULL>. If neither C<PERL_LOADMOD_NOIMPORT> nor C<PERL_LOADMOD_IMPORT_OPS> is 8919 set, the trailing C<NULL> pointer is needed even if no import arguments are 8920 desired. The reference count for each specified C<SV*> argument is 8921 decremented. In addition, the C<name> argument is modified. 8922 8923 If C<PERL_LOADMOD_DENY> is set, the module is loaded as if with C<no> rather 8924 than C<use>. 8925 8926 =for apidoc Amnh||PERL_LOADMOD_DENY 8927 =for apidoc Amnh||PERL_LOADMOD_NOIMPORT 8928 =for apidoc Amnh||PERL_LOADMOD_IMPORT_OPS 8929 8930 =cut */ 8931 8932 void 8933 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...) 8934 { 8935 va_list args; 8936 8937 PERL_ARGS_ASSERT_LOAD_MODULE; 8938 8939 va_start(args, ver); 8940 vload_module(flags, name, ver, &args); 8941 va_end(args); 8942 } 8943 8944 #ifdef PERL_IMPLICIT_CONTEXT 8945 void 8946 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...) 8947 { 8948 dTHX; 8949 va_list args; 8950 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT; 8951 va_start(args, ver); 8952 vload_module(flags, name, ver, &args); 8953 va_end(args); 8954 } 8955 #endif 8956 8957 void 8958 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args) 8959 { 8960 OP *veop, *imop; 8961 OP * modname; 8962 I32 floor; 8963 8964 PERL_ARGS_ASSERT_VLOAD_MODULE; 8965 8966 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure 8967 * that it has a PL_parser to play with while doing that, and also 8968 * that it doesn't mess with any existing parser, by creating a tmp 8969 * new parser with lex_start(). This won't actually be used for much, 8970 * since pp_require() will create another parser for the real work. 8971 * The ENTER/LEAVE pair protect callers from any side effects of use. 8972 * 8973 * start_subparse() creates a new PL_compcv. This means that any ops 8974 * allocated below will be allocated from that CV's op slab, and so 8975 * will be automatically freed if the utilise() fails 8976 */ 8977 8978 ENTER; 8979 SAVEVPTR(PL_curcop); 8980 lex_start(NULL, NULL, LEX_START_SAME_FILTER); 8981 floor = start_subparse(FALSE, 0); 8982 8983 modname = newSVOP(OP_CONST, 0, name); 8984 modname->op_private |= OPpCONST_BARE; 8985 if (ver) { 8986 veop = newSVOP(OP_CONST, 0, ver); 8987 } 8988 else 8989 veop = NULL; 8990 if (flags & PERL_LOADMOD_NOIMPORT) { 8991 imop = sawparens(newNULLLIST()); 8992 } 8993 else if (flags & PERL_LOADMOD_IMPORT_OPS) { 8994 imop = va_arg(*args, OP*); 8995 } 8996 else { 8997 SV *sv; 8998 imop = NULL; 8999 sv = va_arg(*args, SV*); 9000 while (sv) { 9001 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv)); 9002 sv = va_arg(*args, SV*); 9003 } 9004 } 9005 9006 utilize(!(flags & PERL_LOADMOD_DENY), floor, veop, modname, imop); 9007 LEAVE; 9008 } 9009 9010 PERL_STATIC_INLINE OP * 9011 S_new_entersubop(pTHX_ GV *gv, OP *arg) 9012 { 9013 return newUNOP(OP_ENTERSUB, OPf_STACKED, 9014 newLISTOP(OP_LIST, 0, arg, 9015 newUNOP(OP_RV2CV, 0, 9016 newGVOP(OP_GV, 0, gv)))); 9017 } 9018 9019 OP * 9020 Perl_dofile(pTHX_ OP *term, I32 force_builtin) 9021 { 9022 OP *doop; 9023 GV *gv; 9024 9025 PERL_ARGS_ASSERT_DOFILE; 9026 9027 if (!force_builtin && (gv = gv_override("do", 2))) { 9028 doop = S_new_entersubop(aTHX_ gv, term); 9029 } 9030 else { 9031 doop = newUNOP(OP_DOFILE, 0, scalar(term)); 9032 } 9033 return doop; 9034 } 9035 9036 /* 9037 =head1 Optree construction 9038 9039 =for apidoc newSLICEOP 9040 9041 Constructs, checks, and returns an C<lslice> (list slice) op. C<flags> 9042 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will 9043 be set automatically, and, shifted up eight bits, the eight bits of 9044 C<op_private>, except that the bit with value 1 or 2 is automatically 9045 set as required. C<listval> and C<subscript> supply the parameters of 9046 the slice; they are consumed by this function and become part of the 9047 constructed op tree. 9048 9049 =cut 9050 */ 9051 9052 OP * 9053 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval) 9054 { 9055 return newBINOP(OP_LSLICE, flags, 9056 list(force_list(subscript, 1)), 9057 list(force_list(listval, 1)) ); 9058 } 9059 9060 #define ASSIGN_SCALAR 0 9061 #define ASSIGN_LIST 1 9062 #define ASSIGN_REF 2 9063 9064 /* given the optree o on the LHS of an assignment, determine whether its: 9065 * ASSIGN_SCALAR $x = ... 9066 * ASSIGN_LIST ($x) = ... 9067 * ASSIGN_REF \$x = ... 9068 */ 9069 9070 STATIC I32 9071 S_assignment_type(pTHX_ const OP *o) 9072 { 9073 unsigned type; 9074 U8 flags; 9075 U8 ret; 9076 9077 if (!o) 9078 return ASSIGN_LIST; 9079 9080 if (o->op_type == OP_SREFGEN) 9081 { 9082 OP * const kid = cUNOPx(cUNOPo->op_first)->op_first; 9083 type = kid->op_type; 9084 flags = o->op_flags | kid->op_flags; 9085 if (!(flags & OPf_PARENS) 9086 && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV || 9087 kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV )) 9088 return ASSIGN_REF; 9089 ret = ASSIGN_REF; 9090 } else { 9091 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS)) 9092 o = cUNOPo->op_first; 9093 flags = o->op_flags; 9094 type = o->op_type; 9095 ret = ASSIGN_SCALAR; 9096 } 9097 9098 if (type == OP_COND_EXPR) { 9099 OP * const sib = OpSIBLING(cLOGOPo->op_first); 9100 const I32 t = assignment_type(sib); 9101 const I32 f = assignment_type(OpSIBLING(sib)); 9102 9103 if (t == ASSIGN_LIST && f == ASSIGN_LIST) 9104 return ASSIGN_LIST; 9105 if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST)) 9106 yyerror("Assignment to both a list and a scalar"); 9107 return ASSIGN_SCALAR; 9108 } 9109 9110 if (type == OP_LIST && 9111 (flags & OPf_WANT) == OPf_WANT_SCALAR && 9112 o->op_private & OPpLVAL_INTRO) 9113 return ret; 9114 9115 if (type == OP_LIST || flags & OPf_PARENS || 9116 type == OP_RV2AV || type == OP_RV2HV || 9117 type == OP_ASLICE || type == OP_HSLICE || 9118 type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN) 9119 return ASSIGN_LIST; 9120 9121 if (type == OP_PADAV || type == OP_PADHV) 9122 return ASSIGN_LIST; 9123 9124 if (type == OP_RV2SV) 9125 return ret; 9126 9127 return ret; 9128 } 9129 9130 static OP * 9131 S_newONCEOP(pTHX_ OP *initop, OP *padop) 9132 { 9133 dVAR; 9134 const PADOFFSET target = padop->op_targ; 9135 OP *const other = newOP(OP_PADSV, 9136 padop->op_flags 9137 | ((padop->op_private & ~OPpLVAL_INTRO) << 8)); 9138 OP *const first = newOP(OP_NULL, 0); 9139 OP *const nullop = newCONDOP(0, first, initop, other); 9140 /* XXX targlex disabled for now; see ticket #124160 9141 newCONDOP(0, first, S_maybe_targlex(aTHX_ initop), other); 9142 */ 9143 OP *const condop = first->op_next; 9144 9145 OpTYPE_set(condop, OP_ONCE); 9146 other->op_targ = target; 9147 nullop->op_flags |= OPf_WANT_SCALAR; 9148 9149 /* Store the initializedness of state vars in a separate 9150 pad entry. */ 9151 condop->op_targ = 9152 pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0); 9153 /* hijacking PADSTALE for uninitialized state variables */ 9154 SvPADSTALE_on(PAD_SVl(condop->op_targ)); 9155 9156 return nullop; 9157 } 9158 9159 /* 9160 =for apidoc newASSIGNOP 9161 9162 Constructs, checks, and returns an assignment op. C<left> and C<right> 9163 supply the parameters of the assignment; they are consumed by this 9164 function and become part of the constructed op tree. 9165 9166 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then 9167 a suitable conditional optree is constructed. If C<optype> is the opcode 9168 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that 9169 performs the binary operation and assigns the result to the left argument. 9170 Either way, if C<optype> is non-zero then C<flags> has no effect. 9171 9172 If C<optype> is zero, then a plain scalar or list assignment is 9173 constructed. Which type of assignment it is is automatically determined. 9174 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS> 9175 will be set automatically, and, shifted up eight bits, the eight bits 9176 of C<op_private>, except that the bit with value 1 or 2 is automatically 9177 set as required. 9178 9179 =cut 9180 */ 9181 9182 OP * 9183 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) 9184 { 9185 OP *o; 9186 I32 assign_type; 9187 9188 if (optype) { 9189 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) { 9190 right = scalar(right); 9191 return newLOGOP(optype, 0, 9192 op_lvalue(scalar(left), optype), 9193 newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right)); 9194 } 9195 else { 9196 return newBINOP(optype, OPf_STACKED, 9197 op_lvalue(scalar(left), optype), scalar(right)); 9198 } 9199 } 9200 9201 if ((assign_type = assignment_type(left)) == ASSIGN_LIST) { 9202 OP *state_var_op = NULL; 9203 static const char no_list_state[] = "Initialization of state variables" 9204 " in list currently forbidden"; 9205 OP *curop; 9206 9207 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE) 9208 left->op_private &= ~ OPpSLICEWARNING; 9209 9210 PL_modcount = 0; 9211 left = op_lvalue(left, OP_AASSIGN); 9212 curop = list(force_list(left, 1)); 9213 o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop); 9214 o->op_private = (U8)(0 | (flags >> 8)); 9215 9216 if (OP_TYPE_IS_OR_WAS(left, OP_LIST)) 9217 { 9218 OP *lop = ((LISTOP*)left)->op_first, *vop, *eop; 9219 if (!(left->op_flags & OPf_PARENS) && 9220 lop->op_type == OP_PUSHMARK && 9221 (vop = OpSIBLING(lop)) && 9222 (vop->op_type == OP_PADAV || vop->op_type == OP_PADHV) && 9223 !(vop->op_flags & OPf_PARENS) && 9224 (vop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) == 9225 (OPpLVAL_INTRO|OPpPAD_STATE) && 9226 (eop = OpSIBLING(vop)) && 9227 eop->op_type == OP_ENTERSUB && 9228 !OpHAS_SIBLING(eop)) { 9229 state_var_op = vop; 9230 } else { 9231 while (lop) { 9232 if ((lop->op_type == OP_PADSV || 9233 lop->op_type == OP_PADAV || 9234 lop->op_type == OP_PADHV || 9235 lop->op_type == OP_PADANY) 9236 && (lop->op_private & OPpPAD_STATE) 9237 ) 9238 yyerror(no_list_state); 9239 lop = OpSIBLING(lop); 9240 } 9241 } 9242 } 9243 else if ( (left->op_private & OPpLVAL_INTRO) 9244 && (left->op_private & OPpPAD_STATE) 9245 && ( left->op_type == OP_PADSV 9246 || left->op_type == OP_PADAV 9247 || left->op_type == OP_PADHV 9248 || left->op_type == OP_PADANY) 9249 ) { 9250 /* All single variable list context state assignments, hence 9251 state ($a) = ... 9252 (state $a) = ... 9253 state @a = ... 9254 state (@a) = ... 9255 (state @a) = ... 9256 state %a = ... 9257 state (%a) = ... 9258 (state %a) = ... 9259 */ 9260 if (left->op_flags & OPf_PARENS) 9261 yyerror(no_list_state); 9262 else 9263 state_var_op = left; 9264 } 9265 9266 /* optimise @a = split(...) into: 9267 * @{expr}: split(..., @{expr}) (where @a is not flattened) 9268 * @a, my @a, local @a: split(...) (where @a is attached to 9269 * the split op itself) 9270 */ 9271 9272 if ( right 9273 && right->op_type == OP_SPLIT 9274 /* don't do twice, e.g. @b = (@a = split) */ 9275 && !(right->op_private & OPpSPLIT_ASSIGN)) 9276 { 9277 OP *gvop = NULL; 9278 9279 if ( ( left->op_type == OP_RV2AV 9280 && (gvop=((UNOP*)left)->op_first)->op_type==OP_GV) 9281 || left->op_type == OP_PADAV) 9282 { 9283 /* @pkg or @lex or local @pkg' or 'my @lex' */ 9284 OP *tmpop; 9285 if (gvop) { 9286 #ifdef USE_ITHREADS 9287 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff 9288 = cPADOPx(gvop)->op_padix; 9289 cPADOPx(gvop)->op_padix = 0; /* steal it */ 9290 #else 9291 ((PMOP*)right)->op_pmreplrootu.op_pmtargetgv 9292 = MUTABLE_GV(cSVOPx(gvop)->op_sv); 9293 cSVOPx(gvop)->op_sv = NULL; /* steal it */ 9294 #endif 9295 right->op_private |= 9296 left->op_private & OPpOUR_INTRO; 9297 } 9298 else { 9299 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff = left->op_targ; 9300 left->op_targ = 0; /* steal it */ 9301 right->op_private |= OPpSPLIT_LEX; 9302 } 9303 right->op_private |= left->op_private & OPpLVAL_INTRO; 9304 9305 detach_split: 9306 tmpop = cUNOPo->op_first; /* to list (nulled) */ 9307 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */ 9308 assert(OpSIBLING(tmpop) == right); 9309 assert(!OpHAS_SIBLING(right)); 9310 /* detach the split subtreee from the o tree, 9311 * then free the residual o tree */ 9312 op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL); 9313 op_free(o); /* blow off assign */ 9314 right->op_private |= OPpSPLIT_ASSIGN; 9315 right->op_flags &= ~OPf_WANT; 9316 /* "I don't know and I don't care." */ 9317 return right; 9318 } 9319 else if (left->op_type == OP_RV2AV) { 9320 /* @{expr} */ 9321 9322 OP *pushop = cUNOPx(cBINOPo->op_last)->op_first; 9323 assert(OpSIBLING(pushop) == left); 9324 /* Detach the array ... */ 9325 op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL); 9326 /* ... and attach it to the split. */ 9327 op_sibling_splice(right, cLISTOPx(right)->op_last, 9328 0, left); 9329 right->op_flags |= OPf_STACKED; 9330 /* Detach split and expunge aassign as above. */ 9331 goto detach_split; 9332 } 9333 else if (PL_modcount < RETURN_UNLIMITED_NUMBER && 9334 ((LISTOP*)right)->op_last->op_type == OP_CONST) 9335 { 9336 /* convert split(...,0) to split(..., PL_modcount+1) */ 9337 SV ** const svp = 9338 &((SVOP*)((LISTOP*)right)->op_last)->op_sv; 9339 SV * const sv = *svp; 9340 if (SvIOK(sv) && SvIVX(sv) == 0) 9341 { 9342 if (right->op_private & OPpSPLIT_IMPLIM) { 9343 /* our own SV, created in ck_split */ 9344 SvREADONLY_off(sv); 9345 sv_setiv(sv, PL_modcount+1); 9346 } 9347 else { 9348 /* SV may belong to someone else */ 9349 SvREFCNT_dec(sv); 9350 *svp = newSViv(PL_modcount+1); 9351 } 9352 } 9353 } 9354 } 9355 9356 if (state_var_op) 9357 o = S_newONCEOP(aTHX_ o, state_var_op); 9358 return o; 9359 } 9360 if (assign_type == ASSIGN_REF) 9361 return newBINOP(OP_REFASSIGN, flags, scalar(right), left); 9362 if (!right) 9363 right = newOP(OP_UNDEF, 0); 9364 if (right->op_type == OP_READLINE) { 9365 right->op_flags |= OPf_STACKED; 9366 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN), 9367 scalar(right)); 9368 } 9369 else { 9370 o = newBINOP(OP_SASSIGN, flags, 9371 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) ); 9372 } 9373 return o; 9374 } 9375 9376 /* 9377 =for apidoc newSTATEOP 9378 9379 Constructs a state op (COP). The state op is normally a C<nextstate> op, 9380 but will be a C<dbstate> op if debugging is enabled for currently-compiled 9381 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>). 9382 If C<label> is non-null, it supplies the name of a label to attach to 9383 the state op; this function takes ownership of the memory pointed at by 9384 C<label>, and will free it. C<flags> gives the eight bits of C<op_flags> 9385 for the state op. 9386 9387 If C<o> is null, the state op is returned. Otherwise the state op is 9388 combined with C<o> into a C<lineseq> list op, which is returned. C<o> 9389 is consumed by this function and becomes part of the returned op tree. 9390 9391 =cut 9392 */ 9393 9394 OP * 9395 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) 9396 { 9397 dVAR; 9398 const U32 seq = intro_my(); 9399 const U32 utf8 = flags & SVf_UTF8; 9400 COP *cop; 9401 9402 PL_parser->parsed_sub = 0; 9403 9404 flags &= ~SVf_UTF8; 9405 9406 NewOp(1101, cop, 1, COP); 9407 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) { 9408 OpTYPE_set(cop, OP_DBSTATE); 9409 } 9410 else { 9411 OpTYPE_set(cop, OP_NEXTSTATE); 9412 } 9413 cop->op_flags = (U8)flags; 9414 CopHINTS_set(cop, PL_hints); 9415 #ifdef VMS 9416 if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH; 9417 #endif 9418 cop->op_next = (OP*)cop; 9419 9420 cop->cop_seq = seq; 9421 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings); 9422 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop))); 9423 if (label) { 9424 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8); 9425 9426 PL_hints |= HINT_BLOCK_SCOPE; 9427 /* It seems that we need to defer freeing this pointer, as other parts 9428 of the grammar end up wanting to copy it after this op has been 9429 created. */ 9430 SAVEFREEPV(label); 9431 } 9432 9433 if (PL_parser->preambling != NOLINE) { 9434 CopLINE_set(cop, PL_parser->preambling); 9435 PL_parser->copline = NOLINE; 9436 } 9437 else if (PL_parser->copline == NOLINE) 9438 CopLINE_set(cop, CopLINE(PL_curcop)); 9439 else { 9440 CopLINE_set(cop, PL_parser->copline); 9441 PL_parser->copline = NOLINE; 9442 } 9443 #ifdef USE_ITHREADS 9444 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */ 9445 #else 9446 CopFILEGV_set(cop, CopFILEGV(PL_curcop)); 9447 #endif 9448 CopSTASH_set(cop, PL_curstash); 9449 9450 if (cop->op_type == OP_DBSTATE) { 9451 /* this line can have a breakpoint - store the cop in IV */ 9452 AV *av = CopFILEAVx(PL_curcop); 9453 if (av) { 9454 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE); 9455 if (svp && *svp != &PL_sv_undef ) { 9456 (void)SvIOK_on(*svp); 9457 SvIV_set(*svp, PTR2IV(cop)); 9458 } 9459 } 9460 } 9461 9462 if (flags & OPf_SPECIAL) 9463 op_null((OP*)cop); 9464 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o); 9465 } 9466 9467 /* 9468 =for apidoc newLOGOP 9469 9470 Constructs, checks, and returns a logical (flow control) op. C<type> 9471 is the opcode. C<flags> gives the eight bits of C<op_flags>, except 9472 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits, 9473 the eight bits of C<op_private>, except that the bit with value 1 is 9474 automatically set. C<first> supplies the expression controlling the 9475 flow, and C<other> supplies the side (alternate) chain of ops; they are 9476 consumed by this function and become part of the constructed op tree. 9477 9478 =cut 9479 */ 9480 9481 OP * 9482 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other) 9483 { 9484 PERL_ARGS_ASSERT_NEWLOGOP; 9485 9486 return new_logop(type, flags, &first, &other); 9487 } 9488 9489 9490 /* See if the optree o contains a single OP_CONST (plus possibly 9491 * surrounding enter/nextstate/null etc). If so, return it, else return 9492 * NULL. 9493 */ 9494 9495 STATIC OP * 9496 S_search_const(pTHX_ OP *o) 9497 { 9498 PERL_ARGS_ASSERT_SEARCH_CONST; 9499 9500 redo: 9501 switch (o->op_type) { 9502 case OP_CONST: 9503 return o; 9504 case OP_NULL: 9505 if (o->op_flags & OPf_KIDS) { 9506 o = cUNOPo->op_first; 9507 goto redo; 9508 } 9509 break; 9510 case OP_LEAVE: 9511 case OP_SCOPE: 9512 case OP_LINESEQ: 9513 { 9514 OP *kid; 9515 if (!(o->op_flags & OPf_KIDS)) 9516 return NULL; 9517 kid = cLISTOPo->op_first; 9518 9519 do { 9520 switch (kid->op_type) { 9521 case OP_ENTER: 9522 case OP_NULL: 9523 case OP_NEXTSTATE: 9524 kid = OpSIBLING(kid); 9525 break; 9526 default: 9527 if (kid != cLISTOPo->op_last) 9528 return NULL; 9529 goto last; 9530 } 9531 } while (kid); 9532 9533 if (!kid) 9534 kid = cLISTOPo->op_last; 9535 last: 9536 o = kid; 9537 goto redo; 9538 } 9539 } 9540 9541 return NULL; 9542 } 9543 9544 9545 STATIC OP * 9546 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) 9547 { 9548 dVAR; 9549 LOGOP *logop; 9550 OP *o; 9551 OP *first; 9552 OP *other; 9553 OP *cstop = NULL; 9554 int prepend_not = 0; 9555 9556 PERL_ARGS_ASSERT_NEW_LOGOP; 9557 9558 first = *firstp; 9559 other = *otherp; 9560 9561 /* [perl #59802]: Warn about things like "return $a or $b", which 9562 is parsed as "(return $a) or $b" rather than "return ($a or 9563 $b)". NB: This also applies to xor, which is why we do it 9564 here. 9565 */ 9566 switch (first->op_type) { 9567 case OP_NEXT: 9568 case OP_LAST: 9569 case OP_REDO: 9570 /* XXX: Perhaps we should emit a stronger warning for these. 9571 Even with the high-precedence operator they don't seem to do 9572 anything sensible. 9573 9574 But until we do, fall through here. 9575 */ 9576 case OP_RETURN: 9577 case OP_EXIT: 9578 case OP_DIE: 9579 case OP_GOTO: 9580 /* XXX: Currently we allow people to "shoot themselves in the 9581 foot" by explicitly writing "(return $a) or $b". 9582 9583 Warn unless we are looking at the result from folding or if 9584 the programmer explicitly grouped the operators like this. 9585 The former can occur with e.g. 9586 9587 use constant FEATURE => ( $] >= ... ); 9588 sub { not FEATURE and return or do_stuff(); } 9589 */ 9590 if (!first->op_folded && !(first->op_flags & OPf_PARENS)) 9591 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), 9592 "Possible precedence issue with control flow operator"); 9593 /* XXX: Should we optimze this to "return $a;" (i.e. remove 9594 the "or $b" part)? 9595 */ 9596 break; 9597 } 9598 9599 if (type == OP_XOR) /* Not short circuit, but here by precedence. */ 9600 return newBINOP(type, flags, scalar(first), scalar(other)); 9601 9602 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP 9603 || type == OP_CUSTOM); 9604 9605 scalarboolean(first); 9606 9607 /* search for a constant op that could let us fold the test */ 9608 if ((cstop = search_const(first))) { 9609 if (cstop->op_private & OPpCONST_STRICT) 9610 no_bareword_allowed(cstop); 9611 else if ((cstop->op_private & OPpCONST_BARE)) 9612 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional"); 9613 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) || 9614 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) || 9615 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) { 9616 /* Elide the (constant) lhs, since it can't affect the outcome */ 9617 *firstp = NULL; 9618 if (other->op_type == OP_CONST) 9619 other->op_private |= OPpCONST_SHORTCIRCUIT; 9620 op_free(first); 9621 if (other->op_type == OP_LEAVE) 9622 other = newUNOP(OP_NULL, OPf_SPECIAL, other); 9623 else if (other->op_type == OP_MATCH 9624 || other->op_type == OP_SUBST 9625 || other->op_type == OP_TRANSR 9626 || other->op_type == OP_TRANS) 9627 /* Mark the op as being unbindable with =~ */ 9628 other->op_flags |= OPf_SPECIAL; 9629 9630 other->op_folded = 1; 9631 return other; 9632 } 9633 else { 9634 /* Elide the rhs, since the outcome is entirely determined by 9635 * the (constant) lhs */ 9636 9637 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */ 9638 const OP *o2 = other; 9639 if ( ! (o2->op_type == OP_LIST 9640 && (( o2 = cUNOPx(o2)->op_first)) 9641 && o2->op_type == OP_PUSHMARK 9642 && (( o2 = OpSIBLING(o2))) ) 9643 ) 9644 o2 = other; 9645 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV 9646 || o2->op_type == OP_PADHV) 9647 && o2->op_private & OPpLVAL_INTRO 9648 && !(o2->op_private & OPpPAD_STATE)) 9649 { 9650 Perl_croak(aTHX_ "This use of my() in false conditional is " 9651 "no longer allowed"); 9652 } 9653 9654 *otherp = NULL; 9655 if (cstop->op_type == OP_CONST) 9656 cstop->op_private |= OPpCONST_SHORTCIRCUIT; 9657 op_free(other); 9658 return first; 9659 } 9660 } 9661 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR 9662 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */ 9663 { 9664 const OP * const k1 = ((UNOP*)first)->op_first; 9665 const OP * const k2 = OpSIBLING(k1); 9666 OPCODE warnop = 0; 9667 switch (first->op_type) 9668 { 9669 case OP_NULL: 9670 if (k2 && k2->op_type == OP_READLINE 9671 && (k2->op_flags & OPf_STACKED) 9672 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) 9673 { 9674 warnop = k2->op_type; 9675 } 9676 break; 9677 9678 case OP_SASSIGN: 9679 if (k1->op_type == OP_READDIR 9680 || k1->op_type == OP_GLOB 9681 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB) 9682 || k1->op_type == OP_EACH 9683 || k1->op_type == OP_AEACH) 9684 { 9685 warnop = ((k1->op_type == OP_NULL) 9686 ? (OPCODE)k1->op_targ : k1->op_type); 9687 } 9688 break; 9689 } 9690 if (warnop) { 9691 const line_t oldline = CopLINE(PL_curcop); 9692 /* This ensures that warnings are reported at the first line 9693 of the construction, not the last. */ 9694 CopLINE_set(PL_curcop, PL_parser->copline); 9695 Perl_warner(aTHX_ packWARN(WARN_MISC), 9696 "Value of %s%s can be \"0\"; test with defined()", 9697 PL_op_desc[warnop], 9698 ((warnop == OP_READLINE || warnop == OP_GLOB) 9699 ? " construct" : "() operator")); 9700 CopLINE_set(PL_curcop, oldline); 9701 } 9702 } 9703 9704 /* optimize AND and OR ops that have NOTs as children */ 9705 if (first->op_type == OP_NOT 9706 && (first->op_flags & OPf_KIDS) 9707 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */ 9708 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */ 9709 ) { 9710 if (type == OP_AND || type == OP_OR) { 9711 if (type == OP_AND) 9712 type = OP_OR; 9713 else 9714 type = OP_AND; 9715 op_null(first); 9716 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */ 9717 op_null(other); 9718 prepend_not = 1; /* prepend a NOT op later */ 9719 } 9720 } 9721 } 9722 9723 logop = alloc_LOGOP(type, first, LINKLIST(other)); 9724 logop->op_flags |= (U8)flags; 9725 logop->op_private = (U8)(1 | (flags >> 8)); 9726 9727 /* establish postfix order */ 9728 logop->op_next = LINKLIST(first); 9729 first->op_next = (OP*)logop; 9730 assert(!OpHAS_SIBLING(first)); 9731 op_sibling_splice((OP*)logop, first, 0, other); 9732 9733 CHECKOP(type,logop); 9734 9735 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 9736 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0, 9737 (OP*)logop); 9738 other->op_next = o; 9739 9740 return o; 9741 } 9742 9743 /* 9744 =for apidoc newCONDOP 9745 9746 Constructs, checks, and returns a conditional-expression (C<cond_expr>) 9747 op. C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS> 9748 will be set automatically, and, shifted up eight bits, the eight bits of 9749 C<op_private>, except that the bit with value 1 is automatically set. 9750 C<first> supplies the expression selecting between the two branches, 9751 and C<trueop> and C<falseop> supply the branches; they are consumed by 9752 this function and become part of the constructed op tree. 9753 9754 =cut 9755 */ 9756 9757 OP * 9758 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) 9759 { 9760 dVAR; 9761 LOGOP *logop; 9762 OP *start; 9763 OP *o; 9764 OP *cstop; 9765 9766 PERL_ARGS_ASSERT_NEWCONDOP; 9767 9768 if (!falseop) 9769 return newLOGOP(OP_AND, 0, first, trueop); 9770 if (!trueop) 9771 return newLOGOP(OP_OR, 0, first, falseop); 9772 9773 scalarboolean(first); 9774 if ((cstop = search_const(first))) { 9775 /* Left or right arm of the conditional? */ 9776 const bool left = SvTRUE(((SVOP*)cstop)->op_sv); 9777 OP *live = left ? trueop : falseop; 9778 OP *const dead = left ? falseop : trueop; 9779 if (cstop->op_private & OPpCONST_BARE && 9780 cstop->op_private & OPpCONST_STRICT) { 9781 no_bareword_allowed(cstop); 9782 } 9783 op_free(first); 9784 op_free(dead); 9785 if (live->op_type == OP_LEAVE) 9786 live = newUNOP(OP_NULL, OPf_SPECIAL, live); 9787 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST 9788 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR) 9789 /* Mark the op as being unbindable with =~ */ 9790 live->op_flags |= OPf_SPECIAL; 9791 live->op_folded = 1; 9792 return live; 9793 } 9794 logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop)); 9795 logop->op_flags |= (U8)flags; 9796 logop->op_private = (U8)(1 | (flags >> 8)); 9797 logop->op_next = LINKLIST(falseop); 9798 9799 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */ 9800 logop); 9801 9802 /* establish postfix order */ 9803 start = LINKLIST(first); 9804 first->op_next = (OP*)logop; 9805 9806 /* make first, trueop, falseop siblings */ 9807 op_sibling_splice((OP*)logop, first, 0, trueop); 9808 op_sibling_splice((OP*)logop, trueop, 0, falseop); 9809 9810 o = newUNOP(OP_NULL, 0, (OP*)logop); 9811 9812 trueop->op_next = falseop->op_next = o; 9813 9814 o->op_next = start; 9815 return o; 9816 } 9817 9818 /* 9819 =for apidoc newRANGE 9820 9821 Constructs and returns a C<range> op, with subordinate C<flip> and 9822 C<flop> ops. C<flags> gives the eight bits of C<op_flags> for the 9823 C<flip> op and, shifted up eight bits, the eight bits of C<op_private> 9824 for both the C<flip> and C<range> ops, except that the bit with value 9825 1 is automatically set. C<left> and C<right> supply the expressions 9826 controlling the endpoints of the range; they are consumed by this function 9827 and become part of the constructed op tree. 9828 9829 =cut 9830 */ 9831 9832 OP * 9833 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right) 9834 { 9835 LOGOP *range; 9836 OP *flip; 9837 OP *flop; 9838 OP *leftstart; 9839 OP *o; 9840 9841 PERL_ARGS_ASSERT_NEWRANGE; 9842 9843 range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right)); 9844 range->op_flags = OPf_KIDS; 9845 leftstart = LINKLIST(left); 9846 range->op_private = (U8)(1 | (flags >> 8)); 9847 9848 /* make left and right siblings */ 9849 op_sibling_splice((OP*)range, left, 0, right); 9850 9851 range->op_next = (OP*)range; 9852 flip = newUNOP(OP_FLIP, flags, (OP*)range); 9853 flop = newUNOP(OP_FLOP, 0, flip); 9854 o = newUNOP(OP_NULL, 0, flop); 9855 LINKLIST(flop); 9856 range->op_next = leftstart; 9857 9858 left->op_next = flip; 9859 right->op_next = flop; 9860 9861 range->op_targ = 9862 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0); 9863 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV); 9864 flip->op_targ = 9865 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);; 9866 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV); 9867 SvPADTMP_on(PAD_SV(flip->op_targ)); 9868 9869 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0; 9870 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0; 9871 9872 /* check barewords before they might be optimized aways */ 9873 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT) 9874 no_bareword_allowed(left); 9875 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT) 9876 no_bareword_allowed(right); 9877 9878 flip->op_next = o; 9879 if (!flip->op_private || !flop->op_private) 9880 LINKLIST(o); /* blow off optimizer unless constant */ 9881 9882 return o; 9883 } 9884 9885 /* 9886 =for apidoc newLOOPOP 9887 9888 Constructs, checks, and returns an op tree expressing a loop. This is 9889 only a loop in the control flow through the op tree; it does not have 9890 the heavyweight loop structure that allows exiting the loop by C<last> 9891 and suchlike. C<flags> gives the eight bits of C<op_flags> for the 9892 top-level op, except that some bits will be set automatically as required. 9893 C<expr> supplies the expression controlling loop iteration, and C<block> 9894 supplies the body of the loop; they are consumed by this function and 9895 become part of the constructed op tree. C<debuggable> is currently 9896 unused and should always be 1. 9897 9898 =cut 9899 */ 9900 9901 OP * 9902 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) 9903 { 9904 OP* listop; 9905 OP* o; 9906 const bool once = block && block->op_flags & OPf_SPECIAL && 9907 block->op_type == OP_NULL; 9908 9909 PERL_UNUSED_ARG(debuggable); 9910 9911 if (expr) { 9912 if (once && ( 9913 (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv)) 9914 || ( expr->op_type == OP_NOT 9915 && cUNOPx(expr)->op_first->op_type == OP_CONST 9916 && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first)) 9917 ) 9918 )) 9919 /* Return the block now, so that S_new_logop does not try to 9920 fold it away. */ 9921 { 9922 op_free(expr); 9923 return block; /* do {} while 0 does once */ 9924 } 9925 9926 if (expr->op_type == OP_READLINE 9927 || expr->op_type == OP_READDIR 9928 || expr->op_type == OP_GLOB 9929 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH 9930 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) { 9931 expr = newUNOP(OP_DEFINED, 0, 9932 newASSIGNOP(0, newDEFSVOP(), 0, expr) ); 9933 } else if (expr->op_flags & OPf_KIDS) { 9934 const OP * const k1 = ((UNOP*)expr)->op_first; 9935 const OP * const k2 = k1 ? OpSIBLING(k1) : NULL; 9936 switch (expr->op_type) { 9937 case OP_NULL: 9938 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR) 9939 && (k2->op_flags & OPf_STACKED) 9940 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) 9941 expr = newUNOP(OP_DEFINED, 0, expr); 9942 break; 9943 9944 case OP_SASSIGN: 9945 if (k1 && (k1->op_type == OP_READDIR 9946 || k1->op_type == OP_GLOB 9947 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB) 9948 || k1->op_type == OP_EACH 9949 || k1->op_type == OP_AEACH)) 9950 expr = newUNOP(OP_DEFINED, 0, expr); 9951 break; 9952 } 9953 } 9954 } 9955 9956 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar 9957 * op, in listop. This is wrong. [perl #27024] */ 9958 if (!block) 9959 block = newOP(OP_NULL, 0); 9960 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0)); 9961 o = new_logop(OP_AND, 0, &expr, &listop); 9962 9963 if (once) { 9964 ASSUME(listop); 9965 } 9966 9967 if (listop) 9968 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o); 9969 9970 if (once && o != listop) 9971 { 9972 assert(cUNOPo->op_first->op_type == OP_AND 9973 || cUNOPo->op_first->op_type == OP_OR); 9974 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other; 9975 } 9976 9977 if (o == listop) 9978 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */ 9979 9980 o->op_flags |= flags; 9981 o = op_scope(o); 9982 o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/ 9983 return o; 9984 } 9985 9986 /* 9987 =for apidoc newWHILEOP 9988 9989 Constructs, checks, and returns an op tree expressing a C<while> loop. 9990 This is a heavyweight loop, with structure that allows exiting the loop 9991 by C<last> and suchlike. 9992 9993 C<loop> is an optional preconstructed C<enterloop> op to use in the 9994 loop; if it is null then a suitable op will be constructed automatically. 9995 C<expr> supplies the loop's controlling expression. C<block> supplies the 9996 main body of the loop, and C<cont> optionally supplies a C<continue> block 9997 that operates as a second half of the body. All of these optree inputs 9998 are consumed by this function and become part of the constructed op tree. 9999 10000 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop> 10001 op and, shifted up eight bits, the eight bits of C<op_private> for 10002 the C<leaveloop> op, except that (in both cases) some bits will be set 10003 automatically. C<debuggable> is currently unused and should always be 1. 10004 C<has_my> can be supplied as true to force the 10005 loop body to be enclosed in its own scope. 10006 10007 =cut 10008 */ 10009 10010 OP * 10011 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, 10012 OP *expr, OP *block, OP *cont, I32 has_my) 10013 { 10014 dVAR; 10015 OP *redo; 10016 OP *next = NULL; 10017 OP *listop; 10018 OP *o; 10019 U8 loopflags = 0; 10020 10021 PERL_UNUSED_ARG(debuggable); 10022 10023 if (expr) { 10024 if (expr->op_type == OP_READLINE 10025 || expr->op_type == OP_READDIR 10026 || expr->op_type == OP_GLOB 10027 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH 10028 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) { 10029 expr = newUNOP(OP_DEFINED, 0, 10030 newASSIGNOP(0, newDEFSVOP(), 0, expr) ); 10031 } else if (expr->op_flags & OPf_KIDS) { 10032 const OP * const k1 = ((UNOP*)expr)->op_first; 10033 const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL; 10034 switch (expr->op_type) { 10035 case OP_NULL: 10036 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR) 10037 && (k2->op_flags & OPf_STACKED) 10038 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) 10039 expr = newUNOP(OP_DEFINED, 0, expr); 10040 break; 10041 10042 case OP_SASSIGN: 10043 if (k1 && (k1->op_type == OP_READDIR 10044 || k1->op_type == OP_GLOB 10045 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB) 10046 || k1->op_type == OP_EACH 10047 || k1->op_type == OP_AEACH)) 10048 expr = newUNOP(OP_DEFINED, 0, expr); 10049 break; 10050 } 10051 } 10052 } 10053 10054 if (!block) 10055 block = newOP(OP_NULL, 0); 10056 else if (cont || has_my) { 10057 block = op_scope(block); 10058 } 10059 10060 if (cont) { 10061 next = LINKLIST(cont); 10062 } 10063 if (expr) { 10064 OP * const unstack = newOP(OP_UNSTACK, 0); 10065 if (!next) 10066 next = unstack; 10067 cont = op_append_elem(OP_LINESEQ, cont, unstack); 10068 } 10069 10070 assert(block); 10071 listop = op_append_list(OP_LINESEQ, block, cont); 10072 assert(listop); 10073 redo = LINKLIST(listop); 10074 10075 if (expr) { 10076 scalar(listop); 10077 o = new_logop(OP_AND, 0, &expr, &listop); 10078 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) { 10079 op_free((OP*)loop); 10080 return expr; /* listop already freed by new_logop */ 10081 } 10082 if (listop) 10083 ((LISTOP*)listop)->op_last->op_next = 10084 (o == listop ? redo : LINKLIST(o)); 10085 } 10086 else 10087 o = listop; 10088 10089 if (!loop) { 10090 NewOp(1101,loop,1,LOOP); 10091 OpTYPE_set(loop, OP_ENTERLOOP); 10092 loop->op_private = 0; 10093 loop->op_next = (OP*)loop; 10094 } 10095 10096 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o); 10097 10098 loop->op_redoop = redo; 10099 loop->op_lastop = o; 10100 o->op_private |= loopflags; 10101 10102 if (next) 10103 loop->op_nextop = next; 10104 else 10105 loop->op_nextop = o; 10106 10107 o->op_flags |= flags; 10108 o->op_private |= (flags >> 8); 10109 return o; 10110 } 10111 10112 /* 10113 =for apidoc newFOROP 10114 10115 Constructs, checks, and returns an op tree expressing a C<foreach> 10116 loop (iteration through a list of values). This is a heavyweight loop, 10117 with structure that allows exiting the loop by C<last> and suchlike. 10118 10119 C<sv> optionally supplies the variable that will be aliased to each 10120 item in turn; if null, it defaults to C<$_>. 10121 C<expr> supplies the list of values to iterate over. C<block> supplies 10122 the main body of the loop, and C<cont> optionally supplies a C<continue> 10123 block that operates as a second half of the body. All of these optree 10124 inputs are consumed by this function and become part of the constructed 10125 op tree. 10126 10127 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop> 10128 op and, shifted up eight bits, the eight bits of C<op_private> for 10129 the C<leaveloop> op, except that (in both cases) some bits will be set 10130 automatically. 10131 10132 =cut 10133 */ 10134 10135 OP * 10136 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) 10137 { 10138 dVAR; 10139 LOOP *loop; 10140 OP *wop; 10141 PADOFFSET padoff = 0; 10142 I32 iterflags = 0; 10143 I32 iterpflags = 0; 10144 10145 PERL_ARGS_ASSERT_NEWFOROP; 10146 10147 if (sv) { 10148 if (sv->op_type == OP_RV2SV) { /* symbol table variable */ 10149 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */ 10150 OpTYPE_set(sv, OP_RV2GV); 10151 10152 /* The op_type check is needed to prevent a possible segfault 10153 * if the loop variable is undeclared and 'strict vars' is in 10154 * effect. This is illegal but is nonetheless parsed, so we 10155 * may reach this point with an OP_CONST where we're expecting 10156 * an OP_GV. 10157 */ 10158 if (cUNOPx(sv)->op_first->op_type == OP_GV 10159 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv) 10160 iterpflags |= OPpITER_DEF; 10161 } 10162 else if (sv->op_type == OP_PADSV) { /* private variable */ 10163 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */ 10164 padoff = sv->op_targ; 10165 sv->op_targ = 0; 10166 op_free(sv); 10167 sv = NULL; 10168 PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX); 10169 } 10170 else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN) 10171 NOOP; 10172 else 10173 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]); 10174 if (padoff) { 10175 PADNAME * const pn = PAD_COMPNAME(padoff); 10176 const char * const name = PadnamePV(pn); 10177 10178 if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_') 10179 iterpflags |= OPpITER_DEF; 10180 } 10181 } 10182 else { 10183 sv = newGVOP(OP_GV, 0, PL_defgv); 10184 iterpflags |= OPpITER_DEF; 10185 } 10186 10187 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) { 10188 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART); 10189 iterflags |= OPf_STACKED; 10190 } 10191 else if (expr->op_type == OP_NULL && 10192 (expr->op_flags & OPf_KIDS) && 10193 ((BINOP*)expr)->op_first->op_type == OP_FLOP) 10194 { 10195 /* Basically turn for($x..$y) into the same as for($x,$y), but we 10196 * set the STACKED flag to indicate that these values are to be 10197 * treated as min/max values by 'pp_enteriter'. 10198 */ 10199 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first; 10200 LOGOP* const range = (LOGOP*) flip->op_first; 10201 OP* const left = range->op_first; 10202 OP* const right = OpSIBLING(left); 10203 LISTOP* listop; 10204 10205 range->op_flags &= ~OPf_KIDS; 10206 /* detach range's children */ 10207 op_sibling_splice((OP*)range, NULL, -1, NULL); 10208 10209 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right); 10210 listop->op_first->op_next = range->op_next; 10211 left->op_next = range->op_other; 10212 right->op_next = (OP*)listop; 10213 listop->op_next = listop->op_first; 10214 10215 op_free(expr); 10216 expr = (OP*)(listop); 10217 op_null(expr); 10218 iterflags |= OPf_STACKED; 10219 } 10220 else { 10221 expr = op_lvalue(force_list(expr, 1), OP_GREPSTART); 10222 } 10223 10224 loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags, 10225 op_append_elem(OP_LIST, list(expr), 10226 scalar(sv))); 10227 assert(!loop->op_next); 10228 /* for my $x () sets OPpLVAL_INTRO; 10229 * for our $x () sets OPpOUR_INTRO */ 10230 loop->op_private = (U8)iterpflags; 10231 10232 /* upgrade loop from a LISTOP to a LOOPOP; 10233 * keep it in-place if there's space */ 10234 if (loop->op_slabbed 10235 && OpSLOT(loop)->opslot_size 10236 < SIZE_TO_PSIZE(sizeof(LOOP)) + OPSLOT_HEADER_P) 10237 { 10238 /* no space; allocate new op */ 10239 LOOP *tmp; 10240 NewOp(1234,tmp,1,LOOP); 10241 Copy(loop,tmp,1,LISTOP); 10242 assert(loop->op_last->op_sibparent == (OP*)loop); 10243 OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */ 10244 S_op_destroy(aTHX_ (OP*)loop); 10245 loop = tmp; 10246 } 10247 else if (!loop->op_slabbed) 10248 { 10249 /* loop was malloc()ed */ 10250 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP)); 10251 OpLASTSIB_set(loop->op_last, (OP*)loop); 10252 } 10253 loop->op_targ = padoff; 10254 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0); 10255 return wop; 10256 } 10257 10258 /* 10259 =for apidoc newLOOPEX 10260 10261 Constructs, checks, and returns a loop-exiting op (such as C<goto> 10262 or C<last>). C<type> is the opcode. C<label> supplies the parameter 10263 determining the target of the op; it is consumed by this function and 10264 becomes part of the constructed op tree. 10265 10266 =cut 10267 */ 10268 10269 OP* 10270 Perl_newLOOPEX(pTHX_ I32 type, OP *label) 10271 { 10272 OP *o = NULL; 10273 10274 PERL_ARGS_ASSERT_NEWLOOPEX; 10275 10276 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP 10277 || type == OP_CUSTOM); 10278 10279 if (type != OP_GOTO) { 10280 /* "last()" means "last" */ 10281 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) { 10282 o = newOP(type, OPf_SPECIAL); 10283 } 10284 } 10285 else { 10286 /* Check whether it's going to be a goto &function */ 10287 if (label->op_type == OP_ENTERSUB 10288 && !(label->op_flags & OPf_STACKED)) 10289 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN)); 10290 } 10291 10292 /* Check for a constant argument */ 10293 if (label->op_type == OP_CONST) { 10294 SV * const sv = ((SVOP *)label)->op_sv; 10295 STRLEN l; 10296 const char *s = SvPV_const(sv,l); 10297 if (l == strlen(s)) { 10298 o = newPVOP(type, 10299 SvUTF8(((SVOP*)label)->op_sv), 10300 savesharedpv( 10301 SvPV_nolen_const(((SVOP*)label)->op_sv))); 10302 } 10303 } 10304 10305 /* If we have already created an op, we do not need the label. */ 10306 if (o) 10307 op_free(label); 10308 else o = newUNOP(type, OPf_STACKED, label); 10309 10310 PL_hints |= HINT_BLOCK_SCOPE; 10311 return o; 10312 } 10313 10314 /* if the condition is a literal array or hash 10315 (or @{ ... } etc), make a reference to it. 10316 */ 10317 STATIC OP * 10318 S_ref_array_or_hash(pTHX_ OP *cond) 10319 { 10320 if (cond 10321 && (cond->op_type == OP_RV2AV 10322 || cond->op_type == OP_PADAV 10323 || cond->op_type == OP_RV2HV 10324 || cond->op_type == OP_PADHV)) 10325 10326 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN)); 10327 10328 else if(cond 10329 && (cond->op_type == OP_ASLICE 10330 || cond->op_type == OP_KVASLICE 10331 || cond->op_type == OP_HSLICE 10332 || cond->op_type == OP_KVHSLICE)) { 10333 10334 /* anonlist now needs a list from this op, was previously used in 10335 * scalar context */ 10336 cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF); 10337 cond->op_flags |= OPf_WANT_LIST; 10338 10339 return newANONLIST(op_lvalue(cond, OP_ANONLIST)); 10340 } 10341 10342 else 10343 return cond; 10344 } 10345 10346 /* These construct the optree fragments representing given() 10347 and when() blocks. 10348 10349 entergiven and enterwhen are LOGOPs; the op_other pointer 10350 points up to the associated leave op. We need this so we 10351 can put it in the context and make break/continue work. 10352 (Also, of course, pp_enterwhen will jump straight to 10353 op_other if the match fails.) 10354 */ 10355 10356 STATIC OP * 10357 S_newGIVWHENOP(pTHX_ OP *cond, OP *block, 10358 I32 enter_opcode, I32 leave_opcode, 10359 PADOFFSET entertarg) 10360 { 10361 dVAR; 10362 LOGOP *enterop; 10363 OP *o; 10364 10365 PERL_ARGS_ASSERT_NEWGIVWHENOP; 10366 PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */ 10367 10368 enterop = alloc_LOGOP(enter_opcode, block, NULL); 10369 enterop->op_targ = 0; 10370 enterop->op_private = 0; 10371 10372 o = newUNOP(leave_opcode, 0, (OP *) enterop); 10373 10374 if (cond) { 10375 /* prepend cond if we have one */ 10376 op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond)); 10377 10378 o->op_next = LINKLIST(cond); 10379 cond->op_next = (OP *) enterop; 10380 } 10381 else { 10382 /* This is a default {} block */ 10383 enterop->op_flags |= OPf_SPECIAL; 10384 o ->op_flags |= OPf_SPECIAL; 10385 10386 o->op_next = (OP *) enterop; 10387 } 10388 10389 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since 10390 entergiven and enterwhen both 10391 use ck_null() */ 10392 10393 enterop->op_next = LINKLIST(block); 10394 block->op_next = enterop->op_other = o; 10395 10396 return o; 10397 } 10398 10399 10400 /* For the purposes of 'when(implied_smartmatch)' 10401 * versus 'when(boolean_expression)', 10402 * does this look like a boolean operation? For these purposes 10403 a boolean operation is: 10404 - a subroutine call [*] 10405 - a logical connective 10406 - a comparison operator 10407 - a filetest operator, with the exception of -s -M -A -C 10408 - defined(), exists() or eof() 10409 - /$re/ or $foo =~ /$re/ 10410 10411 [*] possibly surprising 10412 */ 10413 STATIC bool 10414 S_looks_like_bool(pTHX_ const OP *o) 10415 { 10416 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL; 10417 10418 switch(o->op_type) { 10419 case OP_OR: 10420 case OP_DOR: 10421 return looks_like_bool(cLOGOPo->op_first); 10422 10423 case OP_AND: 10424 { 10425 OP* sibl = OpSIBLING(cLOGOPo->op_first); 10426 ASSUME(sibl); 10427 return ( 10428 looks_like_bool(cLOGOPo->op_first) 10429 && looks_like_bool(sibl)); 10430 } 10431 10432 case OP_NULL: 10433 case OP_SCALAR: 10434 return ( 10435 o->op_flags & OPf_KIDS 10436 && looks_like_bool(cUNOPo->op_first)); 10437 10438 case OP_ENTERSUB: 10439 10440 case OP_NOT: case OP_XOR: 10441 10442 case OP_EQ: case OP_NE: case OP_LT: 10443 case OP_GT: case OP_LE: case OP_GE: 10444 10445 case OP_I_EQ: case OP_I_NE: case OP_I_LT: 10446 case OP_I_GT: case OP_I_LE: case OP_I_GE: 10447 10448 case OP_SEQ: case OP_SNE: case OP_SLT: 10449 case OP_SGT: case OP_SLE: case OP_SGE: 10450 10451 case OP_SMARTMATCH: 10452 10453 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC: 10454 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC: 10455 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED: 10456 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR: 10457 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR: 10458 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID: 10459 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY: 10460 case OP_FTTEXT: case OP_FTBINARY: 10461 10462 case OP_DEFINED: case OP_EXISTS: 10463 case OP_MATCH: case OP_EOF: 10464 10465 case OP_FLOP: 10466 10467 return TRUE; 10468 10469 case OP_INDEX: 10470 case OP_RINDEX: 10471 /* optimised-away (index() != -1) or similar comparison */ 10472 if (o->op_private & OPpTRUEBOOL) 10473 return TRUE; 10474 return FALSE; 10475 10476 case OP_CONST: 10477 /* Detect comparisons that have been optimized away */ 10478 if (cSVOPo->op_sv == &PL_sv_yes 10479 || cSVOPo->op_sv == &PL_sv_no) 10480 10481 return TRUE; 10482 else 10483 return FALSE; 10484 /* FALLTHROUGH */ 10485 default: 10486 return FALSE; 10487 } 10488 } 10489 10490 10491 /* 10492 =for apidoc newGIVENOP 10493 10494 Constructs, checks, and returns an op tree expressing a C<given> block. 10495 C<cond> supplies the expression to whose value C<$_> will be locally 10496 aliased, and C<block> supplies the body of the C<given> construct; they 10497 are consumed by this function and become part of the constructed op tree. 10498 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_). 10499 10500 =cut 10501 */ 10502 10503 OP * 10504 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off) 10505 { 10506 PERL_ARGS_ASSERT_NEWGIVENOP; 10507 PERL_UNUSED_ARG(defsv_off); 10508 10509 assert(!defsv_off); 10510 return newGIVWHENOP( 10511 ref_array_or_hash(cond), 10512 block, 10513 OP_ENTERGIVEN, OP_LEAVEGIVEN, 10514 0); 10515 } 10516 10517 /* 10518 =for apidoc newWHENOP 10519 10520 Constructs, checks, and returns an op tree expressing a C<when> block. 10521 C<cond> supplies the test expression, and C<block> supplies the block 10522 that will be executed if the test evaluates to true; they are consumed 10523 by this function and become part of the constructed op tree. C<cond> 10524 will be interpreted DWIMically, often as a comparison against C<$_>, 10525 and may be null to generate a C<default> block. 10526 10527 =cut 10528 */ 10529 10530 OP * 10531 Perl_newWHENOP(pTHX_ OP *cond, OP *block) 10532 { 10533 const bool cond_llb = (!cond || looks_like_bool(cond)); 10534 OP *cond_op; 10535 10536 PERL_ARGS_ASSERT_NEWWHENOP; 10537 10538 if (cond_llb) 10539 cond_op = cond; 10540 else { 10541 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL, 10542 newDEFSVOP(), 10543 scalar(ref_array_or_hash(cond))); 10544 } 10545 10546 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0); 10547 } 10548 10549 /* must not conflict with SVf_UTF8 */ 10550 #define CV_CKPROTO_CURSTASH 0x1 10551 10552 void 10553 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p, 10554 const STRLEN len, const U32 flags) 10555 { 10556 SV *name = NULL, *msg; 10557 const char * cvp = SvROK(cv) 10558 ? SvTYPE(SvRV_const(cv)) == SVt_PVCV 10559 ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv)) 10560 : "" 10561 : CvPROTO(cv); 10562 STRLEN clen = CvPROTOLEN(cv), plen = len; 10563 10564 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS; 10565 10566 if (p == NULL && cvp == NULL) 10567 return; 10568 10569 if (!ckWARN_d(WARN_PROTOTYPE)) 10570 return; 10571 10572 if (p && cvp) { 10573 p = S_strip_spaces(aTHX_ p, &plen); 10574 cvp = S_strip_spaces(aTHX_ cvp, &clen); 10575 if ((flags & SVf_UTF8) == SvUTF8(cv)) { 10576 if (plen == clen && memEQ(cvp, p, plen)) 10577 return; 10578 } else { 10579 if (flags & SVf_UTF8) { 10580 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0) 10581 return; 10582 } 10583 else { 10584 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0) 10585 return; 10586 } 10587 } 10588 } 10589 10590 msg = sv_newmortal(); 10591 10592 if (gv) 10593 { 10594 if (isGV(gv)) 10595 gv_efullname3(name = sv_newmortal(), gv, NULL); 10596 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&') 10597 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP); 10598 else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) { 10599 name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash))); 10600 sv_catpvs(name, "::"); 10601 if (SvROK(gv)) { 10602 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV); 10603 assert (CvNAMED(SvRV_const(gv))); 10604 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv)))); 10605 } 10606 else sv_catsv(name, (SV *)gv); 10607 } 10608 else name = (SV *)gv; 10609 } 10610 sv_setpvs(msg, "Prototype mismatch:"); 10611 if (name) 10612 Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name)); 10613 if (cvp) 10614 Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")", 10615 UTF8fARG(SvUTF8(cv),clen,cvp) 10616 ); 10617 else 10618 sv_catpvs(msg, ": none"); 10619 sv_catpvs(msg, " vs "); 10620 if (p) 10621 Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p)); 10622 else 10623 sv_catpvs(msg, "none"); 10624 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg)); 10625 } 10626 10627 static void const_sv_xsub(pTHX_ CV* cv); 10628 static void const_av_xsub(pTHX_ CV* cv); 10629 10630 /* 10631 10632 =head1 Optree Manipulation Functions 10633 10634 =for apidoc cv_const_sv 10635 10636 If C<cv> is a constant sub eligible for inlining, returns the constant 10637 value returned by the sub. Otherwise, returns C<NULL>. 10638 10639 Constant subs can be created with C<newCONSTSUB> or as described in 10640 L<perlsub/"Constant Functions">. 10641 10642 =cut 10643 */ 10644 SV * 10645 Perl_cv_const_sv(const CV *const cv) 10646 { 10647 SV *sv; 10648 if (!cv) 10649 return NULL; 10650 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM)) 10651 return NULL; 10652 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL; 10653 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL; 10654 return sv; 10655 } 10656 10657 SV * 10658 Perl_cv_const_sv_or_av(const CV * const cv) 10659 { 10660 if (!cv) 10661 return NULL; 10662 if (SvROK(cv)) return SvRV((SV *)cv); 10663 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM); 10664 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL; 10665 } 10666 10667 /* op_const_sv: examine an optree to determine whether it's in-lineable. 10668 * Can be called in 2 ways: 10669 * 10670 * !allow_lex 10671 * look for a single OP_CONST with attached value: return the value 10672 * 10673 * allow_lex && !CvCONST(cv); 10674 * 10675 * examine the clone prototype, and if contains only a single 10676 * OP_CONST, return the value; or if it contains a single PADSV ref- 10677 * erencing an outer lexical, turn on CvCONST to indicate the CV is 10678 * a candidate for "constizing" at clone time, and return NULL. 10679 */ 10680 10681 static SV * 10682 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex) 10683 { 10684 SV *sv = NULL; 10685 bool padsv = FALSE; 10686 10687 assert(o); 10688 assert(cv); 10689 10690 for (; o; o = o->op_next) { 10691 const OPCODE type = o->op_type; 10692 10693 if (type == OP_NEXTSTATE || type == OP_LINESEQ 10694 || type == OP_NULL 10695 || type == OP_PUSHMARK) 10696 continue; 10697 if (type == OP_DBSTATE) 10698 continue; 10699 if (type == OP_LEAVESUB) 10700 break; 10701 if (sv) 10702 return NULL; 10703 if (type == OP_CONST && cSVOPo->op_sv) 10704 sv = cSVOPo->op_sv; 10705 else if (type == OP_UNDEF && !o->op_private) { 10706 sv = newSV(0); 10707 SAVEFREESV(sv); 10708 } 10709 else if (allow_lex && type == OP_PADSV) { 10710 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER) 10711 { 10712 sv = &PL_sv_undef; /* an arbitrary non-null value */ 10713 padsv = TRUE; 10714 } 10715 else 10716 return NULL; 10717 } 10718 else { 10719 return NULL; 10720 } 10721 } 10722 if (padsv) { 10723 CvCONST_on(cv); 10724 return NULL; 10725 } 10726 return sv; 10727 } 10728 10729 static void 10730 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o, 10731 PADNAME * const name, SV ** const const_svp) 10732 { 10733 assert (cv); 10734 assert (o || name); 10735 assert (const_svp); 10736 if (!block) { 10737 if (CvFLAGS(PL_compcv)) { 10738 /* might have had built-in attrs applied */ 10739 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv); 10740 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl 10741 && ckWARN(WARN_MISC)) 10742 { 10743 /* protect against fatal warnings leaking compcv */ 10744 SAVEFREESV(PL_compcv); 10745 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined"); 10746 SvREFCNT_inc_simple_void_NN(PL_compcv); 10747 } 10748 CvFLAGS(cv) |= 10749 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS 10750 & ~(CVf_LVALUE * pureperl)); 10751 } 10752 return; 10753 } 10754 10755 /* redundant check for speed: */ 10756 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) { 10757 const line_t oldline = CopLINE(PL_curcop); 10758 SV *namesv = o 10759 ? cSVOPo->op_sv 10760 : sv_2mortal(newSVpvn_utf8( 10761 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name) 10762 )); 10763 if (PL_parser && PL_parser->copline != NOLINE) 10764 /* This ensures that warnings are reported at the first 10765 line of a redefinition, not the last. */ 10766 CopLINE_set(PL_curcop, PL_parser->copline); 10767 /* protect against fatal warnings leaking compcv */ 10768 SAVEFREESV(PL_compcv); 10769 report_redefined_cv(namesv, cv, const_svp); 10770 SvREFCNT_inc_simple_void_NN(PL_compcv); 10771 CopLINE_set(PL_curcop, oldline); 10772 } 10773 SAVEFREESV(cv); 10774 return; 10775 } 10776 10777 CV * 10778 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) 10779 { 10780 CV **spot; 10781 SV **svspot; 10782 const char *ps; 10783 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */ 10784 U32 ps_utf8 = 0; 10785 CV *cv = NULL; 10786 CV *compcv = PL_compcv; 10787 SV *const_sv; 10788 PADNAME *name; 10789 PADOFFSET pax = o->op_targ; 10790 CV *outcv = CvOUTSIDE(PL_compcv); 10791 CV *clonee = NULL; 10792 HEK *hek = NULL; 10793 bool reusable = FALSE; 10794 OP *start = NULL; 10795 #ifdef PERL_DEBUG_READONLY_OPS 10796 OPSLAB *slab = NULL; 10797 #endif 10798 10799 PERL_ARGS_ASSERT_NEWMYSUB; 10800 10801 PL_hints |= HINT_BLOCK_SCOPE; 10802 10803 /* Find the pad slot for storing the new sub. 10804 We cannot use PL_comppad, as it is the pad owned by the new sub. We 10805 need to look in CvOUTSIDE and find the pad belonging to the enclos- 10806 ing sub. And then we need to dig deeper if this is a lexical from 10807 outside, as in: 10808 my sub foo; sub { sub foo { } } 10809 */ 10810 redo: 10811 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax]; 10812 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) { 10813 pax = PARENT_PAD_INDEX(name); 10814 outcv = CvOUTSIDE(outcv); 10815 assert(outcv); 10816 goto redo; 10817 } 10818 svspot = 10819 &PadARRAY(PadlistARRAY(CvPADLIST(outcv)) 10820 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax]; 10821 spot = (CV **)svspot; 10822 10823 if (!(PL_parser && PL_parser->error_count)) 10824 move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name), 0); 10825 10826 if (proto) { 10827 assert(proto->op_type == OP_CONST); 10828 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len); 10829 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv); 10830 } 10831 else 10832 ps = NULL; 10833 10834 if (proto) 10835 SAVEFREEOP(proto); 10836 if (attrs) 10837 SAVEFREEOP(attrs); 10838 10839 if (PL_parser && PL_parser->error_count) { 10840 op_free(block); 10841 SvREFCNT_dec(PL_compcv); 10842 PL_compcv = 0; 10843 goto done; 10844 } 10845 10846 if (CvDEPTH(outcv) && CvCLONE(compcv)) { 10847 cv = *spot; 10848 svspot = (SV **)(spot = &clonee); 10849 } 10850 else if (PadnameIsSTATE(name) || CvDEPTH(outcv)) 10851 cv = *spot; 10852 else { 10853 assert (SvTYPE(*spot) == SVt_PVCV); 10854 if (CvNAMED(*spot)) 10855 hek = CvNAME_HEK(*spot); 10856 else { 10857 dVAR; 10858 U32 hash; 10859 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1); 10860 CvNAME_HEK_set(*spot, hek = 10861 share_hek( 10862 PadnamePV(name)+1, 10863 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1), 10864 hash 10865 ) 10866 ); 10867 CvLEXICAL_on(*spot); 10868 } 10869 cv = PadnamePROTOCV(name); 10870 svspot = (SV **)(spot = &PadnamePROTOCV(name)); 10871 } 10872 10873 if (block) { 10874 /* This makes sub {}; work as expected. */ 10875 if (block->op_type == OP_STUB) { 10876 const line_t l = PL_parser->copline; 10877 op_free(block); 10878 block = newSTATEOP(0, NULL, 0); 10879 PL_parser->copline = l; 10880 } 10881 block = CvLVALUE(compcv) 10882 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)) 10883 ? newUNOP(OP_LEAVESUBLV, 0, 10884 op_lvalue(scalarseq(block), OP_LEAVESUBLV)) 10885 : newUNOP(OP_LEAVESUB, 0, scalarseq(block)); 10886 start = LINKLIST(block); 10887 block->op_next = 0; 10888 if (ps && !*ps && !attrs && !CvLVALUE(compcv)) 10889 const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE); 10890 else 10891 const_sv = NULL; 10892 } 10893 else 10894 const_sv = NULL; 10895 10896 if (cv) { 10897 const bool exists = CvROOT(cv) || CvXSUB(cv); 10898 10899 /* if the subroutine doesn't exist and wasn't pre-declared 10900 * with a prototype, assume it will be AUTOLOADed, 10901 * skipping the prototype check 10902 */ 10903 if (exists || SvPOK(cv)) 10904 cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len, 10905 ps_utf8); 10906 /* already defined? */ 10907 if (exists) { 10908 S_already_defined(aTHX_ cv, block, NULL, name, &const_sv); 10909 if (block) 10910 cv = NULL; 10911 else { 10912 if (attrs) 10913 goto attrs; 10914 /* just a "sub foo;" when &foo is already defined */ 10915 SAVEFREESV(compcv); 10916 goto done; 10917 } 10918 } 10919 else if (CvDEPTH(outcv) && CvCLONE(compcv)) { 10920 cv = NULL; 10921 reusable = TRUE; 10922 } 10923 } 10924 10925 if (const_sv) { 10926 SvREFCNT_inc_simple_void_NN(const_sv); 10927 SvFLAGS(const_sv) |= SVs_PADTMP; 10928 if (cv) { 10929 assert(!CvROOT(cv) && !CvCONST(cv)); 10930 cv_forget_slab(cv); 10931 } 10932 else { 10933 cv = MUTABLE_CV(newSV_type(SVt_PVCV)); 10934 CvFILE_set_from_cop(cv, PL_curcop); 10935 CvSTASH_set(cv, PL_curstash); 10936 *spot = cv; 10937 } 10938 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */ 10939 CvXSUBANY(cv).any_ptr = const_sv; 10940 CvXSUB(cv) = const_sv_xsub; 10941 CvCONST_on(cv); 10942 CvISXSUB_on(cv); 10943 PoisonPADLIST(cv); 10944 CvFLAGS(cv) |= CvMETHOD(compcv); 10945 op_free(block); 10946 SvREFCNT_dec(compcv); 10947 PL_compcv = NULL; 10948 goto setname; 10949 } 10950 10951 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to 10952 determine whether this sub definition is in the same scope as its 10953 declaration. If this sub definition is inside an inner named pack- 10954 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to 10955 the package sub. So check PadnameOUTER(name) too. 10956 */ 10957 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) { 10958 assert(!CvWEAKOUTSIDE(compcv)); 10959 SvREFCNT_dec(CvOUTSIDE(compcv)); 10960 CvWEAKOUTSIDE_on(compcv); 10961 } 10962 /* XXX else do we have a circular reference? */ 10963 10964 if (cv) { /* must reuse cv in case stub is referenced elsewhere */ 10965 /* transfer PL_compcv to cv */ 10966 if (block) { 10967 bool free_file = CvFILE(cv) && CvDYNFILE(cv); 10968 cv_flags_t preserved_flags = 10969 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED); 10970 PADLIST *const temp_padl = CvPADLIST(cv); 10971 CV *const temp_cv = CvOUTSIDE(cv); 10972 const cv_flags_t other_flags = 10973 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE); 10974 OP * const cvstart = CvSTART(cv); 10975 10976 SvPOK_off(cv); 10977 CvFLAGS(cv) = 10978 CvFLAGS(compcv) | preserved_flags; 10979 CvOUTSIDE(cv) = CvOUTSIDE(compcv); 10980 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv); 10981 CvPADLIST_set(cv, CvPADLIST(compcv)); 10982 CvOUTSIDE(compcv) = temp_cv; 10983 CvPADLIST_set(compcv, temp_padl); 10984 CvSTART(cv) = CvSTART(compcv); 10985 CvSTART(compcv) = cvstart; 10986 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE); 10987 CvFLAGS(compcv) |= other_flags; 10988 10989 if (free_file) { 10990 Safefree(CvFILE(cv)); 10991 CvFILE(cv) = NULL; 10992 } 10993 10994 /* inner references to compcv must be fixed up ... */ 10995 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv); 10996 if (PERLDB_INTER)/* Advice debugger on the new sub. */ 10997 ++PL_sub_generation; 10998 } 10999 else { 11000 /* Might have had built-in attributes applied -- propagate them. */ 11001 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS); 11002 } 11003 /* ... before we throw it away */ 11004 SvREFCNT_dec(compcv); 11005 PL_compcv = compcv = cv; 11006 } 11007 else { 11008 cv = compcv; 11009 *spot = cv; 11010 } 11011 11012 setname: 11013 CvLEXICAL_on(cv); 11014 if (!CvNAME_HEK(cv)) { 11015 if (hek) (void)share_hek_hek(hek); 11016 else { 11017 dVAR; 11018 U32 hash; 11019 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1); 11020 hek = share_hek(PadnamePV(name)+1, 11021 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1), 11022 hash); 11023 } 11024 CvNAME_HEK_set(cv, hek); 11025 } 11026 11027 if (const_sv) 11028 goto clone; 11029 11030 if (CvFILE(cv) && CvDYNFILE(cv)) 11031 Safefree(CvFILE(cv)); 11032 CvFILE_set_from_cop(cv, PL_curcop); 11033 CvSTASH_set(cv, PL_curstash); 11034 11035 if (ps) { 11036 sv_setpvn(MUTABLE_SV(cv), ps, ps_len); 11037 if (ps_utf8) 11038 SvUTF8_on(MUTABLE_SV(cv)); 11039 } 11040 11041 if (block) { 11042 /* If we assign an optree to a PVCV, then we've defined a 11043 * subroutine that the debugger could be able to set a breakpoint 11044 * in, so signal to pp_entereval that it should not throw away any 11045 * saved lines at scope exit. */ 11046 11047 PL_breakable_sub_gen++; 11048 CvROOT(cv) = block; 11049 /* The cv no longer needs to hold a refcount on the slab, as CvROOT 11050 itself has a refcount. */ 11051 CvSLABBED_off(cv); 11052 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv)); 11053 #ifdef PERL_DEBUG_READONLY_OPS 11054 slab = (OPSLAB *)CvSTART(cv); 11055 #endif 11056 S_process_optree(aTHX_ cv, block, start); 11057 } 11058 11059 attrs: 11060 if (attrs) { 11061 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */ 11062 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs); 11063 } 11064 11065 if (block) { 11066 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) { 11067 SV * const tmpstr = sv_newmortal(); 11068 GV * const db_postponed = gv_fetchpvs("DB::postponed", 11069 GV_ADDMULTI, SVt_PVHV); 11070 HV *hv; 11071 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld", 11072 CopFILE(PL_curcop), 11073 (long)PL_subline, 11074 (long)CopLINE(PL_curcop)); 11075 if (HvNAME_HEK(PL_curstash)) { 11076 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash)); 11077 sv_catpvs(tmpstr, "::"); 11078 } 11079 else 11080 sv_setpvs(tmpstr, "__ANON__::"); 11081 11082 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1, 11083 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES); 11084 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), 11085 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0); 11086 hv = GvHVn(db_postponed); 11087 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) { 11088 CV * const pcv = GvCV(db_postponed); 11089 if (pcv) { 11090 dSP; 11091 PUSHMARK(SP); 11092 XPUSHs(tmpstr); 11093 PUTBACK; 11094 call_sv(MUTABLE_SV(pcv), G_DISCARD); 11095 } 11096 } 11097 } 11098 } 11099 11100 clone: 11101 if (clonee) { 11102 assert(CvDEPTH(outcv)); 11103 spot = (CV **) 11104 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax]; 11105 if (reusable) 11106 cv_clone_into(clonee, *spot); 11107 else *spot = cv_clone(clonee); 11108 SvREFCNT_dec_NN(clonee); 11109 cv = *spot; 11110 } 11111 11112 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) { 11113 PADOFFSET depth = CvDEPTH(outcv); 11114 while (--depth) { 11115 SV *oldcv; 11116 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax]; 11117 oldcv = *svspot; 11118 *svspot = SvREFCNT_inc_simple_NN(cv); 11119 SvREFCNT_dec(oldcv); 11120 } 11121 } 11122 11123 done: 11124 if (PL_parser) 11125 PL_parser->copline = NOLINE; 11126 LEAVE_SCOPE(floor); 11127 #ifdef PERL_DEBUG_READONLY_OPS 11128 if (slab) 11129 Slab_to_ro(slab); 11130 #endif 11131 op_free(o); 11132 return cv; 11133 } 11134 11135 /* 11136 =for apidoc newATTRSUB_x 11137 11138 Construct a Perl subroutine, also performing some surrounding jobs. 11139 11140 This function is expected to be called in a Perl compilation context, 11141 and some aspects of the subroutine are taken from global variables 11142 associated with compilation. In particular, C<PL_compcv> represents 11143 the subroutine that is currently being compiled. It must be non-null 11144 when this function is called, and some aspects of the subroutine being 11145 constructed are taken from it. The constructed subroutine may actually 11146 be a reuse of the C<PL_compcv> object, but will not necessarily be so. 11147 11148 If C<block> is null then the subroutine will have no body, and for the 11149 time being it will be an error to call it. This represents a forward 11150 subroutine declaration such as S<C<sub foo ($$);>>. If C<block> is 11151 non-null then it provides the Perl code of the subroutine body, which 11152 will be executed when the subroutine is called. This body includes 11153 any argument unwrapping code resulting from a subroutine signature or 11154 similar. The pad use of the code must correspond to the pad attached 11155 to C<PL_compcv>. The code is not expected to include a C<leavesub> or 11156 C<leavesublv> op; this function will add such an op. C<block> is consumed 11157 by this function and will become part of the constructed subroutine. 11158 11159 C<proto> specifies the subroutine's prototype, unless one is supplied 11160 as an attribute (see below). If C<proto> is null, then the subroutine 11161 will not have a prototype. If C<proto> is non-null, it must point to a 11162 C<const> op whose value is a string, and the subroutine will have that 11163 string as its prototype. If a prototype is supplied as an attribute, the 11164 attribute takes precedence over C<proto>, but in that case C<proto> should 11165 preferably be null. In any case, C<proto> is consumed by this function. 11166 11167 C<attrs> supplies attributes to be applied the subroutine. A handful of 11168 attributes take effect by built-in means, being applied to C<PL_compcv> 11169 immediately when seen. Other attributes are collected up and attached 11170 to the subroutine by this route. C<attrs> may be null to supply no 11171 attributes, or point to a C<const> op for a single attribute, or point 11172 to a C<list> op whose children apart from the C<pushmark> are C<const> 11173 ops for one or more attributes. Each C<const> op must be a string, 11174 giving the attribute name optionally followed by parenthesised arguments, 11175 in the manner in which attributes appear in Perl source. The attributes 11176 will be applied to the sub by this function. C<attrs> is consumed by 11177 this function. 11178 11179 If C<o_is_gv> is false and C<o> is null, then the subroutine will 11180 be anonymous. If C<o_is_gv> is false and C<o> is non-null, then C<o> 11181 must point to a C<const> op, which will be consumed by this function, 11182 and its string value supplies a name for the subroutine. The name may 11183 be qualified or unqualified, and if it is unqualified then a default 11184 stash will be selected in some manner. If C<o_is_gv> is true, then C<o> 11185 doesn't point to an C<OP> at all, but is instead a cast pointer to a C<GV> 11186 by which the subroutine will be named. 11187 11188 If there is already a subroutine of the specified name, then the new 11189 sub will either replace the existing one in the glob or be merged with 11190 the existing one. A warning may be generated about redefinition. 11191 11192 If the subroutine has one of a few special names, such as C<BEGIN> or 11193 C<END>, then it will be claimed by the appropriate queue for automatic 11194 running of phase-related subroutines. In this case the relevant glob will 11195 be left not containing any subroutine, even if it did contain one before. 11196 In the case of C<BEGIN>, the subroutine will be executed and the reference 11197 to it disposed of before this function returns. 11198 11199 The function returns a pointer to the constructed subroutine. If the sub 11200 is anonymous then ownership of one counted reference to the subroutine 11201 is transferred to the caller. If the sub is named then the caller does 11202 not get ownership of a reference. In most such cases, where the sub 11203 has a non-phase name, the sub will be alive at the point it is returned 11204 by virtue of being contained in the glob that names it. A phase-named 11205 subroutine will usually be alive by virtue of the reference owned by the 11206 phase's automatic run queue. But a C<BEGIN> subroutine, having already 11207 been executed, will quite likely have been destroyed already by the 11208 time this function returns, making it erroneous for the caller to make 11209 any use of the returned pointer. It is the caller's responsibility to 11210 ensure that it knows which of these situations applies. 11211 11212 =cut 11213 */ 11214 11215 /* _x = extended */ 11216 CV * 11217 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, 11218 OP *block, bool o_is_gv) 11219 { 11220 GV *gv; 11221 const char *ps; 11222 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */ 11223 U32 ps_utf8 = 0; 11224 CV *cv = NULL; /* the previous CV with this name, if any */ 11225 SV *const_sv; 11226 const bool ec = PL_parser && PL_parser->error_count; 11227 /* If the subroutine has no body, no attributes, and no builtin attributes 11228 then it's just a sub declaration, and we may be able to get away with 11229 storing with a placeholder scalar in the symbol table, rather than a 11230 full CV. If anything is present then it will take a full CV to 11231 store it. */ 11232 const I32 gv_fetch_flags 11233 = ec ? GV_NOADD_NOINIT : 11234 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) 11235 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT; 11236 STRLEN namlen = 0; 11237 const char * const name = 11238 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL; 11239 bool has_name; 11240 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv); 11241 bool evanescent = FALSE; 11242 OP *start = NULL; 11243 #ifdef PERL_DEBUG_READONLY_OPS 11244 OPSLAB *slab = NULL; 11245 #endif 11246 11247 if (o_is_gv) { 11248 gv = (GV*)o; 11249 o = NULL; 11250 has_name = TRUE; 11251 } else if (name) { 11252 /* Try to optimise and avoid creating a GV. Instead, the CV’s name 11253 hek and CvSTASH pointer together can imply the GV. If the name 11254 contains a package name, then GvSTASH(CvGV(cv)) may differ from 11255 CvSTASH, so forego the optimisation if we find any. 11256 Also, we may be called from load_module at run time, so 11257 PL_curstash (which sets CvSTASH) may not point to the stash the 11258 sub is stored in. */ 11259 /* XXX This optimization is currently disabled for packages other 11260 than main, since there was too much CPAN breakage. */ 11261 const I32 flags = 11262 ec ? GV_NOADD_NOINIT 11263 : (IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop)) 11264 || PL_curstash != PL_defstash 11265 || memchr(name, ':', namlen) || memchr(name, '\'', namlen) 11266 ? gv_fetch_flags 11267 : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL; 11268 gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV); 11269 has_name = TRUE; 11270 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) { 11271 SV * const sv = sv_newmortal(); 11272 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" IVdf "]", 11273 PL_curstash ? "__ANON__" : "__ANON__::__ANON__", 11274 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); 11275 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV); 11276 has_name = TRUE; 11277 } else if (PL_curstash) { 11278 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV); 11279 has_name = FALSE; 11280 } else { 11281 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV); 11282 has_name = FALSE; 11283 } 11284 11285 if (!ec) { 11286 if (isGV(gv)) { 11287 move_proto_attr(&proto, &attrs, gv, 0); 11288 } else { 11289 assert(cSVOPo); 11290 move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv, 1); 11291 } 11292 } 11293 11294 if (proto) { 11295 assert(proto->op_type == OP_CONST); 11296 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len); 11297 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv); 11298 } 11299 else 11300 ps = NULL; 11301 11302 if (o) 11303 SAVEFREEOP(o); 11304 if (proto) 11305 SAVEFREEOP(proto); 11306 if (attrs) 11307 SAVEFREEOP(attrs); 11308 11309 if (ec) { 11310 op_free(block); 11311 11312 if (name) 11313 SvREFCNT_dec(PL_compcv); 11314 else 11315 cv = PL_compcv; 11316 11317 PL_compcv = 0; 11318 if (name && block) { 11319 const char *s = (char *) my_memrchr(name, ':', namlen); 11320 s = s ? s+1 : name; 11321 if (strEQ(s, "BEGIN")) { 11322 if (PL_in_eval & EVAL_KEEPERR) 11323 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted"); 11324 else { 11325 SV * const errsv = ERRSV; 11326 /* force display of errors found but not reported */ 11327 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted"); 11328 Perl_croak_nocontext("%" SVf, SVfARG(errsv)); 11329 } 11330 } 11331 } 11332 goto done; 11333 } 11334 11335 if (!block && SvTYPE(gv) != SVt_PVGV) { 11336 /* If we are not defining a new sub and the existing one is not a 11337 full GV + CV... */ 11338 if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) { 11339 /* We are applying attributes to an existing sub, so we need it 11340 upgraded if it is a constant. */ 11341 if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV) 11342 gv_init_pvn(gv, PL_curstash, name, namlen, 11343 SVf_UTF8 * name_is_utf8); 11344 } 11345 else { /* Maybe prototype now, and had at maximum 11346 a prototype or const/sub ref before. */ 11347 if (SvTYPE(gv) > SVt_NULL) { 11348 cv_ckproto_len_flags((const CV *)gv, 11349 o ? (const GV *)cSVOPo->op_sv : NULL, ps, 11350 ps_len, ps_utf8); 11351 } 11352 11353 if (!SvROK(gv)) { 11354 if (ps) { 11355 sv_setpvn(MUTABLE_SV(gv), ps, ps_len); 11356 if (ps_utf8) 11357 SvUTF8_on(MUTABLE_SV(gv)); 11358 } 11359 else 11360 sv_setiv(MUTABLE_SV(gv), -1); 11361 } 11362 11363 SvREFCNT_dec(PL_compcv); 11364 cv = PL_compcv = NULL; 11365 goto done; 11366 } 11367 } 11368 11369 cv = (!name || (isGV(gv) && GvCVGEN(gv))) 11370 ? NULL 11371 : isGV(gv) 11372 ? GvCV(gv) 11373 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV 11374 ? (CV *)SvRV(gv) 11375 : NULL; 11376 11377 if (block) { 11378 assert(PL_parser); 11379 /* This makes sub {}; work as expected. */ 11380 if (block->op_type == OP_STUB) { 11381 const line_t l = PL_parser->copline; 11382 op_free(block); 11383 block = newSTATEOP(0, NULL, 0); 11384 PL_parser->copline = l; 11385 } 11386 block = CvLVALUE(PL_compcv) 11387 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv) 11388 && (!isGV(gv) || !GvASSUMECV(gv))) 11389 ? newUNOP(OP_LEAVESUBLV, 0, 11390 op_lvalue(scalarseq(block), OP_LEAVESUBLV)) 11391 : newUNOP(OP_LEAVESUB, 0, scalarseq(block)); 11392 start = LINKLIST(block); 11393 block->op_next = 0; 11394 if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv)) 11395 const_sv = 11396 S_op_const_sv(aTHX_ start, PL_compcv, 11397 cBOOL(CvCLONE(PL_compcv))); 11398 else 11399 const_sv = NULL; 11400 } 11401 else 11402 const_sv = NULL; 11403 11404 if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) { 11405 cv_ckproto_len_flags((const CV *)gv, 11406 o ? (const GV *)cSVOPo->op_sv : NULL, ps, 11407 ps_len, ps_utf8|CV_CKPROTO_CURSTASH); 11408 if (SvROK(gv)) { 11409 /* All the other code for sub redefinition warnings expects the 11410 clobbered sub to be a CV. Instead of making all those code 11411 paths more complex, just inline the RV version here. */ 11412 const line_t oldline = CopLINE(PL_curcop); 11413 assert(IN_PERL_COMPILETIME); 11414 if (PL_parser && PL_parser->copline != NOLINE) 11415 /* This ensures that warnings are reported at the first 11416 line of a redefinition, not the last. */ 11417 CopLINE_set(PL_curcop, PL_parser->copline); 11418 /* protect against fatal warnings leaking compcv */ 11419 SAVEFREESV(PL_compcv); 11420 11421 if (ckWARN(WARN_REDEFINE) 11422 || ( ckWARN_d(WARN_REDEFINE) 11423 && ( !const_sv || SvRV(gv) == const_sv 11424 || sv_cmp(SvRV(gv), const_sv) ))) { 11425 assert(cSVOPo); 11426 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), 11427 "Constant subroutine %" SVf " redefined", 11428 SVfARG(cSVOPo->op_sv)); 11429 } 11430 11431 SvREFCNT_inc_simple_void_NN(PL_compcv); 11432 CopLINE_set(PL_curcop, oldline); 11433 SvREFCNT_dec(SvRV(gv)); 11434 } 11435 } 11436 11437 if (cv) { 11438 const bool exists = CvROOT(cv) || CvXSUB(cv); 11439 11440 /* if the subroutine doesn't exist and wasn't pre-declared 11441 * with a prototype, assume it will be AUTOLOADed, 11442 * skipping the prototype check 11443 */ 11444 if (exists || SvPOK(cv)) 11445 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8); 11446 /* already defined (or promised)? */ 11447 if (exists || (isGV(gv) && GvASSUMECV(gv))) { 11448 S_already_defined(aTHX_ cv, block, o, NULL, &const_sv); 11449 if (block) 11450 cv = NULL; 11451 else { 11452 if (attrs) 11453 goto attrs; 11454 /* just a "sub foo;" when &foo is already defined */ 11455 SAVEFREESV(PL_compcv); 11456 goto done; 11457 } 11458 } 11459 } 11460 11461 if (const_sv) { 11462 SvREFCNT_inc_simple_void_NN(const_sv); 11463 SvFLAGS(const_sv) |= SVs_PADTMP; 11464 if (cv) { 11465 assert(!CvROOT(cv) && !CvCONST(cv)); 11466 cv_forget_slab(cv); 11467 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */ 11468 CvXSUBANY(cv).any_ptr = const_sv; 11469 CvXSUB(cv) = const_sv_xsub; 11470 CvCONST_on(cv); 11471 CvISXSUB_on(cv); 11472 PoisonPADLIST(cv); 11473 CvFLAGS(cv) |= CvMETHOD(PL_compcv); 11474 } 11475 else { 11476 if (isGV(gv) || CvMETHOD(PL_compcv)) { 11477 if (name && isGV(gv)) 11478 GvCV_set(gv, NULL); 11479 cv = newCONSTSUB_flags( 11480 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0, 11481 const_sv 11482 ); 11483 assert(cv); 11484 assert(SvREFCNT((SV*)cv) != 0); 11485 CvFLAGS(cv) |= CvMETHOD(PL_compcv); 11486 } 11487 else { 11488 if (!SvROK(gv)) { 11489 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv); 11490 prepare_SV_for_RV((SV *)gv); 11491 SvOK_off((SV *)gv); 11492 SvROK_on(gv); 11493 } 11494 SvRV_set(gv, const_sv); 11495 } 11496 } 11497 op_free(block); 11498 SvREFCNT_dec(PL_compcv); 11499 PL_compcv = NULL; 11500 goto done; 11501 } 11502 11503 /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */ 11504 if (name && cv && *name == 'B' && strEQ(name, "BEGIN")) 11505 cv = NULL; 11506 11507 if (cv) { /* must reuse cv if autoloaded */ 11508 /* transfer PL_compcv to cv */ 11509 if (block) { 11510 bool free_file = CvFILE(cv) && CvDYNFILE(cv); 11511 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS; 11512 PADLIST *const temp_av = CvPADLIST(cv); 11513 CV *const temp_cv = CvOUTSIDE(cv); 11514 const cv_flags_t other_flags = 11515 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE); 11516 OP * const cvstart = CvSTART(cv); 11517 11518 if (isGV(gv)) { 11519 CvGV_set(cv,gv); 11520 assert(!CvCVGV_RC(cv)); 11521 assert(CvGV(cv) == gv); 11522 } 11523 else { 11524 dVAR; 11525 U32 hash; 11526 PERL_HASH(hash, name, namlen); 11527 CvNAME_HEK_set(cv, 11528 share_hek(name, 11529 name_is_utf8 11530 ? -(SSize_t)namlen 11531 : (SSize_t)namlen, 11532 hash)); 11533 } 11534 11535 SvPOK_off(cv); 11536 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs 11537 | CvNAMED(cv); 11538 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv); 11539 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv); 11540 CvPADLIST_set(cv,CvPADLIST(PL_compcv)); 11541 CvOUTSIDE(PL_compcv) = temp_cv; 11542 CvPADLIST_set(PL_compcv, temp_av); 11543 CvSTART(cv) = CvSTART(PL_compcv); 11544 CvSTART(PL_compcv) = cvstart; 11545 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE); 11546 CvFLAGS(PL_compcv) |= other_flags; 11547 11548 if (free_file) { 11549 Safefree(CvFILE(cv)); 11550 } 11551 CvFILE_set_from_cop(cv, PL_curcop); 11552 CvSTASH_set(cv, PL_curstash); 11553 11554 /* inner references to PL_compcv must be fixed up ... */ 11555 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv); 11556 if (PERLDB_INTER)/* Advice debugger on the new sub. */ 11557 ++PL_sub_generation; 11558 } 11559 else { 11560 /* Might have had built-in attributes applied -- propagate them. */ 11561 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS); 11562 } 11563 /* ... before we throw it away */ 11564 SvREFCNT_dec(PL_compcv); 11565 PL_compcv = cv; 11566 } 11567 else { 11568 cv = PL_compcv; 11569 if (name && isGV(gv)) { 11570 GvCV_set(gv, cv); 11571 GvCVGEN(gv) = 0; 11572 if (HvENAME_HEK(GvSTASH(gv))) 11573 /* sub Foo::bar { (shift)+1 } */ 11574 gv_method_changed(gv); 11575 } 11576 else if (name) { 11577 if (!SvROK(gv)) { 11578 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv); 11579 prepare_SV_for_RV((SV *)gv); 11580 SvOK_off((SV *)gv); 11581 SvROK_on(gv); 11582 } 11583 SvRV_set(gv, (SV *)cv); 11584 if (HvENAME_HEK(PL_curstash)) 11585 mro_method_changed_in(PL_curstash); 11586 } 11587 } 11588 assert(cv); 11589 assert(SvREFCNT((SV*)cv) != 0); 11590 11591 if (!CvHASGV(cv)) { 11592 if (isGV(gv)) 11593 CvGV_set(cv, gv); 11594 else { 11595 dVAR; 11596 U32 hash; 11597 PERL_HASH(hash, name, namlen); 11598 CvNAME_HEK_set(cv, share_hek(name, 11599 name_is_utf8 11600 ? -(SSize_t)namlen 11601 : (SSize_t)namlen, 11602 hash)); 11603 } 11604 CvFILE_set_from_cop(cv, PL_curcop); 11605 CvSTASH_set(cv, PL_curstash); 11606 } 11607 11608 if (ps) { 11609 sv_setpvn(MUTABLE_SV(cv), ps, ps_len); 11610 if ( ps_utf8 ) 11611 SvUTF8_on(MUTABLE_SV(cv)); 11612 } 11613 11614 if (block) { 11615 /* If we assign an optree to a PVCV, then we've defined a 11616 * subroutine that the debugger could be able to set a breakpoint 11617 * in, so signal to pp_entereval that it should not throw away any 11618 * saved lines at scope exit. */ 11619 11620 PL_breakable_sub_gen++; 11621 CvROOT(cv) = block; 11622 /* The cv no longer needs to hold a refcount on the slab, as CvROOT 11623 itself has a refcount. */ 11624 CvSLABBED_off(cv); 11625 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv)); 11626 #ifdef PERL_DEBUG_READONLY_OPS 11627 slab = (OPSLAB *)CvSTART(cv); 11628 #endif 11629 S_process_optree(aTHX_ cv, block, start); 11630 } 11631 11632 attrs: 11633 if (attrs) { 11634 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */ 11635 HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv)) 11636 ? GvSTASH(CvGV(cv)) 11637 : PL_curstash; 11638 if (!name) 11639 SAVEFREESV(cv); 11640 apply_attrs(stash, MUTABLE_SV(cv), attrs); 11641 if (!name) 11642 SvREFCNT_inc_simple_void_NN(cv); 11643 } 11644 11645 if (block && has_name) { 11646 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) { 11647 SV * const tmpstr = cv_name(cv,NULL,0); 11648 GV * const db_postponed = gv_fetchpvs("DB::postponed", 11649 GV_ADDMULTI, SVt_PVHV); 11650 HV *hv; 11651 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld", 11652 CopFILE(PL_curcop), 11653 (long)PL_subline, 11654 (long)CopLINE(PL_curcop)); 11655 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), 11656 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0); 11657 hv = GvHVn(db_postponed); 11658 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) { 11659 CV * const pcv = GvCV(db_postponed); 11660 if (pcv) { 11661 dSP; 11662 PUSHMARK(SP); 11663 XPUSHs(tmpstr); 11664 PUTBACK; 11665 call_sv(MUTABLE_SV(pcv), G_DISCARD); 11666 } 11667 } 11668 } 11669 11670 if (name) { 11671 if (PL_parser && PL_parser->error_count) 11672 clear_special_blocks(name, gv, cv); 11673 else 11674 evanescent = 11675 process_special_blocks(floor, name, gv, cv); 11676 } 11677 } 11678 assert(cv); 11679 11680 done: 11681 assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0); 11682 if (PL_parser) 11683 PL_parser->copline = NOLINE; 11684 LEAVE_SCOPE(floor); 11685 11686 assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0); 11687 if (!evanescent) { 11688 #ifdef PERL_DEBUG_READONLY_OPS 11689 if (slab) 11690 Slab_to_ro(slab); 11691 #endif 11692 if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv))) 11693 pad_add_weakref(cv); 11694 } 11695 return cv; 11696 } 11697 11698 STATIC void 11699 S_clear_special_blocks(pTHX_ const char *const fullname, 11700 GV *const gv, CV *const cv) { 11701 const char *colon; 11702 const char *name; 11703 11704 PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS; 11705 11706 colon = strrchr(fullname,':'); 11707 name = colon ? colon + 1 : fullname; 11708 11709 if ((*name == 'B' && strEQ(name, "BEGIN")) 11710 || (*name == 'E' && strEQ(name, "END")) 11711 || (*name == 'U' && strEQ(name, "UNITCHECK")) 11712 || (*name == 'C' && strEQ(name, "CHECK")) 11713 || (*name == 'I' && strEQ(name, "INIT"))) { 11714 if (!isGV(gv)) { 11715 (void)CvGV(cv); 11716 assert(isGV(gv)); 11717 } 11718 GvCV_set(gv, NULL); 11719 SvREFCNT_dec_NN(MUTABLE_SV(cv)); 11720 } 11721 } 11722 11723 /* Returns true if the sub has been freed. */ 11724 STATIC bool 11725 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, 11726 GV *const gv, 11727 CV *const cv) 11728 { 11729 const char *const colon = strrchr(fullname,':'); 11730 const char *const name = colon ? colon + 1 : fullname; 11731 11732 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS; 11733 11734 if (*name == 'B') { 11735 if (strEQ(name, "BEGIN")) { 11736 const I32 oldscope = PL_scopestack_ix; 11737 dSP; 11738 (void)CvGV(cv); 11739 if (floor) LEAVE_SCOPE(floor); 11740 ENTER; 11741 PUSHSTACKi(PERLSI_REQUIRE); 11742 SAVECOPFILE(&PL_compiling); 11743 SAVECOPLINE(&PL_compiling); 11744 SAVEVPTR(PL_curcop); 11745 11746 DEBUG_x( dump_sub(gv) ); 11747 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv)); 11748 GvCV_set(gv,0); /* cv has been hijacked */ 11749 call_list(oldscope, PL_beginav); 11750 11751 POPSTACK; 11752 LEAVE; 11753 return !PL_savebegin; 11754 } 11755 else 11756 return FALSE; 11757 } else { 11758 if (*name == 'E') { 11759 if (strEQ(name, "END")) { 11760 DEBUG_x( dump_sub(gv) ); 11761 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv)); 11762 } else 11763 return FALSE; 11764 } else if (*name == 'U') { 11765 if (strEQ(name, "UNITCHECK")) { 11766 /* It's never too late to run a unitcheck block */ 11767 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv)); 11768 } 11769 else 11770 return FALSE; 11771 } else if (*name == 'C') { 11772 if (strEQ(name, "CHECK")) { 11773 if (PL_main_start) 11774 /* diag_listed_as: Too late to run %s block */ 11775 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), 11776 "Too late to run CHECK block"); 11777 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv)); 11778 } 11779 else 11780 return FALSE; 11781 } else if (*name == 'I') { 11782 if (strEQ(name, "INIT")) { 11783 if (PL_main_start) 11784 /* diag_listed_as: Too late to run %s block */ 11785 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), 11786 "Too late to run INIT block"); 11787 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv)); 11788 } 11789 else 11790 return FALSE; 11791 } else 11792 return FALSE; 11793 DEBUG_x( dump_sub(gv) ); 11794 (void)CvGV(cv); 11795 GvCV_set(gv,0); /* cv has been hijacked */ 11796 return FALSE; 11797 } 11798 } 11799 11800 /* 11801 =for apidoc newCONSTSUB 11802 11803 Behaves like L</newCONSTSUB_flags>, except that C<name> is nul-terminated 11804 rather than of counted length, and no flags are set. (This means that 11805 C<name> is always interpreted as Latin-1.) 11806 11807 =cut 11808 */ 11809 11810 CV * 11811 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv) 11812 { 11813 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv); 11814 } 11815 11816 /* 11817 =for apidoc newCONSTSUB_flags 11818 11819 Construct a constant subroutine, also performing some surrounding 11820 jobs. A scalar constant-valued subroutine is eligible for inlining 11821 at compile-time, and in Perl code can be created by S<C<sub FOO () { 11822 123 }>>. Other kinds of constant subroutine have other treatment. 11823 11824 The subroutine will have an empty prototype and will ignore any arguments 11825 when called. Its constant behaviour is determined by C<sv>. If C<sv> 11826 is null, the subroutine will yield an empty list. If C<sv> points to a 11827 scalar, the subroutine will always yield that scalar. If C<sv> points 11828 to an array, the subroutine will always yield a list of the elements of 11829 that array in list context, or the number of elements in the array in 11830 scalar context. This function takes ownership of one counted reference 11831 to the scalar or array, and will arrange for the object to live as long 11832 as the subroutine does. If C<sv> points to a scalar then the inlining 11833 assumes that the value of the scalar will never change, so the caller 11834 must ensure that the scalar is not subsequently written to. If C<sv> 11835 points to an array then no such assumption is made, so it is ostensibly 11836 safe to mutate the array or its elements, but whether this is really 11837 supported has not been determined. 11838 11839 The subroutine will have C<CvFILE> set according to C<PL_curcop>. 11840 Other aspects of the subroutine will be left in their default state. 11841 The caller is free to mutate the subroutine beyond its initial state 11842 after this function has returned. 11843 11844 If C<name> is null then the subroutine will be anonymous, with its 11845 C<CvGV> referring to an C<__ANON__> glob. If C<name> is non-null then the 11846 subroutine will be named accordingly, referenced by the appropriate glob. 11847 C<name> is a string of length C<len> bytes giving a sigilless symbol 11848 name, in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1 11849 otherwise. The name may be either qualified or unqualified. If the 11850 name is unqualified then it defaults to being in the stash specified by 11851 C<stash> if that is non-null, or to C<PL_curstash> if C<stash> is null. 11852 The symbol is always added to the stash if necessary, with C<GV_ADDMULTI> 11853 semantics. 11854 11855 C<flags> should not have bits set other than C<SVf_UTF8>. 11856 11857 If there is already a subroutine of the specified name, then the new sub 11858 will replace the existing one in the glob. A warning may be generated 11859 about the redefinition. 11860 11861 If the subroutine has one of a few special names, such as C<BEGIN> or 11862 C<END>, then it will be claimed by the appropriate queue for automatic 11863 running of phase-related subroutines. In this case the relevant glob will 11864 be left not containing any subroutine, even if it did contain one before. 11865 Execution of the subroutine will likely be a no-op, unless C<sv> was 11866 a tied array or the caller modified the subroutine in some interesting 11867 way before it was executed. In the case of C<BEGIN>, the treatment is 11868 buggy: the sub will be executed when only half built, and may be deleted 11869 prematurely, possibly causing a crash. 11870 11871 The function returns a pointer to the constructed subroutine. If the sub 11872 is anonymous then ownership of one counted reference to the subroutine 11873 is transferred to the caller. If the sub is named then the caller does 11874 not get ownership of a reference. In most such cases, where the sub 11875 has a non-phase name, the sub will be alive at the point it is returned 11876 by virtue of being contained in the glob that names it. A phase-named 11877 subroutine will usually be alive by virtue of the reference owned by 11878 the phase's automatic run queue. A C<BEGIN> subroutine may have been 11879 destroyed already by the time this function returns, but currently bugs 11880 occur in that case before the caller gets control. It is the caller's 11881 responsibility to ensure that it knows which of these situations applies. 11882 11883 =cut 11884 */ 11885 11886 CV * 11887 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len, 11888 U32 flags, SV *sv) 11889 { 11890 CV* cv; 11891 const char *const file = CopFILE(PL_curcop); 11892 11893 ENTER; 11894 11895 if (IN_PERL_RUNTIME) { 11896 /* at runtime, it's not safe to manipulate PL_curcop: it may be 11897 * an op shared between threads. Use a non-shared COP for our 11898 * dirty work */ 11899 SAVEVPTR(PL_curcop); 11900 SAVECOMPILEWARNINGS(); 11901 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings); 11902 PL_curcop = &PL_compiling; 11903 } 11904 SAVECOPLINE(PL_curcop); 11905 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE); 11906 11907 SAVEHINTS(); 11908 PL_hints &= ~HINT_BLOCK_SCOPE; 11909 11910 if (stash) { 11911 SAVEGENERICSV(PL_curstash); 11912 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash); 11913 } 11914 11915 /* Protect sv against leakage caused by fatal warnings. */ 11916 if (sv) SAVEFREESV(sv); 11917 11918 /* file becomes the CvFILE. For an XS, it's usually static storage, 11919 and so doesn't get free()d. (It's expected to be from the C pre- 11920 processor __FILE__ directive). But we need a dynamically allocated one, 11921 and we need it to get freed. */ 11922 cv = newXS_len_flags(name, len, 11923 sv && SvTYPE(sv) == SVt_PVAV 11924 ? const_av_xsub 11925 : const_sv_xsub, 11926 file ? file : "", "", 11927 &sv, XS_DYNAMIC_FILENAME | flags); 11928 assert(cv); 11929 assert(SvREFCNT((SV*)cv) != 0); 11930 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv); 11931 CvCONST_on(cv); 11932 11933 LEAVE; 11934 11935 return cv; 11936 } 11937 11938 /* 11939 =for apidoc newXS 11940 11941 Used by C<xsubpp> to hook up XSUBs as Perl subs. C<filename> needs to be 11942 static storage, as it is used directly as CvFILE(), without a copy being made. 11943 11944 =cut 11945 */ 11946 11947 CV * 11948 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename) 11949 { 11950 PERL_ARGS_ASSERT_NEWXS; 11951 return newXS_len_flags( 11952 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0 11953 ); 11954 } 11955 11956 CV * 11957 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr, 11958 const char *const filename, const char *const proto, 11959 U32 flags) 11960 { 11961 PERL_ARGS_ASSERT_NEWXS_FLAGS; 11962 return newXS_len_flags( 11963 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags 11964 ); 11965 } 11966 11967 CV * 11968 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr) 11969 { 11970 PERL_ARGS_ASSERT_NEWXS_DEFFILE; 11971 return newXS_len_flags( 11972 name, strlen(name), subaddr, NULL, NULL, NULL, 0 11973 ); 11974 } 11975 11976 /* 11977 =for apidoc newXS_len_flags 11978 11979 Construct an XS subroutine, also performing some surrounding jobs. 11980 11981 The subroutine will have the entry point C<subaddr>. It will have 11982 the prototype specified by the nul-terminated string C<proto>, or 11983 no prototype if C<proto> is null. The prototype string is copied; 11984 the caller can mutate the supplied string afterwards. If C<filename> 11985 is non-null, it must be a nul-terminated filename, and the subroutine 11986 will have its C<CvFILE> set accordingly. By default C<CvFILE> is set to 11987 point directly to the supplied string, which must be static. If C<flags> 11988 has the C<XS_DYNAMIC_FILENAME> bit set, then a copy of the string will 11989 be taken instead. 11990 11991 Other aspects of the subroutine will be left in their default state. 11992 If anything else needs to be done to the subroutine for it to function 11993 correctly, it is the caller's responsibility to do that after this 11994 function has constructed it. However, beware of the subroutine 11995 potentially being destroyed before this function returns, as described 11996 below. 11997 11998 If C<name> is null then the subroutine will be anonymous, with its 11999 C<CvGV> referring to an C<__ANON__> glob. If C<name> is non-null then the 12000 subroutine will be named accordingly, referenced by the appropriate glob. 12001 C<name> is a string of length C<len> bytes giving a sigilless symbol name, 12002 in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1 otherwise. 12003 The name may be either qualified or unqualified, with the stash defaulting 12004 in the same manner as for C<gv_fetchpvn_flags>. C<flags> may contain 12005 flag bits understood by C<gv_fetchpvn_flags> with the same meaning as 12006 they have there, such as C<GV_ADDWARN>. The symbol is always added to 12007 the stash if necessary, with C<GV_ADDMULTI> semantics. 12008 12009 If there is already a subroutine of the specified name, then the new sub 12010 will replace the existing one in the glob. A warning may be generated 12011 about the redefinition. If the old subroutine was C<CvCONST> then the 12012 decision about whether to warn is influenced by an expectation about 12013 whether the new subroutine will become a constant of similar value. 12014 That expectation is determined by C<const_svp>. (Note that the call to 12015 this function doesn't make the new subroutine C<CvCONST> in any case; 12016 that is left to the caller.) If C<const_svp> is null then it indicates 12017 that the new subroutine will not become a constant. If C<const_svp> 12018 is non-null then it indicates that the new subroutine will become a 12019 constant, and it points to an C<SV*> that provides the constant value 12020 that the subroutine will have. 12021 12022 If the subroutine has one of a few special names, such as C<BEGIN> or 12023 C<END>, then it will be claimed by the appropriate queue for automatic 12024 running of phase-related subroutines. In this case the relevant glob will 12025 be left not containing any subroutine, even if it did contain one before. 12026 In the case of C<BEGIN>, the subroutine will be executed and the reference 12027 to it disposed of before this function returns, and also before its 12028 prototype is set. If a C<BEGIN> subroutine would not be sufficiently 12029 constructed by this function to be ready for execution then the caller 12030 must prevent this happening by giving the subroutine a different name. 12031 12032 The function returns a pointer to the constructed subroutine. If the sub 12033 is anonymous then ownership of one counted reference to the subroutine 12034 is transferred to the caller. If the sub is named then the caller does 12035 not get ownership of a reference. In most such cases, where the sub 12036 has a non-phase name, the sub will be alive at the point it is returned 12037 by virtue of being contained in the glob that names it. A phase-named 12038 subroutine will usually be alive by virtue of the reference owned by the 12039 phase's automatic run queue. But a C<BEGIN> subroutine, having already 12040 been executed, will quite likely have been destroyed already by the 12041 time this function returns, making it erroneous for the caller to make 12042 any use of the returned pointer. It is the caller's responsibility to 12043 ensure that it knows which of these situations applies. 12044 12045 =cut 12046 */ 12047 12048 CV * 12049 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len, 12050 XSUBADDR_t subaddr, const char *const filename, 12051 const char *const proto, SV **const_svp, 12052 U32 flags) 12053 { 12054 CV *cv; 12055 bool interleave = FALSE; 12056 bool evanescent = FALSE; 12057 12058 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS; 12059 12060 { 12061 GV * const gv = gv_fetchpvn( 12062 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__", 12063 name ? len : PL_curstash ? sizeof("__ANON__") - 1: 12064 sizeof("__ANON__::__ANON__") - 1, 12065 GV_ADDMULTI | flags, SVt_PVCV); 12066 12067 if ((cv = (name ? GvCV(gv) : NULL))) { 12068 if (GvCVGEN(gv)) { 12069 /* just a cached method */ 12070 SvREFCNT_dec(cv); 12071 cv = NULL; 12072 } 12073 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) { 12074 /* already defined (or promised) */ 12075 /* Redundant check that allows us to avoid creating an SV 12076 most of the time: */ 12077 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) { 12078 report_redefined_cv(newSVpvn_flags( 12079 name,len,(flags&SVf_UTF8)|SVs_TEMP 12080 ), 12081 cv, const_svp); 12082 } 12083 interleave = TRUE; 12084 ENTER; 12085 SAVEFREESV(cv); 12086 cv = NULL; 12087 } 12088 } 12089 12090 if (cv) /* must reuse cv if autoloaded */ 12091 cv_undef(cv); 12092 else { 12093 cv = MUTABLE_CV(newSV_type(SVt_PVCV)); 12094 if (name) { 12095 GvCV_set(gv,cv); 12096 GvCVGEN(gv) = 0; 12097 if (HvENAME_HEK(GvSTASH(gv))) 12098 gv_method_changed(gv); /* newXS */ 12099 } 12100 } 12101 assert(cv); 12102 assert(SvREFCNT((SV*)cv) != 0); 12103 12104 CvGV_set(cv, gv); 12105 if(filename) { 12106 /* XSUBs can't be perl lang/perl5db.pl debugged 12107 if (PERLDB_LINE_OR_SAVESRC) 12108 (void)gv_fetchfile(filename); */ 12109 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */ 12110 if (flags & XS_DYNAMIC_FILENAME) { 12111 CvDYNFILE_on(cv); 12112 CvFILE(cv) = savepv(filename); 12113 } else { 12114 /* NOTE: not copied, as it is expected to be an external constant string */ 12115 CvFILE(cv) = (char *)filename; 12116 } 12117 } else { 12118 assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename); 12119 CvFILE(cv) = (char*)PL_xsubfilename; 12120 } 12121 CvISXSUB_on(cv); 12122 CvXSUB(cv) = subaddr; 12123 #ifndef PERL_IMPLICIT_CONTEXT 12124 CvHSCXT(cv) = &PL_stack_sp; 12125 #else 12126 PoisonPADLIST(cv); 12127 #endif 12128 12129 if (name) 12130 evanescent = process_special_blocks(0, name, gv, cv); 12131 else 12132 CvANON_on(cv); 12133 } /* <- not a conditional branch */ 12134 12135 assert(cv); 12136 assert(evanescent || SvREFCNT((SV*)cv) != 0); 12137 12138 if (!evanescent) sv_setpv(MUTABLE_SV(cv), proto); 12139 if (interleave) LEAVE; 12140 assert(evanescent || SvREFCNT((SV*)cv) != 0); 12141 return cv; 12142 } 12143 12144 /* Add a stub CV to a typeglob. 12145 * This is the implementation of a forward declaration, 'sub foo';' 12146 */ 12147 12148 CV * 12149 Perl_newSTUB(pTHX_ GV *gv, bool fake) 12150 { 12151 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV)); 12152 GV *cvgv; 12153 PERL_ARGS_ASSERT_NEWSTUB; 12154 assert(!GvCVu(gv)); 12155 GvCV_set(gv, cv); 12156 GvCVGEN(gv) = 0; 12157 if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv))) 12158 gv_method_changed(gv); 12159 if (SvFAKE(gv)) { 12160 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV); 12161 SvFAKE_off(cvgv); 12162 } 12163 else cvgv = gv; 12164 CvGV_set(cv, cvgv); 12165 CvFILE_set_from_cop(cv, PL_curcop); 12166 CvSTASH_set(cv, PL_curstash); 12167 GvMULTI_on(gv); 12168 return cv; 12169 } 12170 12171 void 12172 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) 12173 { 12174 CV *cv; 12175 GV *gv; 12176 OP *root; 12177 OP *start; 12178 12179 if (PL_parser && PL_parser->error_count) { 12180 op_free(block); 12181 goto finish; 12182 } 12183 12184 gv = o 12185 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM) 12186 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM); 12187 12188 GvMULTI_on(gv); 12189 if ((cv = GvFORM(gv))) { 12190 if (ckWARN(WARN_REDEFINE)) { 12191 const line_t oldline = CopLINE(PL_curcop); 12192 if (PL_parser && PL_parser->copline != NOLINE) 12193 CopLINE_set(PL_curcop, PL_parser->copline); 12194 if (o) { 12195 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), 12196 "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv)); 12197 } else { 12198 /* diag_listed_as: Format %s redefined */ 12199 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), 12200 "Format STDOUT redefined"); 12201 } 12202 CopLINE_set(PL_curcop, oldline); 12203 } 12204 SvREFCNT_dec(cv); 12205 } 12206 cv = PL_compcv; 12207 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv); 12208 CvGV_set(cv, gv); 12209 CvFILE_set_from_cop(cv, PL_curcop); 12210 12211 12212 root = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block)); 12213 CvROOT(cv) = root; 12214 start = LINKLIST(root); 12215 root->op_next = 0; 12216 S_process_optree(aTHX_ cv, root, start); 12217 cv_forget_slab(cv); 12218 12219 finish: 12220 op_free(o); 12221 if (PL_parser) 12222 PL_parser->copline = NOLINE; 12223 LEAVE_SCOPE(floor); 12224 PL_compiling.cop_seq = 0; 12225 } 12226 12227 OP * 12228 Perl_newANONLIST(pTHX_ OP *o) 12229 { 12230 return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o); 12231 } 12232 12233 OP * 12234 Perl_newANONHASH(pTHX_ OP *o) 12235 { 12236 return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o); 12237 } 12238 12239 OP * 12240 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block) 12241 { 12242 return newANONATTRSUB(floor, proto, NULL, block); 12243 } 12244 12245 OP * 12246 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block) 12247 { 12248 SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block)); 12249 OP * anoncode = 12250 newSVOP(OP_ANONCODE, 0, 12251 cv); 12252 if (CvANONCONST(cv)) 12253 anoncode = newUNOP(OP_ANONCONST, 0, 12254 op_convert_list(OP_ENTERSUB, 12255 OPf_STACKED|OPf_WANT_SCALAR, 12256 anoncode)); 12257 return newUNOP(OP_REFGEN, 0, anoncode); 12258 } 12259 12260 OP * 12261 Perl_oopsAV(pTHX_ OP *o) 12262 { 12263 dVAR; 12264 12265 PERL_ARGS_ASSERT_OOPSAV; 12266 12267 switch (o->op_type) { 12268 case OP_PADSV: 12269 case OP_PADHV: 12270 OpTYPE_set(o, OP_PADAV); 12271 return ref(o, OP_RV2AV); 12272 12273 case OP_RV2SV: 12274 case OP_RV2HV: 12275 OpTYPE_set(o, OP_RV2AV); 12276 ref(o, OP_RV2AV); 12277 break; 12278 12279 default: 12280 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV"); 12281 break; 12282 } 12283 return o; 12284 } 12285 12286 OP * 12287 Perl_oopsHV(pTHX_ OP *o) 12288 { 12289 dVAR; 12290 12291 PERL_ARGS_ASSERT_OOPSHV; 12292 12293 switch (o->op_type) { 12294 case OP_PADSV: 12295 case OP_PADAV: 12296 OpTYPE_set(o, OP_PADHV); 12297 return ref(o, OP_RV2HV); 12298 12299 case OP_RV2SV: 12300 case OP_RV2AV: 12301 OpTYPE_set(o, OP_RV2HV); 12302 /* rv2hv steals the bottom bit for its own uses */ 12303 o->op_private &= ~OPpARG1_MASK; 12304 ref(o, OP_RV2HV); 12305 break; 12306 12307 default: 12308 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV"); 12309 break; 12310 } 12311 return o; 12312 } 12313 12314 OP * 12315 Perl_newAVREF(pTHX_ OP *o) 12316 { 12317 dVAR; 12318 12319 PERL_ARGS_ASSERT_NEWAVREF; 12320 12321 if (o->op_type == OP_PADANY) { 12322 OpTYPE_set(o, OP_PADAV); 12323 return o; 12324 } 12325 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) { 12326 Perl_croak(aTHX_ "Can't use an array as a reference"); 12327 } 12328 return newUNOP(OP_RV2AV, 0, scalar(o)); 12329 } 12330 12331 OP * 12332 Perl_newGVREF(pTHX_ I32 type, OP *o) 12333 { 12334 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT) 12335 return newUNOP(OP_NULL, 0, o); 12336 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type); 12337 } 12338 12339 OP * 12340 Perl_newHVREF(pTHX_ OP *o) 12341 { 12342 dVAR; 12343 12344 PERL_ARGS_ASSERT_NEWHVREF; 12345 12346 if (o->op_type == OP_PADANY) { 12347 OpTYPE_set(o, OP_PADHV); 12348 return o; 12349 } 12350 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) { 12351 Perl_croak(aTHX_ "Can't use a hash as a reference"); 12352 } 12353 return newUNOP(OP_RV2HV, 0, scalar(o)); 12354 } 12355 12356 OP * 12357 Perl_newCVREF(pTHX_ I32 flags, OP *o) 12358 { 12359 if (o->op_type == OP_PADANY) { 12360 dVAR; 12361 OpTYPE_set(o, OP_PADCV); 12362 } 12363 return newUNOP(OP_RV2CV, flags, scalar(o)); 12364 } 12365 12366 OP * 12367 Perl_newSVREF(pTHX_ OP *o) 12368 { 12369 dVAR; 12370 12371 PERL_ARGS_ASSERT_NEWSVREF; 12372 12373 if (o->op_type == OP_PADANY) { 12374 OpTYPE_set(o, OP_PADSV); 12375 scalar(o); 12376 return o; 12377 } 12378 return newUNOP(OP_RV2SV, 0, scalar(o)); 12379 } 12380 12381 /* Check routines. See the comments at the top of this file for details 12382 * on when these are called */ 12383 12384 OP * 12385 Perl_ck_anoncode(pTHX_ OP *o) 12386 { 12387 PERL_ARGS_ASSERT_CK_ANONCODE; 12388 12389 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type); 12390 cSVOPo->op_sv = NULL; 12391 return o; 12392 } 12393 12394 static void 12395 S_io_hints(pTHX_ OP *o) 12396 { 12397 #if O_BINARY != 0 || O_TEXT != 0 12398 HV * const table = 12399 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;; 12400 if (table) { 12401 SV **svp = hv_fetchs(table, "open_IN", FALSE); 12402 if (svp && *svp) { 12403 STRLEN len = 0; 12404 const char *d = SvPV_const(*svp, len); 12405 const I32 mode = mode_from_discipline(d, len); 12406 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */ 12407 # if O_BINARY != 0 12408 if (mode & O_BINARY) 12409 o->op_private |= OPpOPEN_IN_RAW; 12410 # endif 12411 # if O_TEXT != 0 12412 if (mode & O_TEXT) 12413 o->op_private |= OPpOPEN_IN_CRLF; 12414 # endif 12415 } 12416 12417 svp = hv_fetchs(table, "open_OUT", FALSE); 12418 if (svp && *svp) { 12419 STRLEN len = 0; 12420 const char *d = SvPV_const(*svp, len); 12421 const I32 mode = mode_from_discipline(d, len); 12422 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */ 12423 # if O_BINARY != 0 12424 if (mode & O_BINARY) 12425 o->op_private |= OPpOPEN_OUT_RAW; 12426 # endif 12427 # if O_TEXT != 0 12428 if (mode & O_TEXT) 12429 o->op_private |= OPpOPEN_OUT_CRLF; 12430 # endif 12431 } 12432 } 12433 #else 12434 PERL_UNUSED_CONTEXT; 12435 PERL_UNUSED_ARG(o); 12436 #endif 12437 } 12438 12439 OP * 12440 Perl_ck_backtick(pTHX_ OP *o) 12441 { 12442 GV *gv; 12443 OP *newop = NULL; 12444 OP *sibl; 12445 PERL_ARGS_ASSERT_CK_BACKTICK; 12446 o = ck_fun(o); 12447 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */ 12448 if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first)) 12449 && (gv = gv_override("readpipe",8))) 12450 { 12451 /* detach rest of siblings from o and its first child */ 12452 op_sibling_splice(o, cUNOPo->op_first, -1, NULL); 12453 newop = S_new_entersubop(aTHX_ gv, sibl); 12454 } 12455 else if (!(o->op_flags & OPf_KIDS)) 12456 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP()); 12457 if (newop) { 12458 op_free(o); 12459 return newop; 12460 } 12461 S_io_hints(aTHX_ o); 12462 return o; 12463 } 12464 12465 OP * 12466 Perl_ck_bitop(pTHX_ OP *o) 12467 { 12468 PERL_ARGS_ASSERT_CK_BITOP; 12469 12470 o->op_private = (U8)(PL_hints & HINT_INTEGER); 12471 12472 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */ 12473 && OP_IS_INFIX_BIT(o->op_type)) 12474 { 12475 const OP * const left = cBINOPo->op_first; 12476 const OP * const right = OpSIBLING(left); 12477 if ((OP_IS_NUMCOMPARE(left->op_type) && 12478 (left->op_flags & OPf_PARENS) == 0) || 12479 (OP_IS_NUMCOMPARE(right->op_type) && 12480 (right->op_flags & OPf_PARENS) == 0)) 12481 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE), 12482 "Possible precedence problem on bitwise %s operator", 12483 o->op_type == OP_BIT_OR 12484 ||o->op_type == OP_NBIT_OR ? "|" 12485 : o->op_type == OP_BIT_AND 12486 ||o->op_type == OP_NBIT_AND ? "&" 12487 : o->op_type == OP_BIT_XOR 12488 ||o->op_type == OP_NBIT_XOR ? "^" 12489 : o->op_type == OP_SBIT_OR ? "|." 12490 : o->op_type == OP_SBIT_AND ? "&." : "^." 12491 ); 12492 } 12493 return o; 12494 } 12495 12496 PERL_STATIC_INLINE bool 12497 is_dollar_bracket(pTHX_ const OP * const o) 12498 { 12499 const OP *kid; 12500 PERL_UNUSED_CONTEXT; 12501 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS 12502 && (kid = cUNOPx(o)->op_first) 12503 && kid->op_type == OP_GV 12504 && strEQ(GvNAME(cGVOPx_gv(kid)), "["); 12505 } 12506 12507 /* for lt, gt, le, ge, eq, ne and their i_ variants */ 12508 12509 OP * 12510 Perl_ck_cmp(pTHX_ OP *o) 12511 { 12512 bool is_eq; 12513 bool neg; 12514 bool reverse; 12515 bool iv0; 12516 OP *indexop, *constop, *start; 12517 SV *sv; 12518 IV iv; 12519 12520 PERL_ARGS_ASSERT_CK_CMP; 12521 12522 is_eq = ( o->op_type == OP_EQ 12523 || o->op_type == OP_NE 12524 || o->op_type == OP_I_EQ 12525 || o->op_type == OP_I_NE); 12526 12527 if (!is_eq && ckWARN(WARN_SYNTAX)) { 12528 const OP *kid = cUNOPo->op_first; 12529 if (kid && 12530 ( 12531 ( is_dollar_bracket(aTHX_ kid) 12532 && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST 12533 ) 12534 || ( kid->op_type == OP_CONST 12535 && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid) 12536 ) 12537 ) 12538 ) 12539 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 12540 "$[ used in %s (did you mean $] ?)", OP_DESC(o)); 12541 } 12542 12543 /* convert (index(...) == -1) and variations into 12544 * (r)index/BOOL(,NEG) 12545 */ 12546 12547 reverse = FALSE; 12548 12549 indexop = cUNOPo->op_first; 12550 constop = OpSIBLING(indexop); 12551 start = NULL; 12552 if (indexop->op_type == OP_CONST) { 12553 constop = indexop; 12554 indexop = OpSIBLING(constop); 12555 start = constop; 12556 reverse = TRUE; 12557 } 12558 12559 if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX) 12560 return o; 12561 12562 /* ($lex = index(....)) == -1 */ 12563 if (indexop->op_private & OPpTARGET_MY) 12564 return o; 12565 12566 if (constop->op_type != OP_CONST) 12567 return o; 12568 12569 sv = cSVOPx_sv(constop); 12570 if (!(sv && SvIOK_notUV(sv))) 12571 return o; 12572 12573 iv = SvIVX(sv); 12574 if (iv != -1 && iv != 0) 12575 return o; 12576 iv0 = (iv == 0); 12577 12578 if (o->op_type == OP_LT || o->op_type == OP_I_LT) { 12579 if (!(iv0 ^ reverse)) 12580 return o; 12581 neg = iv0; 12582 } 12583 else if (o->op_type == OP_LE || o->op_type == OP_I_LE) { 12584 if (iv0 ^ reverse) 12585 return o; 12586 neg = !iv0; 12587 } 12588 else if (o->op_type == OP_GE || o->op_type == OP_I_GE) { 12589 if (!(iv0 ^ reverse)) 12590 return o; 12591 neg = !iv0; 12592 } 12593 else if (o->op_type == OP_GT || o->op_type == OP_I_GT) { 12594 if (iv0 ^ reverse) 12595 return o; 12596 neg = iv0; 12597 } 12598 else if (o->op_type == OP_EQ || o->op_type == OP_I_EQ) { 12599 if (iv0) 12600 return o; 12601 neg = TRUE; 12602 } 12603 else { 12604 assert(o->op_type == OP_NE || o->op_type == OP_I_NE); 12605 if (iv0) 12606 return o; 12607 neg = FALSE; 12608 } 12609 12610 indexop->op_flags &= ~OPf_PARENS; 12611 indexop->op_flags |= (o->op_flags & OPf_PARENS); 12612 indexop->op_private |= OPpTRUEBOOL; 12613 if (neg) 12614 indexop->op_private |= OPpINDEX_BOOLNEG; 12615 /* cut out the index op and free the eq,const ops */ 12616 (void)op_sibling_splice(o, start, 1, NULL); 12617 op_free(o); 12618 12619 return indexop; 12620 } 12621 12622 12623 OP * 12624 Perl_ck_concat(pTHX_ OP *o) 12625 { 12626 const OP * const kid = cUNOPo->op_first; 12627 12628 PERL_ARGS_ASSERT_CK_CONCAT; 12629 PERL_UNUSED_CONTEXT; 12630 12631 /* reuse the padtmp returned by the concat child */ 12632 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) && 12633 !(kUNOP->op_first->op_flags & OPf_MOD)) 12634 { 12635 o->op_flags |= OPf_STACKED; 12636 o->op_private |= OPpCONCAT_NESTED; 12637 } 12638 return o; 12639 } 12640 12641 OP * 12642 Perl_ck_spair(pTHX_ OP *o) 12643 { 12644 dVAR; 12645 12646 PERL_ARGS_ASSERT_CK_SPAIR; 12647 12648 if (o->op_flags & OPf_KIDS) { 12649 OP* newop; 12650 OP* kid; 12651 OP* kidkid; 12652 const OPCODE type = o->op_type; 12653 o = modkids(ck_fun(o), type); 12654 kid = cUNOPo->op_first; 12655 kidkid = kUNOP->op_first; 12656 newop = OpSIBLING(kidkid); 12657 if (newop) { 12658 const OPCODE type = newop->op_type; 12659 if (OpHAS_SIBLING(newop)) 12660 return o; 12661 if (o->op_type == OP_REFGEN 12662 && ( type == OP_RV2CV 12663 || ( !(newop->op_flags & OPf_PARENS) 12664 && ( type == OP_RV2AV || type == OP_PADAV 12665 || type == OP_RV2HV || type == OP_PADHV)))) 12666 NOOP; /* OK (allow srefgen for \@a and \%h) */ 12667 else if (OP_GIMME(newop,0) != G_SCALAR) 12668 return o; 12669 } 12670 /* excise first sibling */ 12671 op_sibling_splice(kid, NULL, 1, NULL); 12672 op_free(kidkid); 12673 } 12674 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP, 12675 * and OP_CHOMP into OP_SCHOMP */ 12676 o->op_ppaddr = PL_ppaddr[++o->op_type]; 12677 return ck_fun(o); 12678 } 12679 12680 OP * 12681 Perl_ck_delete(pTHX_ OP *o) 12682 { 12683 PERL_ARGS_ASSERT_CK_DELETE; 12684 12685 o = ck_fun(o); 12686 o->op_private = 0; 12687 if (o->op_flags & OPf_KIDS) { 12688 OP * const kid = cUNOPo->op_first; 12689 switch (kid->op_type) { 12690 case OP_ASLICE: 12691 o->op_flags |= OPf_SPECIAL; 12692 /* FALLTHROUGH */ 12693 case OP_HSLICE: 12694 o->op_private |= OPpSLICE; 12695 break; 12696 case OP_AELEM: 12697 o->op_flags |= OPf_SPECIAL; 12698 /* FALLTHROUGH */ 12699 case OP_HELEM: 12700 break; 12701 case OP_KVASLICE: 12702 o->op_flags |= OPf_SPECIAL; 12703 /* FALLTHROUGH */ 12704 case OP_KVHSLICE: 12705 o->op_private |= OPpKVSLICE; 12706 break; 12707 default: 12708 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY " 12709 "element or slice"); 12710 } 12711 if (kid->op_private & OPpLVAL_INTRO) 12712 o->op_private |= OPpLVAL_INTRO; 12713 op_null(kid); 12714 } 12715 return o; 12716 } 12717 12718 OP * 12719 Perl_ck_eof(pTHX_ OP *o) 12720 { 12721 PERL_ARGS_ASSERT_CK_EOF; 12722 12723 if (o->op_flags & OPf_KIDS) { 12724 OP *kid; 12725 if (cLISTOPo->op_first->op_type == OP_STUB) { 12726 OP * const newop 12727 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv)); 12728 op_free(o); 12729 o = newop; 12730 } 12731 o = ck_fun(o); 12732 kid = cLISTOPo->op_first; 12733 if (kid->op_type == OP_RV2GV) 12734 kid->op_private |= OPpALLOW_FAKE; 12735 } 12736 return o; 12737 } 12738 12739 12740 OP * 12741 Perl_ck_eval(pTHX_ OP *o) 12742 { 12743 dVAR; 12744 12745 PERL_ARGS_ASSERT_CK_EVAL; 12746 12747 PL_hints |= HINT_BLOCK_SCOPE; 12748 if (o->op_flags & OPf_KIDS) { 12749 SVOP * const kid = (SVOP*)cUNOPo->op_first; 12750 assert(kid); 12751 12752 if (o->op_type == OP_ENTERTRY) { 12753 LOGOP *enter; 12754 12755 /* cut whole sibling chain free from o */ 12756 op_sibling_splice(o, NULL, -1, NULL); 12757 op_free(o); 12758 12759 enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL); 12760 12761 /* establish postfix order */ 12762 enter->op_next = (OP*)enter; 12763 12764 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid); 12765 OpTYPE_set(o, OP_LEAVETRY); 12766 enter->op_other = o; 12767 return o; 12768 } 12769 else { 12770 scalar((OP*)kid); 12771 S_set_haseval(aTHX); 12772 } 12773 } 12774 else { 12775 const U8 priv = o->op_private; 12776 op_free(o); 12777 /* the newUNOP will recursively call ck_eval(), which will handle 12778 * all the stuff at the end of this function, like adding 12779 * OP_HINTSEVAL 12780 */ 12781 return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP()); 12782 } 12783 o->op_targ = (PADOFFSET)PL_hints; 12784 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8; 12785 if ((PL_hints & HINT_LOCALIZE_HH) != 0 12786 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) { 12787 /* Store a copy of %^H that pp_entereval can pick up. */ 12788 HV *hh = hv_copy_hints_hv(GvHV(PL_hintgv)); 12789 OP *hhop; 12790 STOREFEATUREBITSHH(hh); 12791 hhop = newSVOP(OP_HINTSEVAL, 0, MUTABLE_SV(hh)); 12792 /* append hhop to only child */ 12793 op_sibling_splice(o, cUNOPo->op_first, 0, hhop); 12794 12795 o->op_private |= OPpEVAL_HAS_HH; 12796 } 12797 if (!(o->op_private & OPpEVAL_BYTES) 12798 && FEATURE_UNIEVAL_IS_ENABLED) 12799 o->op_private |= OPpEVAL_UNICODE; 12800 return o; 12801 } 12802 12803 OP * 12804 Perl_ck_exec(pTHX_ OP *o) 12805 { 12806 PERL_ARGS_ASSERT_CK_EXEC; 12807 12808 if (o->op_flags & OPf_STACKED) { 12809 OP *kid; 12810 o = ck_fun(o); 12811 kid = OpSIBLING(cUNOPo->op_first); 12812 if (kid->op_type == OP_RV2GV) 12813 op_null(kid); 12814 } 12815 else 12816 o = listkids(o); 12817 return o; 12818 } 12819 12820 OP * 12821 Perl_ck_exists(pTHX_ OP *o) 12822 { 12823 PERL_ARGS_ASSERT_CK_EXISTS; 12824 12825 o = ck_fun(o); 12826 if (o->op_flags & OPf_KIDS) { 12827 OP * const kid = cUNOPo->op_first; 12828 if (kid->op_type == OP_ENTERSUB) { 12829 (void) ref(kid, o->op_type); 12830 if (kid->op_type != OP_RV2CV 12831 && !(PL_parser && PL_parser->error_count)) 12832 Perl_croak(aTHX_ 12833 "exists argument is not a subroutine name"); 12834 o->op_private |= OPpEXISTS_SUB; 12835 } 12836 else if (kid->op_type == OP_AELEM) 12837 o->op_flags |= OPf_SPECIAL; 12838 else if (kid->op_type != OP_HELEM) 12839 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY " 12840 "element or a subroutine"); 12841 op_null(kid); 12842 } 12843 return o; 12844 } 12845 12846 OP * 12847 Perl_ck_rvconst(pTHX_ OP *o) 12848 { 12849 dVAR; 12850 SVOP * const kid = (SVOP*)cUNOPo->op_first; 12851 12852 PERL_ARGS_ASSERT_CK_RVCONST; 12853 12854 if (o->op_type == OP_RV2HV) 12855 /* rv2hv steals the bottom bit for its own uses */ 12856 o->op_private &= ~OPpARG1_MASK; 12857 12858 o->op_private |= (PL_hints & HINT_STRICT_REFS); 12859 12860 if (kid->op_type == OP_CONST) { 12861 int iscv; 12862 GV *gv; 12863 SV * const kidsv = kid->op_sv; 12864 12865 /* Is it a constant from cv_const_sv()? */ 12866 if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) { 12867 return o; 12868 } 12869 if (SvTYPE(kidsv) == SVt_PVAV) return o; 12870 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) { 12871 const char *badthing; 12872 switch (o->op_type) { 12873 case OP_RV2SV: 12874 badthing = "a SCALAR"; 12875 break; 12876 case OP_RV2AV: 12877 badthing = "an ARRAY"; 12878 break; 12879 case OP_RV2HV: 12880 badthing = "a HASH"; 12881 break; 12882 default: 12883 badthing = NULL; 12884 break; 12885 } 12886 if (badthing) 12887 Perl_croak(aTHX_ 12888 "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use", 12889 SVfARG(kidsv), badthing); 12890 } 12891 /* 12892 * This is a little tricky. We only want to add the symbol if we 12893 * didn't add it in the lexer. Otherwise we get duplicate strict 12894 * warnings. But if we didn't add it in the lexer, we must at 12895 * least pretend like we wanted to add it even if it existed before, 12896 * or we get possible typo warnings. OPpCONST_ENTERED says 12897 * whether the lexer already added THIS instance of this symbol. 12898 */ 12899 iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0; 12900 gv = gv_fetchsv(kidsv, 12901 o->op_type == OP_RV2CV 12902 && o->op_private & OPpMAY_RETURN_CONSTANT 12903 ? GV_NOEXPAND 12904 : iscv | !(kid->op_private & OPpCONST_ENTERED), 12905 iscv 12906 ? SVt_PVCV 12907 : o->op_type == OP_RV2SV 12908 ? SVt_PV 12909 : o->op_type == OP_RV2AV 12910 ? SVt_PVAV 12911 : o->op_type == OP_RV2HV 12912 ? SVt_PVHV 12913 : SVt_PVGV); 12914 if (gv) { 12915 if (!isGV(gv)) { 12916 assert(iscv); 12917 assert(SvROK(gv)); 12918 if (!(o->op_private & OPpMAY_RETURN_CONSTANT) 12919 && SvTYPE(SvRV(gv)) != SVt_PVCV) 12920 gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV); 12921 } 12922 OpTYPE_set(kid, OP_GV); 12923 SvREFCNT_dec(kid->op_sv); 12924 #ifdef USE_ITHREADS 12925 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */ 12926 STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP)); 12927 kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY); 12928 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix)); 12929 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv))); 12930 #else 12931 kid->op_sv = SvREFCNT_inc_simple_NN(gv); 12932 #endif 12933 kid->op_private = 0; 12934 /* FAKE globs in the symbol table cause weird bugs (#77810) */ 12935 SvFAKE_off(gv); 12936 } 12937 } 12938 return o; 12939 } 12940 12941 OP * 12942 Perl_ck_ftst(pTHX_ OP *o) 12943 { 12944 dVAR; 12945 const I32 type = o->op_type; 12946 12947 PERL_ARGS_ASSERT_CK_FTST; 12948 12949 if (o->op_flags & OPf_REF) { 12950 NOOP; 12951 } 12952 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) { 12953 SVOP * const kid = (SVOP*)cUNOPo->op_first; 12954 const OPCODE kidtype = kid->op_type; 12955 12956 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE) 12957 && !kid->op_folded) { 12958 OP * const newop = newGVOP(type, OPf_REF, 12959 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO)); 12960 op_free(o); 12961 return newop; 12962 } 12963 12964 if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) { 12965 SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2); 12966 if (name) { 12967 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */ 12968 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)", 12969 array_passed_to_stat, name); 12970 } 12971 else { 12972 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */ 12973 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat); 12974 } 12975 } 12976 scalar((OP *) kid); 12977 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type)) 12978 o->op_private |= OPpFT_ACCESS; 12979 if (OP_IS_FILETEST(type) 12980 && OP_IS_FILETEST(kidtype) 12981 ) { 12982 o->op_private |= OPpFT_STACKED; 12983 kid->op_private |= OPpFT_STACKING; 12984 if (kidtype == OP_FTTTY && ( 12985 !(kid->op_private & OPpFT_STACKED) 12986 || kid->op_private & OPpFT_AFTER_t 12987 )) 12988 o->op_private |= OPpFT_AFTER_t; 12989 } 12990 } 12991 else { 12992 op_free(o); 12993 if (type == OP_FTTTY) 12994 o = newGVOP(type, OPf_REF, PL_stdingv); 12995 else 12996 o = newUNOP(type, 0, newDEFSVOP()); 12997 } 12998 return o; 12999 } 13000 13001 OP * 13002 Perl_ck_fun(pTHX_ OP *o) 13003 { 13004 const int type = o->op_type; 13005 I32 oa = PL_opargs[type] >> OASHIFT; 13006 13007 PERL_ARGS_ASSERT_CK_FUN; 13008 13009 if (o->op_flags & OPf_STACKED) { 13010 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL)) 13011 oa &= ~OA_OPTIONAL; 13012 else 13013 return no_fh_allowed(o); 13014 } 13015 13016 if (o->op_flags & OPf_KIDS) { 13017 OP *prev_kid = NULL; 13018 OP *kid = cLISTOPo->op_first; 13019 I32 numargs = 0; 13020 bool seen_optional = FALSE; 13021 13022 if (kid->op_type == OP_PUSHMARK || 13023 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK)) 13024 { 13025 prev_kid = kid; 13026 kid = OpSIBLING(kid); 13027 } 13028 if (kid && kid->op_type == OP_COREARGS) { 13029 bool optional = FALSE; 13030 while (oa) { 13031 numargs++; 13032 if (oa & OA_OPTIONAL) optional = TRUE; 13033 oa = oa >> 4; 13034 } 13035 if (optional) o->op_private |= numargs; 13036 return o; 13037 } 13038 13039 while (oa) { 13040 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) { 13041 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) { 13042 kid = newDEFSVOP(); 13043 /* append kid to chain */ 13044 op_sibling_splice(o, prev_kid, 0, kid); 13045 } 13046 seen_optional = TRUE; 13047 } 13048 if (!kid) break; 13049 13050 numargs++; 13051 switch (oa & 7) { 13052 case OA_SCALAR: 13053 /* list seen where single (scalar) arg expected? */ 13054 if (numargs == 1 && !(oa >> 4) 13055 && kid->op_type == OP_LIST && type != OP_SCALAR) 13056 { 13057 return too_many_arguments_pv(o,PL_op_desc[type], 0); 13058 } 13059 if (type != OP_DELETE) scalar(kid); 13060 break; 13061 case OA_LIST: 13062 if (oa < 16) { 13063 kid = 0; 13064 continue; 13065 } 13066 else 13067 list(kid); 13068 break; 13069 case OA_AVREF: 13070 if ((type == OP_PUSH || type == OP_UNSHIFT) 13071 && !OpHAS_SIBLING(kid)) 13072 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), 13073 "Useless use of %s with no values", 13074 PL_op_desc[type]); 13075 13076 if (kid->op_type == OP_CONST 13077 && ( !SvROK(cSVOPx_sv(kid)) 13078 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV ) 13079 ) 13080 bad_type_pv(numargs, "array", o, kid); 13081 else if (kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV 13082 || kid->op_type == OP_RV2GV) { 13083 bad_type_pv(1, "array", o, kid); 13084 } 13085 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) { 13086 yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden", 13087 PL_op_desc[type]), 0); 13088 } 13089 else { 13090 op_lvalue(kid, type); 13091 } 13092 break; 13093 case OA_HVREF: 13094 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV) 13095 bad_type_pv(numargs, "hash", o, kid); 13096 op_lvalue(kid, type); 13097 break; 13098 case OA_CVREF: 13099 { 13100 /* replace kid with newop in chain */ 13101 OP * const newop = 13102 S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0); 13103 newop->op_next = newop; 13104 kid = newop; 13105 } 13106 break; 13107 case OA_FILEREF: 13108 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) { 13109 if (kid->op_type == OP_CONST && 13110 (kid->op_private & OPpCONST_BARE)) 13111 { 13112 OP * const newop = newGVOP(OP_GV, 0, 13113 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO)); 13114 /* replace kid with newop in chain */ 13115 op_sibling_splice(o, prev_kid, 1, newop); 13116 op_free(kid); 13117 kid = newop; 13118 } 13119 else if (kid->op_type == OP_READLINE) { 13120 /* neophyte patrol: open(<FH>), close(<FH>) etc. */ 13121 bad_type_pv(numargs, "HANDLE", o, kid); 13122 } 13123 else { 13124 I32 flags = OPf_SPECIAL; 13125 I32 priv = 0; 13126 PADOFFSET targ = 0; 13127 13128 /* is this op a FH constructor? */ 13129 if (is_handle_constructor(o,numargs)) { 13130 const char *name = NULL; 13131 STRLEN len = 0; 13132 U32 name_utf8 = 0; 13133 bool want_dollar = TRUE; 13134 13135 flags = 0; 13136 /* Set a flag to tell rv2gv to vivify 13137 * need to "prove" flag does not mean something 13138 * else already - NI-S 1999/05/07 13139 */ 13140 priv = OPpDEREF; 13141 if (kid->op_type == OP_PADSV) { 13142 PADNAME * const pn 13143 = PAD_COMPNAME_SV(kid->op_targ); 13144 name = PadnamePV (pn); 13145 len = PadnameLEN(pn); 13146 name_utf8 = PadnameUTF8(pn); 13147 } 13148 else if (kid->op_type == OP_RV2SV 13149 && kUNOP->op_first->op_type == OP_GV) 13150 { 13151 GV * const gv = cGVOPx_gv(kUNOP->op_first); 13152 name = GvNAME(gv); 13153 len = GvNAMELEN(gv); 13154 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0; 13155 } 13156 else if (kid->op_type == OP_AELEM 13157 || kid->op_type == OP_HELEM) 13158 { 13159 OP *firstop; 13160 OP *op = ((BINOP*)kid)->op_first; 13161 name = NULL; 13162 if (op) { 13163 SV *tmpstr = NULL; 13164 const char * const a = 13165 kid->op_type == OP_AELEM ? 13166 "[]" : "{}"; 13167 if (((op->op_type == OP_RV2AV) || 13168 (op->op_type == OP_RV2HV)) && 13169 (firstop = ((UNOP*)op)->op_first) && 13170 (firstop->op_type == OP_GV)) { 13171 /* packagevar $a[] or $h{} */ 13172 GV * const gv = cGVOPx_gv(firstop); 13173 if (gv) 13174 tmpstr = 13175 Perl_newSVpvf(aTHX_ 13176 "%s%c...%c", 13177 GvNAME(gv), 13178 a[0], a[1]); 13179 } 13180 else if (op->op_type == OP_PADAV 13181 || op->op_type == OP_PADHV) { 13182 /* lexicalvar $a[] or $h{} */ 13183 const char * const padname = 13184 PAD_COMPNAME_PV(op->op_targ); 13185 if (padname) 13186 tmpstr = 13187 Perl_newSVpvf(aTHX_ 13188 "%s%c...%c", 13189 padname + 1, 13190 a[0], a[1]); 13191 } 13192 if (tmpstr) { 13193 name = SvPV_const(tmpstr, len); 13194 name_utf8 = SvUTF8(tmpstr); 13195 sv_2mortal(tmpstr); 13196 } 13197 } 13198 if (!name) { 13199 name = "__ANONIO__"; 13200 len = 10; 13201 want_dollar = FALSE; 13202 } 13203 op_lvalue(kid, type); 13204 } 13205 if (name) { 13206 SV *namesv; 13207 targ = pad_alloc(OP_RV2GV, SVf_READONLY); 13208 namesv = PAD_SVl(targ); 13209 if (want_dollar && *name != '$') 13210 sv_setpvs(namesv, "$"); 13211 else 13212 SvPVCLEAR(namesv); 13213 sv_catpvn(namesv, name, len); 13214 if ( name_utf8 ) SvUTF8_on(namesv); 13215 } 13216 } 13217 scalar(kid); 13218 kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid, 13219 OP_RV2GV, flags); 13220 kid->op_targ = targ; 13221 kid->op_private |= priv; 13222 } 13223 } 13224 scalar(kid); 13225 break; 13226 case OA_SCALARREF: 13227 if ((type == OP_UNDEF || type == OP_POS) 13228 && numargs == 1 && !(oa >> 4) 13229 && kid->op_type == OP_LIST) 13230 return too_many_arguments_pv(o,PL_op_desc[type], 0); 13231 op_lvalue(scalar(kid), type); 13232 break; 13233 } 13234 oa >>= 4; 13235 prev_kid = kid; 13236 kid = OpSIBLING(kid); 13237 } 13238 /* FIXME - should the numargs or-ing move after the too many 13239 * arguments check? */ 13240 o->op_private |= numargs; 13241 if (kid) 13242 return too_many_arguments_pv(o,OP_DESC(o), 0); 13243 listkids(o); 13244 } 13245 else if (PL_opargs[type] & OA_DEFGV) { 13246 /* Ordering of these two is important to keep f_map.t passing. */ 13247 op_free(o); 13248 return newUNOP(type, 0, newDEFSVOP()); 13249 } 13250 13251 if (oa) { 13252 while (oa & OA_OPTIONAL) 13253 oa >>= 4; 13254 if (oa && oa != OA_LIST) 13255 return too_few_arguments_pv(o,OP_DESC(o), 0); 13256 } 13257 return o; 13258 } 13259 13260 OP * 13261 Perl_ck_glob(pTHX_ OP *o) 13262 { 13263 GV *gv; 13264 13265 PERL_ARGS_ASSERT_CK_GLOB; 13266 13267 o = ck_fun(o); 13268 if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first)) 13269 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */ 13270 13271 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4))) 13272 { 13273 /* convert 13274 * glob 13275 * \ null - const(wildcard) 13276 * into 13277 * null 13278 * \ enter 13279 * \ list 13280 * \ mark - glob - rv2cv 13281 * | \ gv(CORE::GLOBAL::glob) 13282 * | 13283 * \ null - const(wildcard) 13284 */ 13285 o->op_flags |= OPf_SPECIAL; 13286 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP); 13287 o = S_new_entersubop(aTHX_ gv, o); 13288 o = newUNOP(OP_NULL, 0, o); 13289 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */ 13290 return o; 13291 } 13292 else o->op_flags &= ~OPf_SPECIAL; 13293 #if !defined(PERL_EXTERNAL_GLOB) 13294 if (!PL_globhook) { 13295 ENTER; 13296 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, 13297 newSVpvs("File::Glob"), NULL, NULL, NULL); 13298 LEAVE; 13299 } 13300 #endif /* !PERL_EXTERNAL_GLOB */ 13301 gv = (GV *)newSV(0); 13302 gv_init(gv, 0, "", 0, 0); 13303 gv_IOadd(gv); 13304 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv)); 13305 SvREFCNT_dec_NN(gv); /* newGVOP increased it */ 13306 scalarkids(o); 13307 return o; 13308 } 13309 13310 OP * 13311 Perl_ck_grep(pTHX_ OP *o) 13312 { 13313 LOGOP *gwop; 13314 OP *kid; 13315 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE; 13316 13317 PERL_ARGS_ASSERT_CK_GREP; 13318 13319 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */ 13320 13321 if (o->op_flags & OPf_STACKED) { 13322 kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first; 13323 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE) 13324 return no_fh_allowed(o); 13325 o->op_flags &= ~OPf_STACKED; 13326 } 13327 kid = OpSIBLING(cLISTOPo->op_first); 13328 if (type == OP_MAPWHILE) 13329 list(kid); 13330 else 13331 scalar(kid); 13332 o = ck_fun(o); 13333 if (PL_parser && PL_parser->error_count) 13334 return o; 13335 kid = OpSIBLING(cLISTOPo->op_first); 13336 if (kid->op_type != OP_NULL) 13337 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type); 13338 kid = kUNOP->op_first; 13339 13340 gwop = alloc_LOGOP(type, o, LINKLIST(kid)); 13341 kid->op_next = (OP*)gwop; 13342 o->op_private = gwop->op_private = 0; 13343 gwop->op_targ = pad_alloc(type, SVs_PADTMP); 13344 13345 kid = OpSIBLING(cLISTOPo->op_first); 13346 for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid)) 13347 op_lvalue(kid, OP_GREPSTART); 13348 13349 return (OP*)gwop; 13350 } 13351 13352 OP * 13353 Perl_ck_index(pTHX_ OP *o) 13354 { 13355 PERL_ARGS_ASSERT_CK_INDEX; 13356 13357 if (o->op_flags & OPf_KIDS) { 13358 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */ 13359 if (kid) 13360 kid = OpSIBLING(kid); /* get past "big" */ 13361 if (kid && kid->op_type == OP_CONST) { 13362 const bool save_taint = TAINT_get; 13363 SV *sv = kSVOP->op_sv; 13364 if ( (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv)) 13365 && SvOK(sv) && !SvROK(sv)) 13366 { 13367 sv = newSV(0); 13368 sv_copypv(sv, kSVOP->op_sv); 13369 SvREFCNT_dec_NN(kSVOP->op_sv); 13370 kSVOP->op_sv = sv; 13371 } 13372 if (SvOK(sv)) fbm_compile(sv, 0); 13373 TAINT_set(save_taint); 13374 #ifdef NO_TAINT_SUPPORT 13375 PERL_UNUSED_VAR(save_taint); 13376 #endif 13377 } 13378 } 13379 return ck_fun(o); 13380 } 13381 13382 OP * 13383 Perl_ck_lfun(pTHX_ OP *o) 13384 { 13385 const OPCODE type = o->op_type; 13386 13387 PERL_ARGS_ASSERT_CK_LFUN; 13388 13389 return modkids(ck_fun(o), type); 13390 } 13391 13392 OP * 13393 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ 13394 { 13395 PERL_ARGS_ASSERT_CK_DEFINED; 13396 13397 if ((o->op_flags & OPf_KIDS)) { 13398 switch (cUNOPo->op_first->op_type) { 13399 case OP_RV2AV: 13400 case OP_PADAV: 13401 Perl_croak(aTHX_ "Can't use 'defined(@array)'" 13402 " (Maybe you should just omit the defined()?)"); 13403 NOT_REACHED; /* NOTREACHED */ 13404 break; 13405 case OP_RV2HV: 13406 case OP_PADHV: 13407 Perl_croak(aTHX_ "Can't use 'defined(%%hash)'" 13408 " (Maybe you should just omit the defined()?)"); 13409 NOT_REACHED; /* NOTREACHED */ 13410 break; 13411 default: 13412 /* no warning */ 13413 break; 13414 } 13415 } 13416 return ck_rfun(o); 13417 } 13418 13419 OP * 13420 Perl_ck_readline(pTHX_ OP *o) 13421 { 13422 PERL_ARGS_ASSERT_CK_READLINE; 13423 13424 if (o->op_flags & OPf_KIDS) { 13425 OP *kid = cLISTOPo->op_first; 13426 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE; 13427 scalar(kid); 13428 } 13429 else { 13430 OP * const newop 13431 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv)); 13432 op_free(o); 13433 return newop; 13434 } 13435 return o; 13436 } 13437 13438 OP * 13439 Perl_ck_rfun(pTHX_ OP *o) 13440 { 13441 const OPCODE type = o->op_type; 13442 13443 PERL_ARGS_ASSERT_CK_RFUN; 13444 13445 return refkids(ck_fun(o), type); 13446 } 13447 13448 OP * 13449 Perl_ck_listiob(pTHX_ OP *o) 13450 { 13451 OP *kid; 13452 13453 PERL_ARGS_ASSERT_CK_LISTIOB; 13454 13455 kid = cLISTOPo->op_first; 13456 if (!kid) { 13457 o = force_list(o, 1); 13458 kid = cLISTOPo->op_first; 13459 } 13460 if (kid->op_type == OP_PUSHMARK) 13461 kid = OpSIBLING(kid); 13462 if (kid && o->op_flags & OPf_STACKED) 13463 kid = OpSIBLING(kid); 13464 else if (kid && !OpHAS_SIBLING(kid)) { /* print HANDLE; */ 13465 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE 13466 && !kid->op_folded) { 13467 o->op_flags |= OPf_STACKED; /* make it a filehandle */ 13468 scalar(kid); 13469 /* replace old const op with new OP_RV2GV parent */ 13470 kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first, 13471 OP_RV2GV, OPf_REF); 13472 kid = OpSIBLING(kid); 13473 } 13474 } 13475 13476 if (!kid) 13477 op_append_elem(o->op_type, o, newDEFSVOP()); 13478 13479 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF); 13480 return listkids(o); 13481 } 13482 13483 OP * 13484 Perl_ck_smartmatch(pTHX_ OP *o) 13485 { 13486 dVAR; 13487 PERL_ARGS_ASSERT_CK_SMARTMATCH; 13488 if (0 == (o->op_flags & OPf_SPECIAL)) { 13489 OP *first = cBINOPo->op_first; 13490 OP *second = OpSIBLING(first); 13491 13492 /* Implicitly take a reference to an array or hash */ 13493 13494 /* remove the original two siblings, then add back the 13495 * (possibly different) first and second sibs. 13496 */ 13497 op_sibling_splice(o, NULL, 1, NULL); 13498 op_sibling_splice(o, NULL, 1, NULL); 13499 first = ref_array_or_hash(first); 13500 second = ref_array_or_hash(second); 13501 op_sibling_splice(o, NULL, 0, second); 13502 op_sibling_splice(o, NULL, 0, first); 13503 13504 /* Implicitly take a reference to a regular expression */ 13505 if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) { 13506 OpTYPE_set(first, OP_QR); 13507 } 13508 if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) { 13509 OpTYPE_set(second, OP_QR); 13510 } 13511 } 13512 13513 return o; 13514 } 13515 13516 13517 static OP * 13518 S_maybe_targlex(pTHX_ OP *o) 13519 { 13520 OP * const kid = cLISTOPo->op_first; 13521 /* has a disposable target? */ 13522 if ((PL_opargs[kid->op_type] & OA_TARGLEX) 13523 && !(kid->op_flags & OPf_STACKED) 13524 /* Cannot steal the second time! */ 13525 && !(kid->op_private & OPpTARGET_MY) 13526 ) 13527 { 13528 OP * const kkid = OpSIBLING(kid); 13529 13530 /* Can just relocate the target. */ 13531 if (kkid && kkid->op_type == OP_PADSV 13532 && (!(kkid->op_private & OPpLVAL_INTRO) 13533 || kkid->op_private & OPpPAD_STATE)) 13534 { 13535 kid->op_targ = kkid->op_targ; 13536 kkid->op_targ = 0; 13537 /* Now we do not need PADSV and SASSIGN. 13538 * Detach kid and free the rest. */ 13539 op_sibling_splice(o, NULL, 1, NULL); 13540 op_free(o); 13541 kid->op_private |= OPpTARGET_MY; /* Used for context settings */ 13542 return kid; 13543 } 13544 } 13545 return o; 13546 } 13547 13548 OP * 13549 Perl_ck_sassign(pTHX_ OP *o) 13550 { 13551 dVAR; 13552 OP * const kid = cBINOPo->op_first; 13553 13554 PERL_ARGS_ASSERT_CK_SASSIGN; 13555 13556 if (OpHAS_SIBLING(kid)) { 13557 OP *kkid = OpSIBLING(kid); 13558 /* For state variable assignment with attributes, kkid is a list op 13559 whose op_last is a padsv. */ 13560 if ((kkid->op_type == OP_PADSV || 13561 (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) && 13562 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV 13563 ) 13564 ) 13565 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) 13566 == (OPpLVAL_INTRO|OPpPAD_STATE)) { 13567 return S_newONCEOP(aTHX_ o, kkid); 13568 } 13569 } 13570 return S_maybe_targlex(aTHX_ o); 13571 } 13572 13573 13574 OP * 13575 Perl_ck_match(pTHX_ OP *o) 13576 { 13577 PERL_UNUSED_CONTEXT; 13578 PERL_ARGS_ASSERT_CK_MATCH; 13579 13580 return o; 13581 } 13582 13583 OP * 13584 Perl_ck_method(pTHX_ OP *o) 13585 { 13586 SV *sv, *methsv, *rclass; 13587 const char* method; 13588 char* compatptr; 13589 int utf8; 13590 STRLEN len, nsplit = 0, i; 13591 OP* new_op; 13592 OP * const kid = cUNOPo->op_first; 13593 13594 PERL_ARGS_ASSERT_CK_METHOD; 13595 if (kid->op_type != OP_CONST) return o; 13596 13597 sv = kSVOP->op_sv; 13598 13599 /* replace ' with :: */ 13600 while ((compatptr = (char *) memchr(SvPVX(sv), '\'', 13601 SvEND(sv) - SvPVX(sv) ))) 13602 { 13603 *compatptr = ':'; 13604 sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1); 13605 } 13606 13607 method = SvPVX_const(sv); 13608 len = SvCUR(sv); 13609 utf8 = SvUTF8(sv) ? -1 : 1; 13610 13611 for (i = len - 1; i > 0; --i) if (method[i] == ':') { 13612 nsplit = i+1; 13613 break; 13614 } 13615 13616 methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0); 13617 13618 if (!nsplit) { /* $proto->method() */ 13619 op_free(o); 13620 return newMETHOP_named(OP_METHOD_NAMED, 0, methsv); 13621 } 13622 13623 if (memEQs(method, nsplit, "SUPER::")) { /* $proto->SUPER::method() */ 13624 op_free(o); 13625 return newMETHOP_named(OP_METHOD_SUPER, 0, methsv); 13626 } 13627 13628 /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */ 13629 if (nsplit >= 9 && strBEGINs(method+nsplit-9, "::SUPER::")) { 13630 rclass = newSVpvn_share(method, utf8*(nsplit-9), 0); 13631 new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv); 13632 } else { 13633 rclass = newSVpvn_share(method, utf8*(nsplit-2), 0); 13634 new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv); 13635 } 13636 #ifdef USE_ITHREADS 13637 op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ); 13638 #else 13639 cMETHOPx(new_op)->op_rclass_sv = rclass; 13640 #endif 13641 op_free(o); 13642 return new_op; 13643 } 13644 13645 OP * 13646 Perl_ck_null(pTHX_ OP *o) 13647 { 13648 PERL_ARGS_ASSERT_CK_NULL; 13649 PERL_UNUSED_CONTEXT; 13650 return o; 13651 } 13652 13653 OP * 13654 Perl_ck_open(pTHX_ OP *o) 13655 { 13656 PERL_ARGS_ASSERT_CK_OPEN; 13657 13658 S_io_hints(aTHX_ o); 13659 { 13660 /* In case of three-arg dup open remove strictness 13661 * from the last arg if it is a bareword. */ 13662 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */ 13663 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */ 13664 OP *oa; 13665 const char *mode; 13666 13667 if ((last->op_type == OP_CONST) && /* The bareword. */ 13668 (last->op_private & OPpCONST_BARE) && 13669 (last->op_private & OPpCONST_STRICT) && 13670 (oa = OpSIBLING(first)) && /* The fh. */ 13671 (oa = OpSIBLING(oa)) && /* The mode. */ 13672 (oa->op_type == OP_CONST) && 13673 SvPOK(((SVOP*)oa)->op_sv) && 13674 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) && 13675 mode[0] == '>' && mode[1] == '&' && /* A dup open. */ 13676 (last == OpSIBLING(oa))) /* The bareword. */ 13677 last->op_private &= ~OPpCONST_STRICT; 13678 } 13679 return ck_fun(o); 13680 } 13681 13682 OP * 13683 Perl_ck_prototype(pTHX_ OP *o) 13684 { 13685 PERL_ARGS_ASSERT_CK_PROTOTYPE; 13686 if (!(o->op_flags & OPf_KIDS)) { 13687 op_free(o); 13688 return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP()); 13689 } 13690 return o; 13691 } 13692 13693 OP * 13694 Perl_ck_refassign(pTHX_ OP *o) 13695 { 13696 OP * const right = cLISTOPo->op_first; 13697 OP * const left = OpSIBLING(right); 13698 OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first; 13699 bool stacked = 0; 13700 13701 PERL_ARGS_ASSERT_CK_REFASSIGN; 13702 assert (left); 13703 assert (left->op_type == OP_SREFGEN); 13704 13705 o->op_private = 0; 13706 /* we use OPpPAD_STATE in refassign to mean either of those things, 13707 * and the code assumes the two flags occupy the same bit position 13708 * in the various ops below */ 13709 assert(OPpPAD_STATE == OPpOUR_INTRO); 13710 13711 switch (varop->op_type) { 13712 case OP_PADAV: 13713 o->op_private |= OPpLVREF_AV; 13714 goto settarg; 13715 case OP_PADHV: 13716 o->op_private |= OPpLVREF_HV; 13717 /* FALLTHROUGH */ 13718 case OP_PADSV: 13719 settarg: 13720 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)); 13721 o->op_targ = varop->op_targ; 13722 varop->op_targ = 0; 13723 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX); 13724 break; 13725 13726 case OP_RV2AV: 13727 o->op_private |= OPpLVREF_AV; 13728 goto checkgv; 13729 NOT_REACHED; /* NOTREACHED */ 13730 case OP_RV2HV: 13731 o->op_private |= OPpLVREF_HV; 13732 /* FALLTHROUGH */ 13733 case OP_RV2SV: 13734 checkgv: 13735 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)); 13736 if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad; 13737 detach_and_stack: 13738 /* Point varop to its GV kid, detached. */ 13739 varop = op_sibling_splice(varop, NULL, -1, NULL); 13740 stacked = TRUE; 13741 break; 13742 case OP_RV2CV: { 13743 OP * const kidparent = 13744 OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first); 13745 OP * const kid = cUNOPx(kidparent)->op_first; 13746 o->op_private |= OPpLVREF_CV; 13747 if (kid->op_type == OP_GV) { 13748 SV *sv = (SV*)cGVOPx_gv(kid); 13749 varop = kidparent; 13750 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) { 13751 /* a CVREF here confuses pp_refassign, so make sure 13752 it gets a GV */ 13753 CV *const cv = (CV*)SvRV(sv); 13754 SV *name_sv = sv_2mortal(newSVhek(CvNAME_HEK(cv))); 13755 (void)gv_init_sv((GV*)sv, CvSTASH(cv), name_sv, 0); 13756 assert(SvTYPE(sv) == SVt_PVGV); 13757 } 13758 goto detach_and_stack; 13759 } 13760 if (kid->op_type != OP_PADCV) goto bad; 13761 o->op_targ = kid->op_targ; 13762 kid->op_targ = 0; 13763 break; 13764 } 13765 case OP_AELEM: 13766 case OP_HELEM: 13767 o->op_private |= (varop->op_private & OPpLVAL_INTRO); 13768 o->op_private |= OPpLVREF_ELEM; 13769 op_null(varop); 13770 stacked = TRUE; 13771 /* Detach varop. */ 13772 op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL); 13773 break; 13774 default: 13775 bad: 13776 /* diag_listed_as: Can't modify reference to %s in %s assignment */ 13777 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar " 13778 "assignment", 13779 OP_DESC(varop))); 13780 return o; 13781 } 13782 if (!FEATURE_REFALIASING_IS_ENABLED) 13783 Perl_croak(aTHX_ 13784 "Experimental aliasing via reference not enabled"); 13785 Perl_ck_warner_d(aTHX_ 13786 packWARN(WARN_EXPERIMENTAL__REFALIASING), 13787 "Aliasing via reference is experimental"); 13788 if (stacked) { 13789 o->op_flags |= OPf_STACKED; 13790 op_sibling_splice(o, right, 1, varop); 13791 } 13792 else { 13793 o->op_flags &=~ OPf_STACKED; 13794 op_sibling_splice(o, right, 1, NULL); 13795 } 13796 op_free(left); 13797 return o; 13798 } 13799 13800 OP * 13801 Perl_ck_repeat(pTHX_ OP *o) 13802 { 13803 PERL_ARGS_ASSERT_CK_REPEAT; 13804 13805 if (cBINOPo->op_first->op_flags & OPf_PARENS) { 13806 OP* kids; 13807 o->op_private |= OPpREPEAT_DOLIST; 13808 kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */ 13809 kids = force_list(kids, 1); /* promote it to a list */ 13810 op_sibling_splice(o, NULL, 0, kids); /* and add back */ 13811 } 13812 else 13813 scalar(o); 13814 return o; 13815 } 13816 13817 OP * 13818 Perl_ck_require(pTHX_ OP *o) 13819 { 13820 GV* gv; 13821 13822 PERL_ARGS_ASSERT_CK_REQUIRE; 13823 13824 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */ 13825 SVOP * const kid = (SVOP*)cUNOPo->op_first; 13826 U32 hash; 13827 char *s; 13828 STRLEN len; 13829 if (kid->op_type == OP_CONST) { 13830 SV * const sv = kid->op_sv; 13831 U32 const was_readonly = SvREADONLY(sv); 13832 if (kid->op_private & OPpCONST_BARE) { 13833 dVAR; 13834 const char *end; 13835 HEK *hek; 13836 13837 if (was_readonly) { 13838 SvREADONLY_off(sv); 13839 } 13840 13841 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0); 13842 13843 s = SvPVX(sv); 13844 len = SvCUR(sv); 13845 end = s + len; 13846 /* treat ::foo::bar as foo::bar */ 13847 if (len >= 2 && s[0] == ':' && s[1] == ':') 13848 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s); 13849 if (s == end) 13850 DIE(aTHX_ "Bareword in require maps to empty filename"); 13851 13852 for (; s < end; s++) { 13853 if (*s == ':' && s[1] == ':') { 13854 *s = '/'; 13855 Move(s+2, s+1, end - s - 1, char); 13856 --end; 13857 } 13858 } 13859 SvEND_set(sv, end); 13860 sv_catpvs(sv, ".pm"); 13861 PERL_HASH(hash, SvPVX(sv), SvCUR(sv)); 13862 hek = share_hek(SvPVX(sv), 13863 (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1), 13864 hash); 13865 sv_sethek(sv, hek); 13866 unshare_hek(hek); 13867 SvFLAGS(sv) |= was_readonly; 13868 } 13869 else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv) 13870 && !SvVOK(sv)) { 13871 s = SvPV(sv, len); 13872 if (SvREFCNT(sv) > 1) { 13873 kid->op_sv = newSVpvn_share( 13874 s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0); 13875 SvREFCNT_dec_NN(sv); 13876 } 13877 else { 13878 dVAR; 13879 HEK *hek; 13880 if (was_readonly) SvREADONLY_off(sv); 13881 PERL_HASH(hash, s, len); 13882 hek = share_hek(s, 13883 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 13884 hash); 13885 sv_sethek(sv, hek); 13886 unshare_hek(hek); 13887 SvFLAGS(sv) |= was_readonly; 13888 } 13889 } 13890 } 13891 } 13892 13893 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */ 13894 /* handle override, if any */ 13895 && (gv = gv_override("require", 7))) { 13896 OP *kid, *newop; 13897 if (o->op_flags & OPf_KIDS) { 13898 kid = cUNOPo->op_first; 13899 op_sibling_splice(o, NULL, -1, NULL); 13900 } 13901 else { 13902 kid = newDEFSVOP(); 13903 } 13904 op_free(o); 13905 newop = S_new_entersubop(aTHX_ gv, kid); 13906 return newop; 13907 } 13908 13909 return ck_fun(o); 13910 } 13911 13912 OP * 13913 Perl_ck_return(pTHX_ OP *o) 13914 { 13915 OP *kid; 13916 13917 PERL_ARGS_ASSERT_CK_RETURN; 13918 13919 kid = OpSIBLING(cLISTOPo->op_first); 13920 if (PL_compcv && CvLVALUE(PL_compcv)) { 13921 for (; kid; kid = OpSIBLING(kid)) 13922 op_lvalue(kid, OP_LEAVESUBLV); 13923 } 13924 13925 return o; 13926 } 13927 13928 OP * 13929 Perl_ck_select(pTHX_ OP *o) 13930 { 13931 dVAR; 13932 OP* kid; 13933 13934 PERL_ARGS_ASSERT_CK_SELECT; 13935 13936 if (o->op_flags & OPf_KIDS) { 13937 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */ 13938 if (kid && OpHAS_SIBLING(kid)) { 13939 OpTYPE_set(o, OP_SSELECT); 13940 o = ck_fun(o); 13941 return fold_constants(op_integerize(op_std_init(o))); 13942 } 13943 } 13944 o = ck_fun(o); 13945 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */ 13946 if (kid && kid->op_type == OP_RV2GV) 13947 kid->op_private &= ~HINT_STRICT_REFS; 13948 return o; 13949 } 13950 13951 OP * 13952 Perl_ck_shift(pTHX_ OP *o) 13953 { 13954 const I32 type = o->op_type; 13955 13956 PERL_ARGS_ASSERT_CK_SHIFT; 13957 13958 if (!(o->op_flags & OPf_KIDS)) { 13959 OP *argop; 13960 13961 if (!CvUNIQUE(PL_compcv)) { 13962 o->op_flags |= OPf_SPECIAL; 13963 return o; 13964 } 13965 13966 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv))); 13967 op_free(o); 13968 return newUNOP(type, 0, scalar(argop)); 13969 } 13970 return scalar(ck_fun(o)); 13971 } 13972 13973 OP * 13974 Perl_ck_sort(pTHX_ OP *o) 13975 { 13976 OP *firstkid; 13977 OP *kid; 13978 HV * const hinthv = 13979 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL; 13980 U8 stacked; 13981 13982 PERL_ARGS_ASSERT_CK_SORT; 13983 13984 if (hinthv) { 13985 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE); 13986 if (svp) { 13987 const I32 sorthints = (I32)SvIV(*svp); 13988 if ((sorthints & HINT_SORT_STABLE) != 0) 13989 o->op_private |= OPpSORT_STABLE; 13990 if ((sorthints & HINT_SORT_UNSTABLE) != 0) 13991 o->op_private |= OPpSORT_UNSTABLE; 13992 } 13993 } 13994 13995 if (o->op_flags & OPf_STACKED) 13996 simplify_sort(o); 13997 firstkid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */ 13998 13999 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */ 14000 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */ 14001 14002 /* if the first arg is a code block, process it and mark sort as 14003 * OPf_SPECIAL */ 14004 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) { 14005 LINKLIST(kid); 14006 if (kid->op_type == OP_LEAVE) 14007 op_null(kid); /* wipe out leave */ 14008 /* Prevent execution from escaping out of the sort block. */ 14009 kid->op_next = 0; 14010 14011 /* provide scalar context for comparison function/block */ 14012 kid = scalar(firstkid); 14013 kid->op_next = kid; 14014 o->op_flags |= OPf_SPECIAL; 14015 } 14016 else if (kid->op_type == OP_CONST 14017 && kid->op_private & OPpCONST_BARE) { 14018 char tmpbuf[256]; 14019 STRLEN len; 14020 PADOFFSET off; 14021 const char * const name = SvPV(kSVOP_sv, len); 14022 *tmpbuf = '&'; 14023 assert (len < 256); 14024 Copy(name, tmpbuf+1, len, char); 14025 off = pad_findmy_pvn(tmpbuf, len+1, 0); 14026 if (off != NOT_IN_PAD) { 14027 if (PAD_COMPNAME_FLAGS_isOUR(off)) { 14028 SV * const fq = 14029 newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off))); 14030 sv_catpvs(fq, "::"); 14031 sv_catsv(fq, kSVOP_sv); 14032 SvREFCNT_dec_NN(kSVOP_sv); 14033 kSVOP->op_sv = fq; 14034 } 14035 else { 14036 OP * const padop = newOP(OP_PADCV, 0); 14037 padop->op_targ = off; 14038 /* replace the const op with the pad op */ 14039 op_sibling_splice(firstkid, NULL, 1, padop); 14040 op_free(kid); 14041 } 14042 } 14043 } 14044 14045 firstkid = OpSIBLING(firstkid); 14046 } 14047 14048 for (kid = firstkid; kid; kid = OpSIBLING(kid)) { 14049 /* provide list context for arguments */ 14050 list(kid); 14051 if (stacked) 14052 op_lvalue(kid, OP_GREPSTART); 14053 } 14054 14055 return o; 14056 } 14057 14058 /* for sort { X } ..., where X is one of 14059 * $a <=> $b, $b <=> $a, $a cmp $b, $b cmp $a 14060 * elide the second child of the sort (the one containing X), 14061 * and set these flags as appropriate 14062 OPpSORT_NUMERIC; 14063 OPpSORT_INTEGER; 14064 OPpSORT_DESCEND; 14065 * Also, check and warn on lexical $a, $b. 14066 */ 14067 14068 STATIC void 14069 S_simplify_sort(pTHX_ OP *o) 14070 { 14071 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */ 14072 OP *k; 14073 int descending; 14074 GV *gv; 14075 const char *gvname; 14076 bool have_scopeop; 14077 14078 PERL_ARGS_ASSERT_SIMPLIFY_SORT; 14079 14080 kid = kUNOP->op_first; /* get past null */ 14081 if (!(have_scopeop = kid->op_type == OP_SCOPE) 14082 && kid->op_type != OP_LEAVE) 14083 return; 14084 kid = kLISTOP->op_last; /* get past scope */ 14085 switch(kid->op_type) { 14086 case OP_NCMP: 14087 case OP_I_NCMP: 14088 case OP_SCMP: 14089 if (!have_scopeop) goto padkids; 14090 break; 14091 default: 14092 return; 14093 } 14094 k = kid; /* remember this node*/ 14095 if (kBINOP->op_first->op_type != OP_RV2SV 14096 || kBINOP->op_last ->op_type != OP_RV2SV) 14097 { 14098 /* 14099 Warn about my($a) or my($b) in a sort block, *if* $a or $b is 14100 then used in a comparison. This catches most, but not 14101 all cases. For instance, it catches 14102 sort { my($a); $a <=> $b } 14103 but not 14104 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; } 14105 (although why you'd do that is anyone's guess). 14106 */ 14107 14108 padkids: 14109 if (!ckWARN(WARN_SYNTAX)) return; 14110 kid = kBINOP->op_first; 14111 do { 14112 if (kid->op_type == OP_PADSV) { 14113 PADNAME * const name = PAD_COMPNAME(kid->op_targ); 14114 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$' 14115 && ( PadnamePV(name)[1] == 'a' 14116 || PadnamePV(name)[1] == 'b' )) 14117 /* diag_listed_as: "my %s" used in sort comparison */ 14118 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 14119 "\"%s %s\" used in sort comparison", 14120 PadnameIsSTATE(name) 14121 ? "state" 14122 : "my", 14123 PadnamePV(name)); 14124 } 14125 } while ((kid = OpSIBLING(kid))); 14126 return; 14127 } 14128 kid = kBINOP->op_first; /* get past cmp */ 14129 if (kUNOP->op_first->op_type != OP_GV) 14130 return; 14131 kid = kUNOP->op_first; /* get past rv2sv */ 14132 gv = kGVOP_gv; 14133 if (GvSTASH(gv) != PL_curstash) 14134 return; 14135 gvname = GvNAME(gv); 14136 if (*gvname == 'a' && gvname[1] == '\0') 14137 descending = 0; 14138 else if (*gvname == 'b' && gvname[1] == '\0') 14139 descending = 1; 14140 else 14141 return; 14142 14143 kid = k; /* back to cmp */ 14144 /* already checked above that it is rv2sv */ 14145 kid = kBINOP->op_last; /* down to 2nd arg */ 14146 if (kUNOP->op_first->op_type != OP_GV) 14147 return; 14148 kid = kUNOP->op_first; /* get past rv2sv */ 14149 gv = kGVOP_gv; 14150 if (GvSTASH(gv) != PL_curstash) 14151 return; 14152 gvname = GvNAME(gv); 14153 if ( descending 14154 ? !(*gvname == 'a' && gvname[1] == '\0') 14155 : !(*gvname == 'b' && gvname[1] == '\0')) 14156 return; 14157 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL); 14158 if (descending) 14159 o->op_private |= OPpSORT_DESCEND; 14160 if (k->op_type == OP_NCMP) 14161 o->op_private |= OPpSORT_NUMERIC; 14162 if (k->op_type == OP_I_NCMP) 14163 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER; 14164 kid = OpSIBLING(cLISTOPo->op_first); 14165 /* cut out and delete old block (second sibling) */ 14166 op_sibling_splice(o, cLISTOPo->op_first, 1, NULL); 14167 op_free(kid); 14168 } 14169 14170 OP * 14171 Perl_ck_split(pTHX_ OP *o) 14172 { 14173 dVAR; 14174 OP *kid; 14175 OP *sibs; 14176 14177 PERL_ARGS_ASSERT_CK_SPLIT; 14178 14179 assert(o->op_type == OP_LIST); 14180 14181 if (o->op_flags & OPf_STACKED) 14182 return no_fh_allowed(o); 14183 14184 kid = cLISTOPo->op_first; 14185 /* delete leading NULL node, then add a CONST if no other nodes */ 14186 assert(kid->op_type == OP_NULL); 14187 op_sibling_splice(o, NULL, 1, 14188 OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" "))); 14189 op_free(kid); 14190 kid = cLISTOPo->op_first; 14191 14192 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) { 14193 /* remove match expression, and replace with new optree with 14194 * a match op at its head */ 14195 op_sibling_splice(o, NULL, 1, NULL); 14196 /* pmruntime will handle split " " behavior with flag==2 */ 14197 kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0); 14198 op_sibling_splice(o, NULL, 0, kid); 14199 } 14200 14201 assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT); 14202 14203 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) { 14204 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), 14205 "Use of /g modifier is meaningless in split"); 14206 } 14207 14208 /* eliminate the split op, and move the match op (plus any children) 14209 * into its place, then convert the match op into a split op. i.e. 14210 * 14211 * SPLIT MATCH SPLIT(ex-MATCH) 14212 * | | | 14213 * MATCH - A - B - C => R - A - B - C => R - A - B - C 14214 * | | | 14215 * R X - Y X - Y 14216 * | 14217 * X - Y 14218 * 14219 * (R, if it exists, will be a regcomp op) 14220 */ 14221 14222 op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */ 14223 sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */ 14224 op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */ 14225 OpTYPE_set(kid, OP_SPLIT); 14226 kid->op_flags = (o->op_flags | (kid->op_flags & OPf_KIDS)); 14227 kid->op_private = o->op_private; 14228 op_free(o); 14229 o = kid; 14230 kid = sibs; /* kid is now the string arg of the split */ 14231 14232 if (!kid) { 14233 kid = newDEFSVOP(); 14234 op_append_elem(OP_SPLIT, o, kid); 14235 } 14236 scalar(kid); 14237 14238 kid = OpSIBLING(kid); 14239 if (!kid) { 14240 kid = newSVOP(OP_CONST, 0, newSViv(0)); 14241 op_append_elem(OP_SPLIT, o, kid); 14242 o->op_private |= OPpSPLIT_IMPLIM; 14243 } 14244 scalar(kid); 14245 14246 if (OpHAS_SIBLING(kid)) 14247 return too_many_arguments_pv(o,OP_DESC(o), 0); 14248 14249 return o; 14250 } 14251 14252 OP * 14253 Perl_ck_stringify(pTHX_ OP *o) 14254 { 14255 OP * const kid = OpSIBLING(cUNOPo->op_first); 14256 PERL_ARGS_ASSERT_CK_STRINGIFY; 14257 if (( kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA 14258 || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST 14259 || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST) 14260 && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */ 14261 { 14262 op_sibling_splice(o, cUNOPo->op_first, -1, NULL); 14263 op_free(o); 14264 return kid; 14265 } 14266 return ck_fun(o); 14267 } 14268 14269 OP * 14270 Perl_ck_join(pTHX_ OP *o) 14271 { 14272 OP * const kid = OpSIBLING(cLISTOPo->op_first); 14273 14274 PERL_ARGS_ASSERT_CK_JOIN; 14275 14276 if (kid && kid->op_type == OP_MATCH) { 14277 if (ckWARN(WARN_SYNTAX)) { 14278 const REGEXP *re = PM_GETRE(kPMOP); 14279 const SV *msg = re 14280 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re), 14281 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) ) 14282 : newSVpvs_flags( "STRING", SVs_TEMP ); 14283 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 14284 "/%" SVf "/ should probably be written as \"%" SVf "\"", 14285 SVfARG(msg), SVfARG(msg)); 14286 } 14287 } 14288 if (kid 14289 && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */ 14290 || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO)) 14291 || ( kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV 14292 && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO))))) 14293 { 14294 const OP * const bairn = OpSIBLING(kid); /* the list */ 14295 if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */ 14296 && OP_GIMME(bairn,0) == G_SCALAR) 14297 { 14298 OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED, 14299 op_sibling_splice(o, kid, 1, NULL)); 14300 op_free(o); 14301 return ret; 14302 } 14303 } 14304 14305 return ck_fun(o); 14306 } 14307 14308 /* 14309 =for apidoc rv2cv_op_cv 14310 14311 Examines an op, which is expected to identify a subroutine at runtime, 14312 and attempts to determine at compile time which subroutine it identifies. 14313 This is normally used during Perl compilation to determine whether 14314 a prototype can be applied to a function call. C<cvop> is the op 14315 being considered, normally an C<rv2cv> op. A pointer to the identified 14316 subroutine is returned, if it could be determined statically, and a null 14317 pointer is returned if it was not possible to determine statically. 14318 14319 Currently, the subroutine can be identified statically if the RV that the 14320 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op. 14321 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is 14322 suitable if the constant value must be an RV pointing to a CV. Details of 14323 this process may change in future versions of Perl. If the C<rv2cv> op 14324 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify 14325 the subroutine statically: this flag is used to suppress compile-time 14326 magic on a subroutine call, forcing it to use default runtime behaviour. 14327 14328 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling 14329 of a GV reference is modified. If a GV was examined and its CV slot was 14330 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set. 14331 If the op is not optimised away, and the CV slot is later populated with 14332 a subroutine having a prototype, that flag eventually triggers the warning 14333 "called too early to check prototype". 14334 14335 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead 14336 of returning a pointer to the subroutine it returns a pointer to the 14337 GV giving the most appropriate name for the subroutine in this context. 14338 Normally this is just the C<CvGV> of the subroutine, but for an anonymous 14339 (C<CvANON>) subroutine that is referenced through a GV it will be the 14340 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned. 14341 A null pointer is returned as usual if there is no statically-determinable 14342 subroutine. 14343 14344 =for apidoc Amnh||OPpEARLY_CV 14345 =for apidoc Amnh||OPpENTERSUB_AMPER 14346 =for apidoc Amnh||RV2CVOPCV_MARK_EARLY 14347 =for apidoc Amnh||RV2CVOPCV_RETURN_NAME_GV 14348 14349 =cut 14350 */ 14351 14352 /* shared by toke.c:yylex */ 14353 CV * 14354 Perl_find_lexical_cv(pTHX_ PADOFFSET off) 14355 { 14356 PADNAME *name = PAD_COMPNAME(off); 14357 CV *compcv = PL_compcv; 14358 while (PadnameOUTER(name)) { 14359 assert(PARENT_PAD_INDEX(name)); 14360 compcv = CvOUTSIDE(compcv); 14361 name = PadlistNAMESARRAY(CvPADLIST(compcv)) 14362 [off = PARENT_PAD_INDEX(name)]; 14363 } 14364 assert(!PadnameIsOUR(name)); 14365 if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) { 14366 return PadnamePROTOCV(name); 14367 } 14368 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off]; 14369 } 14370 14371 CV * 14372 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags) 14373 { 14374 OP *rvop; 14375 CV *cv; 14376 GV *gv; 14377 PERL_ARGS_ASSERT_RV2CV_OP_CV; 14378 if (flags & ~RV2CVOPCV_FLAG_MASK) 14379 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags); 14380 if (cvop->op_type != OP_RV2CV) 14381 return NULL; 14382 if (cvop->op_private & OPpENTERSUB_AMPER) 14383 return NULL; 14384 if (!(cvop->op_flags & OPf_KIDS)) 14385 return NULL; 14386 rvop = cUNOPx(cvop)->op_first; 14387 switch (rvop->op_type) { 14388 case OP_GV: { 14389 gv = cGVOPx_gv(rvop); 14390 if (!isGV(gv)) { 14391 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) { 14392 cv = MUTABLE_CV(SvRV(gv)); 14393 gv = NULL; 14394 break; 14395 } 14396 if (flags & RV2CVOPCV_RETURN_STUB) 14397 return (CV *)gv; 14398 else return NULL; 14399 } 14400 cv = GvCVu(gv); 14401 if (!cv) { 14402 if (flags & RV2CVOPCV_MARK_EARLY) 14403 rvop->op_private |= OPpEARLY_CV; 14404 return NULL; 14405 } 14406 } break; 14407 case OP_CONST: { 14408 SV *rv = cSVOPx_sv(rvop); 14409 if (!SvROK(rv)) 14410 return NULL; 14411 cv = (CV*)SvRV(rv); 14412 gv = NULL; 14413 } break; 14414 case OP_PADCV: { 14415 cv = find_lexical_cv(rvop->op_targ); 14416 gv = NULL; 14417 } break; 14418 default: { 14419 return NULL; 14420 } NOT_REACHED; /* NOTREACHED */ 14421 } 14422 if (SvTYPE((SV*)cv) != SVt_PVCV) 14423 return NULL; 14424 if (flags & RV2CVOPCV_RETURN_NAME_GV) { 14425 if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv) 14426 gv = CvGV(cv); 14427 return (CV*)gv; 14428 } 14429 else if (flags & RV2CVOPCV_MAYBE_NAME_GV) { 14430 if (CvLEXICAL(cv) || CvNAMED(cv)) 14431 return NULL; 14432 if (!CvANON(cv) || !gv) 14433 gv = CvGV(cv); 14434 return (CV*)gv; 14435 14436 } else { 14437 return cv; 14438 } 14439 } 14440 14441 /* 14442 =for apidoc ck_entersub_args_list 14443 14444 Performs the default fixup of the arguments part of an C<entersub> 14445 op tree. This consists of applying list context to each of the 14446 argument ops. This is the standard treatment used on a call marked 14447 with C<&>, or a method call, or a call through a subroutine reference, 14448 or any other call where the callee can't be identified at compile time, 14449 or a call where the callee has no prototype. 14450 14451 =cut 14452 */ 14453 14454 OP * 14455 Perl_ck_entersub_args_list(pTHX_ OP *entersubop) 14456 { 14457 OP *aop; 14458 14459 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST; 14460 14461 aop = cUNOPx(entersubop)->op_first; 14462 if (!OpHAS_SIBLING(aop)) 14463 aop = cUNOPx(aop)->op_first; 14464 for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) { 14465 /* skip the extra attributes->import() call implicitly added in 14466 * something like foo(my $x : bar) 14467 */ 14468 if ( aop->op_type == OP_ENTERSUB 14469 && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID 14470 ) 14471 continue; 14472 list(aop); 14473 op_lvalue(aop, OP_ENTERSUB); 14474 } 14475 return entersubop; 14476 } 14477 14478 /* 14479 =for apidoc ck_entersub_args_proto 14480 14481 Performs the fixup of the arguments part of an C<entersub> op tree 14482 based on a subroutine prototype. This makes various modifications to 14483 the argument ops, from applying context up to inserting C<refgen> ops, 14484 and checking the number and syntactic types of arguments, as directed by 14485 the prototype. This is the standard treatment used on a subroutine call, 14486 not marked with C<&>, where the callee can be identified at compile time 14487 and has a prototype. 14488 14489 C<protosv> supplies the subroutine prototype to be applied to the call. 14490 It may be a normal defined scalar, of which the string value will be used. 14491 Alternatively, for convenience, it may be a subroutine object (a C<CV*> 14492 that has been cast to C<SV*>) which has a prototype. The prototype 14493 supplied, in whichever form, does not need to match the actual callee 14494 referenced by the op tree. 14495 14496 If the argument ops disagree with the prototype, for example by having 14497 an unacceptable number of arguments, a valid op tree is returned anyway. 14498 The error is reflected in the parser state, normally resulting in a single 14499 exception at the top level of parsing which covers all the compilation 14500 errors that occurred. In the error message, the callee is referred to 14501 by the name defined by the C<namegv> parameter. 14502 14503 =cut 14504 */ 14505 14506 OP * 14507 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) 14508 { 14509 STRLEN proto_len; 14510 const char *proto, *proto_end; 14511 OP *aop, *prev, *cvop, *parent; 14512 int optional = 0; 14513 I32 arg = 0; 14514 I32 contextclass = 0; 14515 const char *e = NULL; 14516 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO; 14517 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv)) 14518 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, " 14519 "flags=%lx", (unsigned long) SvFLAGS(protosv)); 14520 if (SvTYPE(protosv) == SVt_PVCV) 14521 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv); 14522 else proto = SvPV(protosv, proto_len); 14523 proto = S_strip_spaces(aTHX_ proto, &proto_len); 14524 proto_end = proto + proto_len; 14525 parent = entersubop; 14526 aop = cUNOPx(entersubop)->op_first; 14527 if (!OpHAS_SIBLING(aop)) { 14528 parent = aop; 14529 aop = cUNOPx(aop)->op_first; 14530 } 14531 prev = aop; 14532 aop = OpSIBLING(aop); 14533 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ; 14534 while (aop != cvop) { 14535 OP* o3 = aop; 14536 14537 if (proto >= proto_end) 14538 { 14539 SV * const namesv = cv_name((CV *)namegv, NULL, 0); 14540 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf, 14541 SVfARG(namesv)), SvUTF8(namesv)); 14542 return entersubop; 14543 } 14544 14545 switch (*proto) { 14546 case ';': 14547 optional = 1; 14548 proto++; 14549 continue; 14550 case '_': 14551 /* _ must be at the end */ 14552 if (proto[1] && !memCHRs(";@%", proto[1])) 14553 goto oops; 14554 /* FALLTHROUGH */ 14555 case '$': 14556 proto++; 14557 arg++; 14558 scalar(aop); 14559 break; 14560 case '%': 14561 case '@': 14562 list(aop); 14563 arg++; 14564 break; 14565 case '&': 14566 proto++; 14567 arg++; 14568 if ( o3->op_type != OP_UNDEF 14569 && (o3->op_type != OP_SREFGEN 14570 || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type 14571 != OP_ANONCODE 14572 && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type 14573 != OP_RV2CV))) 14574 bad_type_gv(arg, namegv, o3, 14575 arg == 1 ? "block or sub {}" : "sub {}"); 14576 break; 14577 case '*': 14578 /* '*' allows any scalar type, including bareword */ 14579 proto++; 14580 arg++; 14581 if (o3->op_type == OP_RV2GV) 14582 goto wrapref; /* autoconvert GLOB -> GLOBref */ 14583 else if (o3->op_type == OP_CONST) 14584 o3->op_private &= ~OPpCONST_STRICT; 14585 scalar(aop); 14586 break; 14587 case '+': 14588 proto++; 14589 arg++; 14590 if (o3->op_type == OP_RV2AV || 14591 o3->op_type == OP_PADAV || 14592 o3->op_type == OP_RV2HV || 14593 o3->op_type == OP_PADHV 14594 ) { 14595 goto wrapref; 14596 } 14597 scalar(aop); 14598 break; 14599 case '[': case ']': 14600 goto oops; 14601 14602 case '\\': 14603 proto++; 14604 arg++; 14605 again: 14606 switch (*proto++) { 14607 case '[': 14608 if (contextclass++ == 0) { 14609 e = (char *) memchr(proto, ']', proto_end - proto); 14610 if (!e || e == proto) 14611 goto oops; 14612 } 14613 else 14614 goto oops; 14615 goto again; 14616 14617 case ']': 14618 if (contextclass) { 14619 const char *p = proto; 14620 const char *const end = proto; 14621 contextclass = 0; 14622 while (*--p != '[') 14623 /* \[$] accepts any scalar lvalue */ 14624 if (*p == '$' 14625 && Perl_op_lvalue_flags(aTHX_ 14626 scalar(o3), 14627 OP_READ, /* not entersub */ 14628 OP_LVALUE_NO_CROAK 14629 )) goto wrapref; 14630 bad_type_gv(arg, namegv, o3, 14631 Perl_form(aTHX_ "one of %.*s",(int)(end - p), p)); 14632 } else 14633 goto oops; 14634 break; 14635 case '*': 14636 if (o3->op_type == OP_RV2GV) 14637 goto wrapref; 14638 if (!contextclass) 14639 bad_type_gv(arg, namegv, o3, "symbol"); 14640 break; 14641 case '&': 14642 if (o3->op_type == OP_ENTERSUB 14643 && !(o3->op_flags & OPf_STACKED)) 14644 goto wrapref; 14645 if (!contextclass) 14646 bad_type_gv(arg, namegv, o3, "subroutine"); 14647 break; 14648 case '$': 14649 if (o3->op_type == OP_RV2SV || 14650 o3->op_type == OP_PADSV || 14651 o3->op_type == OP_HELEM || 14652 o3->op_type == OP_AELEM) 14653 goto wrapref; 14654 if (!contextclass) { 14655 /* \$ accepts any scalar lvalue */ 14656 if (Perl_op_lvalue_flags(aTHX_ 14657 scalar(o3), 14658 OP_READ, /* not entersub */ 14659 OP_LVALUE_NO_CROAK 14660 )) goto wrapref; 14661 bad_type_gv(arg, namegv, o3, "scalar"); 14662 } 14663 break; 14664 case '@': 14665 if (o3->op_type == OP_RV2AV || 14666 o3->op_type == OP_PADAV) 14667 { 14668 o3->op_flags &=~ OPf_PARENS; 14669 goto wrapref; 14670 } 14671 if (!contextclass) 14672 bad_type_gv(arg, namegv, o3, "array"); 14673 break; 14674 case '%': 14675 if (o3->op_type == OP_RV2HV || 14676 o3->op_type == OP_PADHV) 14677 { 14678 o3->op_flags &=~ OPf_PARENS; 14679 goto wrapref; 14680 } 14681 if (!contextclass) 14682 bad_type_gv(arg, namegv, o3, "hash"); 14683 break; 14684 wrapref: 14685 aop = S_op_sibling_newUNOP(aTHX_ parent, prev, 14686 OP_REFGEN, 0); 14687 if (contextclass && e) { 14688 proto = e + 1; 14689 contextclass = 0; 14690 } 14691 break; 14692 default: goto oops; 14693 } 14694 if (contextclass) 14695 goto again; 14696 break; 14697 case ' ': 14698 proto++; 14699 continue; 14700 default: 14701 oops: { 14702 Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf, 14703 SVfARG(cv_name((CV *)namegv, NULL, 0)), 14704 SVfARG(protosv)); 14705 } 14706 } 14707 14708 op_lvalue(aop, OP_ENTERSUB); 14709 prev = aop; 14710 aop = OpSIBLING(aop); 14711 } 14712 if (aop == cvop && *proto == '_') { 14713 /* generate an access to $_ */ 14714 op_sibling_splice(parent, prev, 0, newDEFSVOP()); 14715 } 14716 if (!optional && proto_end > proto && 14717 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_')) 14718 { 14719 SV * const namesv = cv_name((CV *)namegv, NULL, 0); 14720 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf, 14721 SVfARG(namesv)), SvUTF8(namesv)); 14722 } 14723 return entersubop; 14724 } 14725 14726 /* 14727 =for apidoc ck_entersub_args_proto_or_list 14728 14729 Performs the fixup of the arguments part of an C<entersub> op tree either 14730 based on a subroutine prototype or using default list-context processing. 14731 This is the standard treatment used on a subroutine call, not marked 14732 with C<&>, where the callee can be identified at compile time. 14733 14734 C<protosv> supplies the subroutine prototype to be applied to the call, 14735 or indicates that there is no prototype. It may be a normal scalar, 14736 in which case if it is defined then the string value will be used 14737 as a prototype, and if it is undefined then there is no prototype. 14738 Alternatively, for convenience, it may be a subroutine object (a C<CV*> 14739 that has been cast to C<SV*>), of which the prototype will be used if it 14740 has one. The prototype (or lack thereof) supplied, in whichever form, 14741 does not need to match the actual callee referenced by the op tree. 14742 14743 If the argument ops disagree with the prototype, for example by having 14744 an unacceptable number of arguments, a valid op tree is returned anyway. 14745 The error is reflected in the parser state, normally resulting in a single 14746 exception at the top level of parsing which covers all the compilation 14747 errors that occurred. In the error message, the callee is referred to 14748 by the name defined by the C<namegv> parameter. 14749 14750 =cut 14751 */ 14752 14753 OP * 14754 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop, 14755 GV *namegv, SV *protosv) 14756 { 14757 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST; 14758 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv)) 14759 return ck_entersub_args_proto(entersubop, namegv, protosv); 14760 else 14761 return ck_entersub_args_list(entersubop); 14762 } 14763 14764 OP * 14765 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv) 14766 { 14767 IV cvflags = SvIVX(protosv); 14768 int opnum = cvflags & 0xffff; 14769 OP *aop = cUNOPx(entersubop)->op_first; 14770 14771 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE; 14772 14773 if (!opnum) { 14774 OP *cvop; 14775 if (!OpHAS_SIBLING(aop)) 14776 aop = cUNOPx(aop)->op_first; 14777 aop = OpSIBLING(aop); 14778 for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ; 14779 if (aop != cvop) { 14780 SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL); 14781 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf, 14782 SVfARG(namesv)), SvUTF8(namesv)); 14783 } 14784 14785 op_free(entersubop); 14786 switch(cvflags >> 16) { 14787 case 'F': return newSVOP(OP_CONST, 0, 14788 newSVpv(CopFILE(PL_curcop),0)); 14789 case 'L': return newSVOP( 14790 OP_CONST, 0, 14791 Perl_newSVpvf(aTHX_ 14792 "%" IVdf, (IV)CopLINE(PL_curcop) 14793 ) 14794 ); 14795 case 'P': return newSVOP(OP_CONST, 0, 14796 (PL_curstash 14797 ? newSVhek(HvNAME_HEK(PL_curstash)) 14798 : &PL_sv_undef 14799 ) 14800 ); 14801 } 14802 NOT_REACHED; /* NOTREACHED */ 14803 } 14804 else { 14805 OP *prev, *cvop, *first, *parent; 14806 U32 flags = 0; 14807 14808 parent = entersubop; 14809 if (!OpHAS_SIBLING(aop)) { 14810 parent = aop; 14811 aop = cUNOPx(aop)->op_first; 14812 } 14813 14814 first = prev = aop; 14815 aop = OpSIBLING(aop); 14816 /* find last sibling */ 14817 for (cvop = aop; 14818 OpHAS_SIBLING(cvop); 14819 prev = cvop, cvop = OpSIBLING(cvop)) 14820 ; 14821 if (!(cvop->op_private & OPpENTERSUB_NOPAREN) 14822 /* Usually, OPf_SPECIAL on an op with no args means that it had 14823 * parens, but these have their own meaning for that flag: */ 14824 && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH 14825 && opnum != OP_DELETE && opnum != OP_EXISTS) 14826 flags |= OPf_SPECIAL; 14827 /* excise cvop from end of sibling chain */ 14828 op_sibling_splice(parent, prev, 1, NULL); 14829 op_free(cvop); 14830 if (aop == cvop) aop = NULL; 14831 14832 /* detach remaining siblings from the first sibling, then 14833 * dispose of original optree */ 14834 14835 if (aop) 14836 op_sibling_splice(parent, first, -1, NULL); 14837 op_free(entersubop); 14838 14839 if (cvflags == (OP_ENTEREVAL | (1<<16))) 14840 flags |= OPpEVAL_BYTES <<8; 14841 14842 switch (PL_opargs[opnum] & OA_CLASS_MASK) { 14843 case OA_UNOP: 14844 case OA_BASEOP_OR_UNOP: 14845 case OA_FILESTATOP: 14846 if (!aop) 14847 return newOP(opnum,flags); /* zero args */ 14848 if (aop == prev) 14849 return newUNOP(opnum,flags,aop); /* one arg */ 14850 /* too many args */ 14851 /* FALLTHROUGH */ 14852 case OA_BASEOP: 14853 if (aop) { 14854 SV *namesv; 14855 OP *nextop; 14856 14857 namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL); 14858 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf, 14859 SVfARG(namesv)), SvUTF8(namesv)); 14860 while (aop) { 14861 nextop = OpSIBLING(aop); 14862 op_free(aop); 14863 aop = nextop; 14864 } 14865 14866 } 14867 return opnum == OP_RUNCV 14868 ? newPVOP(OP_RUNCV,0,NULL) 14869 : newOP(opnum,0); 14870 default: 14871 return op_convert_list(opnum,0,aop); 14872 } 14873 } 14874 NOT_REACHED; /* NOTREACHED */ 14875 return entersubop; 14876 } 14877 14878 /* 14879 =for apidoc cv_get_call_checker_flags 14880 14881 Retrieves the function that will be used to fix up a call to C<cv>. 14882 Specifically, the function is applied to an C<entersub> op tree for a 14883 subroutine call, not marked with C<&>, where the callee can be identified 14884 at compile time as C<cv>. 14885 14886 The C-level function pointer is returned in C<*ckfun_p>, an SV argument 14887 for it is returned in C<*ckobj_p>, and control flags are returned in 14888 C<*ckflags_p>. The function is intended to be called in this manner: 14889 14890 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p)); 14891 14892 In this call, C<entersubop> is a pointer to the C<entersub> op, 14893 which may be replaced by the check function, and C<namegv> supplies 14894 the name that should be used by the check function to refer 14895 to the callee of the C<entersub> op if it needs to emit any diagnostics. 14896 It is permitted to apply the check function in non-standard situations, 14897 such as to a call to a different subroutine or to a method call. 14898 14899 C<namegv> may not actually be a GV. If the C<CALL_CHECKER_REQUIRE_GV> 14900 bit is clear in C<*ckflags_p>, it is permitted to pass a CV or other SV 14901 instead, anything that can be used as the first argument to L</cv_name>. 14902 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<*ckflags_p> then the 14903 check function requires C<namegv> to be a genuine GV. 14904 14905 By default, the check function is 14906 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>, 14907 the SV parameter is C<cv> itself, and the C<CALL_CHECKER_REQUIRE_GV> 14908 flag is clear. This implements standard prototype processing. It can 14909 be changed, for a particular subroutine, by L</cv_set_call_checker_flags>. 14910 14911 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<gflags> then it 14912 indicates that the caller only knows about the genuine GV version of 14913 C<namegv>, and accordingly the corresponding bit will always be set in 14914 C<*ckflags_p>, regardless of the check function's recorded requirements. 14915 If the C<CALL_CHECKER_REQUIRE_GV> bit is clear in C<gflags> then it 14916 indicates the caller knows about the possibility of passing something 14917 other than a GV as C<namegv>, and accordingly the corresponding bit may 14918 be either set or clear in C<*ckflags_p>, indicating the check function's 14919 recorded requirements. 14920 14921 C<gflags> is a bitset passed into C<cv_get_call_checker_flags>, in which 14922 only the C<CALL_CHECKER_REQUIRE_GV> bit currently has a defined meaning 14923 (for which see above). All other bits should be clear. 14924 14925 =for apidoc Amnh||CALL_CHECKER_REQUIRE_GV 14926 14927 =for apidoc cv_get_call_checker 14928 14929 The original form of L</cv_get_call_checker_flags>, which does not return 14930 checker flags. When using a checker function returned by this function, 14931 it is only safe to call it with a genuine GV as its C<namegv> argument. 14932 14933 =cut 14934 */ 14935 14936 void 14937 Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags, 14938 Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p) 14939 { 14940 MAGIC *callmg; 14941 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS; 14942 PERL_UNUSED_CONTEXT; 14943 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL; 14944 if (callmg) { 14945 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr); 14946 *ckobj_p = callmg->mg_obj; 14947 *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV; 14948 } else { 14949 *ckfun_p = Perl_ck_entersub_args_proto_or_list; 14950 *ckobj_p = (SV*)cv; 14951 *ckflags_p = gflags & MGf_REQUIRE_GV; 14952 } 14953 } 14954 14955 void 14956 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p) 14957 { 14958 U32 ckflags; 14959 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER; 14960 PERL_UNUSED_CONTEXT; 14961 cv_get_call_checker_flags(cv, CALL_CHECKER_REQUIRE_GV, ckfun_p, ckobj_p, 14962 &ckflags); 14963 } 14964 14965 /* 14966 =for apidoc cv_set_call_checker_flags 14967 14968 Sets the function that will be used to fix up a call to C<cv>. 14969 Specifically, the function is applied to an C<entersub> op tree for a 14970 subroutine call, not marked with C<&>, where the callee can be identified 14971 at compile time as C<cv>. 14972 14973 The C-level function pointer is supplied in C<ckfun>, an SV argument for 14974 it is supplied in C<ckobj>, and control flags are supplied in C<ckflags>. 14975 The function should be defined like this: 14976 14977 STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj) 14978 14979 It is intended to be called in this manner: 14980 14981 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj); 14982 14983 In this call, C<entersubop> is a pointer to the C<entersub> op, 14984 which may be replaced by the check function, and C<namegv> supplies 14985 the name that should be used by the check function to refer 14986 to the callee of the C<entersub> op if it needs to emit any diagnostics. 14987 It is permitted to apply the check function in non-standard situations, 14988 such as to a call to a different subroutine or to a method call. 14989 14990 C<namegv> may not actually be a GV. For efficiency, perl may pass a 14991 CV or other SV instead. Whatever is passed can be used as the first 14992 argument to L</cv_name>. You can force perl to pass a GV by including 14993 C<CALL_CHECKER_REQUIRE_GV> in the C<ckflags>. 14994 14995 C<ckflags> is a bitset, in which only the C<CALL_CHECKER_REQUIRE_GV> 14996 bit currently has a defined meaning (for which see above). All other 14997 bits should be clear. 14998 14999 The current setting for a particular CV can be retrieved by 15000 L</cv_get_call_checker_flags>. 15001 15002 =for apidoc cv_set_call_checker 15003 15004 The original form of L</cv_set_call_checker_flags>, which passes it the 15005 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility. The effect 15006 of that flag setting is that the check function is guaranteed to get a 15007 genuine GV as its C<namegv> argument. 15008 15009 =cut 15010 */ 15011 15012 void 15013 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj) 15014 { 15015 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER; 15016 cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV); 15017 } 15018 15019 void 15020 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun, 15021 SV *ckobj, U32 ckflags) 15022 { 15023 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS; 15024 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) { 15025 if (SvMAGICAL((SV*)cv)) 15026 mg_free_type((SV*)cv, PERL_MAGIC_checkcall); 15027 } else { 15028 MAGIC *callmg; 15029 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0); 15030 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall); 15031 assert(callmg); 15032 if (callmg->mg_flags & MGf_REFCOUNTED) { 15033 SvREFCNT_dec(callmg->mg_obj); 15034 callmg->mg_flags &= ~MGf_REFCOUNTED; 15035 } 15036 callmg->mg_ptr = FPTR2DPTR(char *, ckfun); 15037 callmg->mg_obj = ckobj; 15038 if (ckobj != (SV*)cv) { 15039 SvREFCNT_inc_simple_void_NN(ckobj); 15040 callmg->mg_flags |= MGf_REFCOUNTED; 15041 } 15042 callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV) 15043 | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY; 15044 } 15045 } 15046 15047 static void 15048 S_entersub_alloc_targ(pTHX_ OP * const o) 15049 { 15050 o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP); 15051 o->op_private |= OPpENTERSUB_HASTARG; 15052 } 15053 15054 OP * 15055 Perl_ck_subr(pTHX_ OP *o) 15056 { 15057 OP *aop, *cvop; 15058 CV *cv; 15059 GV *namegv; 15060 SV **const_class = NULL; 15061 15062 PERL_ARGS_ASSERT_CK_SUBR; 15063 15064 aop = cUNOPx(o)->op_first; 15065 if (!OpHAS_SIBLING(aop)) 15066 aop = cUNOPx(aop)->op_first; 15067 aop = OpSIBLING(aop); 15068 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ; 15069 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY); 15070 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL; 15071 15072 o->op_private &= ~1; 15073 o->op_private |= (PL_hints & HINT_STRICT_REFS); 15074 if (PERLDB_SUB && PL_curstash != PL_debstash) 15075 o->op_private |= OPpENTERSUB_DB; 15076 switch (cvop->op_type) { 15077 case OP_RV2CV: 15078 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER); 15079 op_null(cvop); 15080 break; 15081 case OP_METHOD: 15082 case OP_METHOD_NAMED: 15083 case OP_METHOD_SUPER: 15084 case OP_METHOD_REDIR: 15085 case OP_METHOD_REDIR_SUPER: 15086 o->op_flags |= OPf_REF; 15087 if (aop->op_type == OP_CONST) { 15088 aop->op_private &= ~OPpCONST_STRICT; 15089 const_class = &cSVOPx(aop)->op_sv; 15090 } 15091 else if (aop->op_type == OP_LIST) { 15092 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first); 15093 if (sib && sib->op_type == OP_CONST) { 15094 sib->op_private &= ~OPpCONST_STRICT; 15095 const_class = &cSVOPx(sib)->op_sv; 15096 } 15097 } 15098 /* make class name a shared cow string to speedup method calls */ 15099 /* constant string might be replaced with object, f.e. bigint */ 15100 if (const_class && SvPOK(*const_class)) { 15101 STRLEN len; 15102 const char* str = SvPV(*const_class, len); 15103 if (len) { 15104 SV* const shared = newSVpvn_share( 15105 str, SvUTF8(*const_class) 15106 ? -(SSize_t)len : (SSize_t)len, 15107 0 15108 ); 15109 if (SvREADONLY(*const_class)) 15110 SvREADONLY_on(shared); 15111 SvREFCNT_dec(*const_class); 15112 *const_class = shared; 15113 } 15114 } 15115 break; 15116 } 15117 15118 if (!cv) { 15119 S_entersub_alloc_targ(aTHX_ o); 15120 return ck_entersub_args_list(o); 15121 } else { 15122 Perl_call_checker ckfun; 15123 SV *ckobj; 15124 U32 ckflags; 15125 cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags); 15126 if (CvISXSUB(cv) || !CvROOT(cv)) 15127 S_entersub_alloc_targ(aTHX_ o); 15128 if (!namegv) { 15129 /* The original call checker API guarantees that a GV will 15130 be provided with the right name. So, if the old API was 15131 used (or the REQUIRE_GV flag was passed), we have to reify 15132 the CV’s GV, unless this is an anonymous sub. This is not 15133 ideal for lexical subs, as its stringification will include 15134 the package. But it is the best we can do. */ 15135 if (ckflags & CALL_CHECKER_REQUIRE_GV) { 15136 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv))) 15137 namegv = CvGV(cv); 15138 } 15139 else namegv = MUTABLE_GV(cv); 15140 /* After a syntax error in a lexical sub, the cv that 15141 rv2cv_op_cv returns may be a nameless stub. */ 15142 if (!namegv) return ck_entersub_args_list(o); 15143 15144 } 15145 return ckfun(aTHX_ o, namegv, ckobj); 15146 } 15147 } 15148 15149 OP * 15150 Perl_ck_svconst(pTHX_ OP *o) 15151 { 15152 SV * const sv = cSVOPo->op_sv; 15153 PERL_ARGS_ASSERT_CK_SVCONST; 15154 PERL_UNUSED_CONTEXT; 15155 #ifdef PERL_COPY_ON_WRITE 15156 /* Since the read-only flag may be used to protect a string buffer, we 15157 cannot do copy-on-write with existing read-only scalars that are not 15158 already copy-on-write scalars. To allow $_ = "hello" to do COW with 15159 that constant, mark the constant as COWable here, if it is not 15160 already read-only. */ 15161 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) { 15162 SvIsCOW_on(sv); 15163 CowREFCNT(sv) = 0; 15164 # ifdef PERL_DEBUG_READONLY_COW 15165 sv_buf_to_ro(sv); 15166 # endif 15167 } 15168 #endif 15169 SvREADONLY_on(sv); 15170 return o; 15171 } 15172 15173 OP * 15174 Perl_ck_trunc(pTHX_ OP *o) 15175 { 15176 PERL_ARGS_ASSERT_CK_TRUNC; 15177 15178 if (o->op_flags & OPf_KIDS) { 15179 SVOP *kid = (SVOP*)cUNOPo->op_first; 15180 15181 if (kid->op_type == OP_NULL) 15182 kid = (SVOP*)OpSIBLING(kid); 15183 if (kid && kid->op_type == OP_CONST && 15184 (kid->op_private & OPpCONST_BARE) && 15185 !kid->op_folded) 15186 { 15187 o->op_flags |= OPf_SPECIAL; 15188 kid->op_private &= ~OPpCONST_STRICT; 15189 } 15190 } 15191 return ck_fun(o); 15192 } 15193 15194 OP * 15195 Perl_ck_substr(pTHX_ OP *o) 15196 { 15197 PERL_ARGS_ASSERT_CK_SUBSTR; 15198 15199 o = ck_fun(o); 15200 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) { 15201 OP *kid = cLISTOPo->op_first; 15202 15203 if (kid->op_type == OP_NULL) 15204 kid = OpSIBLING(kid); 15205 if (kid) 15206 /* Historically, substr(delete $foo{bar},...) has been allowed 15207 with 4-arg substr. Keep it working by applying entersub 15208 lvalue context. */ 15209 op_lvalue(kid, OP_ENTERSUB); 15210 15211 } 15212 return o; 15213 } 15214 15215 OP * 15216 Perl_ck_tell(pTHX_ OP *o) 15217 { 15218 PERL_ARGS_ASSERT_CK_TELL; 15219 o = ck_fun(o); 15220 if (o->op_flags & OPf_KIDS) { 15221 OP *kid = cLISTOPo->op_first; 15222 if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid); 15223 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE; 15224 } 15225 return o; 15226 } 15227 15228 OP * 15229 Perl_ck_each(pTHX_ OP *o) 15230 { 15231 dVAR; 15232 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL; 15233 const unsigned orig_type = o->op_type; 15234 15235 PERL_ARGS_ASSERT_CK_EACH; 15236 15237 if (kid) { 15238 switch (kid->op_type) { 15239 case OP_PADHV: 15240 case OP_RV2HV: 15241 break; 15242 case OP_PADAV: 15243 case OP_RV2AV: 15244 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH 15245 : orig_type == OP_KEYS ? OP_AKEYS 15246 : OP_AVALUES); 15247 break; 15248 case OP_CONST: 15249 if (kid->op_private == OPpCONST_BARE 15250 || !SvROK(cSVOPx_sv(kid)) 15251 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV 15252 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV ) 15253 ) 15254 goto bad; 15255 /* FALLTHROUGH */ 15256 default: 15257 qerror(Perl_mess(aTHX_ 15258 "Experimental %s on scalar is now forbidden", 15259 PL_op_desc[orig_type])); 15260 bad: 15261 bad_type_pv(1, "hash or array", o, kid); 15262 return o; 15263 } 15264 } 15265 return ck_fun(o); 15266 } 15267 15268 OP * 15269 Perl_ck_length(pTHX_ OP *o) 15270 { 15271 PERL_ARGS_ASSERT_CK_LENGTH; 15272 15273 o = ck_fun(o); 15274 15275 if (ckWARN(WARN_SYNTAX)) { 15276 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL; 15277 15278 if (kid) { 15279 SV *name = NULL; 15280 const bool hash = kid->op_type == OP_PADHV 15281 || kid->op_type == OP_RV2HV; 15282 switch (kid->op_type) { 15283 case OP_PADHV: 15284 case OP_PADAV: 15285 case OP_RV2HV: 15286 case OP_RV2AV: 15287 name = S_op_varname(aTHX_ kid); 15288 break; 15289 default: 15290 return o; 15291 } 15292 if (name) 15293 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 15294 "length() used on %" SVf " (did you mean \"scalar(%s%" SVf 15295 ")\"?)", 15296 SVfARG(name), hash ? "keys " : "", SVfARG(name) 15297 ); 15298 else if (hash) 15299 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */ 15300 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 15301 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)"); 15302 else 15303 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */ 15304 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 15305 "length() used on @array (did you mean \"scalar(@array)\"?)"); 15306 } 15307 } 15308 15309 return o; 15310 } 15311 15312 15313 OP * 15314 Perl_ck_isa(pTHX_ OP *o) 15315 { 15316 OP *classop = cBINOPo->op_last; 15317 15318 PERL_ARGS_ASSERT_CK_ISA; 15319 15320 /* Convert barename into PV */ 15321 if(classop->op_type == OP_CONST && classop->op_private & OPpCONST_BARE) { 15322 /* TODO: Optionally convert package to raw HV here */ 15323 classop->op_private &= ~(OPpCONST_BARE|OPpCONST_STRICT); 15324 } 15325 15326 return o; 15327 } 15328 15329 15330 /* 15331 --------------------------------------------------------- 15332 15333 Common vars in list assignment 15334 15335 There now follows some enums and static functions for detecting 15336 common variables in list assignments. Here is a little essay I wrote 15337 for myself when trying to get my head around this. DAPM. 15338 15339 ---- 15340 15341 First some random observations: 15342 15343 * If a lexical var is an alias of something else, e.g. 15344 for my $x ($lex, $pkg, $a[0]) {...} 15345 then the act of aliasing will increase the reference count of the SV 15346 15347 * If a package var is an alias of something else, it may still have a 15348 reference count of 1, depending on how the alias was created, e.g. 15349 in *a = *b, $a may have a refcount of 1 since the GP is shared 15350 with a single GvSV pointer to the SV. So If it's an alias of another 15351 package var, then RC may be 1; if it's an alias of another scalar, e.g. 15352 a lexical var or an array element, then it will have RC > 1. 15353 15354 * There are many ways to create a package alias; ultimately, XS code 15355 may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so 15356 run-time tracing mechanisms are unlikely to be able to catch all cases. 15357 15358 * When the LHS is all my declarations, the same vars can't appear directly 15359 on the RHS, but they can indirectly via closures, aliasing and lvalue 15360 subs. But those techniques all involve an increase in the lexical 15361 scalar's ref count. 15362 15363 * When the LHS is all lexical vars (but not necessarily my declarations), 15364 it is possible for the same lexicals to appear directly on the RHS, and 15365 without an increased ref count, since the stack isn't refcounted. 15366 This case can be detected at compile time by scanning for common lex 15367 vars with PL_generation. 15368 15369 * lvalue subs defeat common var detection, but they do at least 15370 return vars with a temporary ref count increment. Also, you can't 15371 tell at compile time whether a sub call is lvalue. 15372 15373 15374 So... 15375 15376 A: There are a few circumstances where there definitely can't be any 15377 commonality: 15378 15379 LHS empty: () = (...); 15380 RHS empty: (....) = (); 15381 RHS contains only constants or other 'can't possibly be shared' 15382 elements (e.g. ops that return PADTMPs): (...) = (1,2, length) 15383 i.e. they only contain ops not marked as dangerous, whose children 15384 are also not dangerous; 15385 LHS ditto; 15386 LHS contains a single scalar element: e.g. ($x) = (....); because 15387 after $x has been modified, it won't be used again on the RHS; 15388 RHS contains a single element with no aggregate on LHS: e.g. 15389 ($a,$b,$c) = ($x); again, once $a has been modified, its value 15390 won't be used again. 15391 15392 B: If LHS are all 'my' lexical var declarations (or safe ops, which 15393 we can ignore): 15394 15395 my ($a, $b, @c) = ...; 15396 15397 Due to closure and goto tricks, these vars may already have content. 15398 For the same reason, an element on the RHS may be a lexical or package 15399 alias of one of the vars on the left, or share common elements, for 15400 example: 15401 15402 my ($x,$y) = f(); # $x and $y on both sides 15403 sub f : lvalue { ($x,$y) = (1,2); $y, $x } 15404 15405 and 15406 15407 my $ra = f(); 15408 my @a = @$ra; # elements of @a on both sides 15409 sub f { @a = 1..4; \@a } 15410 15411 15412 First, just consider scalar vars on LHS: 15413 15414 RHS is safe only if (A), or in addition, 15415 * contains only lexical *scalar* vars, where neither side's 15416 lexicals have been flagged as aliases 15417 15418 If RHS is not safe, then it's always legal to check LHS vars for 15419 RC==1, since the only RHS aliases will always be associated 15420 with an RC bump. 15421 15422 Note that in particular, RHS is not safe if: 15423 15424 * it contains package scalar vars; e.g.: 15425 15426 f(); 15427 my ($x, $y) = (2, $x_alias); 15428 sub f { $x = 1; *x_alias = \$x; } 15429 15430 * It contains other general elements, such as flattened or 15431 * spliced or single array or hash elements, e.g. 15432 15433 f(); 15434 my ($x,$y) = @a; # or $a[0] or @a{@b} etc 15435 15436 sub f { 15437 ($x, $y) = (1,2); 15438 use feature 'refaliasing'; 15439 \($a[0], $a[1]) = \($y,$x); 15440 } 15441 15442 It doesn't matter if the array/hash is lexical or package. 15443 15444 * it contains a function call that happens to be an lvalue 15445 sub which returns one or more of the above, e.g. 15446 15447 f(); 15448 my ($x,$y) = f(); 15449 15450 sub f : lvalue { 15451 ($x, $y) = (1,2); 15452 *x1 = \$x; 15453 $y, $x1; 15454 } 15455 15456 (so a sub call on the RHS should be treated the same 15457 as having a package var on the RHS). 15458 15459 * any other "dangerous" thing, such an op or built-in that 15460 returns one of the above, e.g. pp_preinc 15461 15462 15463 If RHS is not safe, what we can do however is at compile time flag 15464 that the LHS are all my declarations, and at run time check whether 15465 all the LHS have RC == 1, and if so skip the full scan. 15466 15467 Now consider array and hash vars on LHS: e.g. my (...,@a) = ...; 15468 15469 Here the issue is whether there can be elements of @a on the RHS 15470 which will get prematurely freed when @a is cleared prior to 15471 assignment. This is only a problem if the aliasing mechanism 15472 is one which doesn't increase the refcount - only if RC == 1 15473 will the RHS element be prematurely freed. 15474 15475 Because the array/hash is being INTROed, it or its elements 15476 can't directly appear on the RHS: 15477 15478 my (@a) = ($a[0], @a, etc) # NOT POSSIBLE 15479 15480 but can indirectly, e.g.: 15481 15482 my $r = f(); 15483 my (@a) = @$r; 15484 sub f { @a = 1..3; \@a } 15485 15486 So if the RHS isn't safe as defined by (A), we must always 15487 mortalise and bump the ref count of any remaining RHS elements 15488 when assigning to a non-empty LHS aggregate. 15489 15490 Lexical scalars on the RHS aren't safe if they've been involved in 15491 aliasing, e.g. 15492 15493 use feature 'refaliasing'; 15494 15495 f(); 15496 \(my $lex) = \$pkg; 15497 my @a = ($lex,3); # equivalent to ($a[0],3) 15498 15499 sub f { 15500 @a = (1,2); 15501 \$pkg = \$a[0]; 15502 } 15503 15504 Similarly with lexical arrays and hashes on the RHS: 15505 15506 f(); 15507 my @b; 15508 my @a = (@b); 15509 15510 sub f { 15511 @a = (1,2); 15512 \$b[0] = \$a[1]; 15513 \$b[1] = \$a[0]; 15514 } 15515 15516 15517 15518 C: As (B), but in addition the LHS may contain non-intro lexicals, e.g. 15519 my $a; ($a, my $b) = (....); 15520 15521 The difference between (B) and (C) is that it is now physically 15522 possible for the LHS vars to appear on the RHS too, where they 15523 are not reference counted; but in this case, the compile-time 15524 PL_generation sweep will detect such common vars. 15525 15526 So the rules for (C) differ from (B) in that if common vars are 15527 detected, the runtime "test RC==1" optimisation can no longer be used, 15528 and a full mark and sweep is required 15529 15530 D: As (C), but in addition the LHS may contain package vars. 15531 15532 Since package vars can be aliased without a corresponding refcount 15533 increase, all bets are off. It's only safe if (A). E.g. 15534 15535 my ($x, $y) = (1,2); 15536 15537 for $x_alias ($x) { 15538 ($x_alias, $y) = (3, $x); # whoops 15539 } 15540 15541 Ditto for LHS aggregate package vars. 15542 15543 E: Any other dangerous ops on LHS, e.g. 15544 (f(), $a[0], @$r) = (...); 15545 15546 this is similar to (E) in that all bets are off. In addition, it's 15547 impossible to determine at compile time whether the LHS 15548 contains a scalar or an aggregate, e.g. 15549 15550 sub f : lvalue { @a } 15551 (f()) = 1..3; 15552 15553 * --------------------------------------------------------- 15554 */ 15555 15556 15557 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates 15558 * that at least one of the things flagged was seen. 15559 */ 15560 15561 enum { 15562 AAS_MY_SCALAR = 0x001, /* my $scalar */ 15563 AAS_MY_AGG = 0x002, /* aggregate: my @array or my %hash */ 15564 AAS_LEX_SCALAR = 0x004, /* $lexical */ 15565 AAS_LEX_AGG = 0x008, /* @lexical or %lexical aggregate */ 15566 AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */ 15567 AAS_PKG_SCALAR = 0x020, /* $scalar (where $scalar is pkg var) */ 15568 AAS_PKG_AGG = 0x040, /* package @array or %hash aggregate */ 15569 AAS_DANGEROUS = 0x080, /* an op (other than the above) 15570 that's flagged OA_DANGEROUS */ 15571 AAS_SAFE_SCALAR = 0x100, /* produces at least one scalar SV that's 15572 not in any of the categories above */ 15573 AAS_DEFAV = 0x200 /* contains just a single '@_' on RHS */ 15574 }; 15575 15576 15577 15578 /* helper function for S_aassign_scan(). 15579 * check a PAD-related op for commonality and/or set its generation number. 15580 * Returns a boolean indicating whether its shared */ 15581 15582 static bool 15583 S_aassign_padcheck(pTHX_ OP* o, bool rhs) 15584 { 15585 if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX) 15586 /* lexical used in aliasing */ 15587 return TRUE; 15588 15589 if (rhs) 15590 return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation); 15591 else 15592 PAD_COMPNAME_GEN_set(o->op_targ, PL_generation); 15593 15594 return FALSE; 15595 } 15596 15597 15598 /* 15599 Helper function for OPpASSIGN_COMMON* detection in rpeep(). 15600 It scans the left or right hand subtree of the aassign op, and returns a 15601 set of flags indicating what sorts of things it found there. 15602 'rhs' indicates whether we're scanning the LHS or RHS. If the former, we 15603 set PL_generation on lexical vars; if the latter, we see if 15604 PL_generation matches. 15605 'scalars_p' is a pointer to a counter of the number of scalar SVs seen. 15606 This fn will increment it by the number seen. It's not intended to 15607 be an accurate count (especially as many ops can push a variable 15608 number of SVs onto the stack); rather it's used as to test whether there 15609 can be at most 1 SV pushed; so it's only meanings are "0, 1, many". 15610 */ 15611 15612 static int 15613 S_aassign_scan(pTHX_ OP* o, bool rhs, int *scalars_p) 15614 { 15615 OP *top_op = o; 15616 OP *effective_top_op = o; 15617 int all_flags = 0; 15618 15619 while (1) { 15620 bool top = o == effective_top_op; 15621 int flags = 0; 15622 OP* next_kid = NULL; 15623 15624 /* first, look for a solitary @_ on the RHS */ 15625 if ( rhs 15626 && top 15627 && (o->op_flags & OPf_KIDS) 15628 && OP_TYPE_IS_OR_WAS(o, OP_LIST) 15629 ) { 15630 OP *kid = cUNOPo->op_first; 15631 if ( ( kid->op_type == OP_PUSHMARK 15632 || kid->op_type == OP_PADRANGE) /* ex-pushmark */ 15633 && ((kid = OpSIBLING(kid))) 15634 && !OpHAS_SIBLING(kid) 15635 && kid->op_type == OP_RV2AV 15636 && !(kid->op_flags & OPf_REF) 15637 && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB)) 15638 && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST) 15639 && ((kid = cUNOPx(kid)->op_first)) 15640 && kid->op_type == OP_GV 15641 && cGVOPx_gv(kid) == PL_defgv 15642 ) 15643 flags = AAS_DEFAV; 15644 } 15645 15646 switch (o->op_type) { 15647 case OP_GVSV: 15648 (*scalars_p)++; 15649 all_flags |= AAS_PKG_SCALAR; 15650 goto do_next; 15651 15652 case OP_PADAV: 15653 case OP_PADHV: 15654 (*scalars_p) += 2; 15655 /* if !top, could be e.g. @a[0,1] */ 15656 all_flags |= (top && (o->op_flags & OPf_REF)) 15657 ? ((o->op_private & OPpLVAL_INTRO) 15658 ? AAS_MY_AGG : AAS_LEX_AGG) 15659 : AAS_DANGEROUS; 15660 goto do_next; 15661 15662 case OP_PADSV: 15663 { 15664 int comm = S_aassign_padcheck(aTHX_ o, rhs) 15665 ? AAS_LEX_SCALAR_COMM : 0; 15666 (*scalars_p)++; 15667 all_flags |= (o->op_private & OPpLVAL_INTRO) 15668 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm); 15669 goto do_next; 15670 15671 } 15672 15673 case OP_RV2AV: 15674 case OP_RV2HV: 15675 (*scalars_p) += 2; 15676 if (cUNOPx(o)->op_first->op_type != OP_GV) 15677 all_flags |= AAS_DANGEROUS; /* @{expr}, %{expr} */ 15678 /* @pkg, %pkg */ 15679 /* if !top, could be e.g. @a[0,1] */ 15680 else if (top && (o->op_flags & OPf_REF)) 15681 all_flags |= AAS_PKG_AGG; 15682 else 15683 all_flags |= AAS_DANGEROUS; 15684 goto do_next; 15685 15686 case OP_RV2SV: 15687 (*scalars_p)++; 15688 if (cUNOPx(o)->op_first->op_type != OP_GV) { 15689 (*scalars_p) += 2; 15690 all_flags |= AAS_DANGEROUS; /* ${expr} */ 15691 } 15692 else 15693 all_flags |= AAS_PKG_SCALAR; /* $pkg */ 15694 goto do_next; 15695 15696 case OP_SPLIT: 15697 if (o->op_private & OPpSPLIT_ASSIGN) { 15698 /* the assign in @a = split() has been optimised away 15699 * and the @a attached directly to the split op 15700 * Treat the array as appearing on the RHS, i.e. 15701 * ... = (@a = split) 15702 * is treated like 15703 * ... = @a; 15704 */ 15705 15706 if (o->op_flags & OPf_STACKED) { 15707 /* @{expr} = split() - the array expression is tacked 15708 * on as an extra child to split - process kid */ 15709 next_kid = cLISTOPo->op_last; 15710 goto do_next; 15711 } 15712 15713 /* ... else array is directly attached to split op */ 15714 (*scalars_p) += 2; 15715 all_flags |= (PL_op->op_private & OPpSPLIT_LEX) 15716 ? ((o->op_private & OPpLVAL_INTRO) 15717 ? AAS_MY_AGG : AAS_LEX_AGG) 15718 : AAS_PKG_AGG; 15719 goto do_next; 15720 } 15721 (*scalars_p)++; 15722 /* other args of split can't be returned */ 15723 all_flags |= AAS_SAFE_SCALAR; 15724 goto do_next; 15725 15726 case OP_UNDEF: 15727 /* undef on LHS following a var is significant, e.g. 15728 * my $x = 1; 15729 * @a = (($x, undef) = (2 => $x)); 15730 * # @a shoul be (2,1) not (2,2) 15731 * 15732 * undef on RHS counts as a scalar: 15733 * ($x, $y) = (undef, $x); # 2 scalars on RHS: unsafe 15734 */ 15735 if ((!rhs && *scalars_p) || rhs) 15736 (*scalars_p)++; 15737 flags = AAS_SAFE_SCALAR; 15738 break; 15739 15740 case OP_PUSHMARK: 15741 case OP_STUB: 15742 /* these are all no-ops; they don't push a potentially common SV 15743 * onto the stack, so they are neither AAS_DANGEROUS nor 15744 * AAS_SAFE_SCALAR */ 15745 goto do_next; 15746 15747 case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */ 15748 break; 15749 15750 case OP_NULL: 15751 case OP_LIST: 15752 /* these do nothing, but may have children */ 15753 break; 15754 15755 default: 15756 if (PL_opargs[o->op_type] & OA_DANGEROUS) { 15757 (*scalars_p) += 2; 15758 flags = AAS_DANGEROUS; 15759 break; 15760 } 15761 15762 if ( (PL_opargs[o->op_type] & OA_TARGLEX) 15763 && (o->op_private & OPpTARGET_MY)) 15764 { 15765 (*scalars_p)++; 15766 all_flags |= S_aassign_padcheck(aTHX_ o, rhs) 15767 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR; 15768 goto do_next; 15769 } 15770 15771 /* if its an unrecognised, non-dangerous op, assume that it 15772 * is the cause of at least one safe scalar */ 15773 (*scalars_p)++; 15774 flags = AAS_SAFE_SCALAR; 15775 break; 15776 } 15777 15778 all_flags |= flags; 15779 15780 /* by default, process all kids next 15781 * XXX this assumes that all other ops are "transparent" - i.e. that 15782 * they can return some of their children. While this true for e.g. 15783 * sort and grep, it's not true for e.g. map. We really need a 15784 * 'transparent' flag added to regen/opcodes 15785 */ 15786 if (o->op_flags & OPf_KIDS) { 15787 next_kid = cUNOPo->op_first; 15788 /* these ops do nothing but may have children; but their 15789 * children should also be treated as top-level */ 15790 if ( o == effective_top_op 15791 && (o->op_type == OP_NULL || o->op_type == OP_LIST) 15792 ) 15793 effective_top_op = next_kid; 15794 } 15795 15796 15797 /* If next_kid is set, someone in the code above wanted us to process 15798 * that kid and all its remaining siblings. Otherwise, work our way 15799 * back up the tree */ 15800 do_next: 15801 while (!next_kid) { 15802 if (o == top_op) 15803 return all_flags; /* at top; no parents/siblings to try */ 15804 if (OpHAS_SIBLING(o)) { 15805 next_kid = o->op_sibparent; 15806 if (o == effective_top_op) 15807 effective_top_op = next_kid; 15808 } 15809 else 15810 if (o == effective_top_op) 15811 effective_top_op = o->op_sibparent; 15812 o = o->op_sibparent; /* try parent's next sibling */ 15813 15814 } 15815 o = next_kid; 15816 } /* while */ 15817 15818 } 15819 15820 15821 /* Check for in place reverse and sort assignments like "@a = reverse @a" 15822 and modify the optree to make them work inplace */ 15823 15824 STATIC void 15825 S_inplace_aassign(pTHX_ OP *o) { 15826 15827 OP *modop, *modop_pushmark; 15828 OP *oright; 15829 OP *oleft, *oleft_pushmark; 15830 15831 PERL_ARGS_ASSERT_INPLACE_AASSIGN; 15832 15833 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID); 15834 15835 assert(cUNOPo->op_first->op_type == OP_NULL); 15836 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first; 15837 assert(modop_pushmark->op_type == OP_PUSHMARK); 15838 modop = OpSIBLING(modop_pushmark); 15839 15840 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE) 15841 return; 15842 15843 /* no other operation except sort/reverse */ 15844 if (OpHAS_SIBLING(modop)) 15845 return; 15846 15847 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK); 15848 if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return; 15849 15850 if (modop->op_flags & OPf_STACKED) { 15851 /* skip sort subroutine/block */ 15852 assert(oright->op_type == OP_NULL); 15853 oright = OpSIBLING(oright); 15854 } 15855 15856 assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL); 15857 oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first; 15858 assert(oleft_pushmark->op_type == OP_PUSHMARK); 15859 oleft = OpSIBLING(oleft_pushmark); 15860 15861 /* Check the lhs is an array */ 15862 if (!oleft || 15863 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV) 15864 || OpHAS_SIBLING(oleft) 15865 || (oleft->op_private & OPpLVAL_INTRO) 15866 ) 15867 return; 15868 15869 /* Only one thing on the rhs */ 15870 if (OpHAS_SIBLING(oright)) 15871 return; 15872 15873 /* check the array is the same on both sides */ 15874 if (oleft->op_type == OP_RV2AV) { 15875 if (oright->op_type != OP_RV2AV 15876 || !cUNOPx(oright)->op_first 15877 || cUNOPx(oright)->op_first->op_type != OP_GV 15878 || cUNOPx(oleft )->op_first->op_type != OP_GV 15879 || cGVOPx_gv(cUNOPx(oleft)->op_first) != 15880 cGVOPx_gv(cUNOPx(oright)->op_first) 15881 ) 15882 return; 15883 } 15884 else if (oright->op_type != OP_PADAV 15885 || oright->op_targ != oleft->op_targ 15886 ) 15887 return; 15888 15889 /* This actually is an inplace assignment */ 15890 15891 modop->op_private |= OPpSORT_INPLACE; 15892 15893 /* transfer MODishness etc from LHS arg to RHS arg */ 15894 oright->op_flags = oleft->op_flags; 15895 15896 /* remove the aassign op and the lhs */ 15897 op_null(o); 15898 op_null(oleft_pushmark); 15899 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first) 15900 op_null(cUNOPx(oleft)->op_first); 15901 op_null(oleft); 15902 } 15903 15904 15905 15906 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start' 15907 * that potentially represent a series of one or more aggregate derefs 15908 * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert 15909 * the whole chain to a single OP_MULTIDEREF op (maybe with a few 15910 * additional ops left in too). 15911 * 15912 * The caller will have already verified that the first few ops in the 15913 * chain following 'start' indicate a multideref candidate, and will have 15914 * set 'orig_o' to the point further on in the chain where the first index 15915 * expression (if any) begins. 'orig_action' specifies what type of 15916 * beginning has already been determined by the ops between start..orig_o 15917 * (e.g. $lex_ary[], $pkg_ary->{}, expr->[], etc). 15918 * 15919 * 'hints' contains any hints flags that need adding (currently just 15920 * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller. 15921 */ 15922 15923 STATIC void 15924 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints) 15925 { 15926 dVAR; 15927 int pass; 15928 UNOP_AUX_item *arg_buf = NULL; 15929 bool reset_start_targ = FALSE; /* start->op_targ needs zeroing */ 15930 int index_skip = -1; /* don't output index arg on this action */ 15931 15932 /* similar to regex compiling, do two passes; the first pass 15933 * determines whether the op chain is convertible and calculates the 15934 * buffer size; the second pass populates the buffer and makes any 15935 * changes necessary to ops (such as moving consts to the pad on 15936 * threaded builds). 15937 * 15938 * NB: for things like Coverity, note that both passes take the same 15939 * path through the logic tree (except for 'if (pass)' bits), since 15940 * both passes are following the same op_next chain; and in 15941 * particular, if it would return early on the second pass, it would 15942 * already have returned early on the first pass. 15943 */ 15944 for (pass = 0; pass < 2; pass++) { 15945 OP *o = orig_o; 15946 UV action = orig_action; 15947 OP *first_elem_op = NULL; /* first seen aelem/helem */ 15948 OP *top_op = NULL; /* highest [ah]elem/exists/del/rv2[ah]v */ 15949 int action_count = 0; /* number of actions seen so far */ 15950 int action_ix = 0; /* action_count % (actions per IV) */ 15951 bool next_is_hash = FALSE; /* is the next lookup to be a hash? */ 15952 bool is_last = FALSE; /* no more derefs to follow */ 15953 bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */ 15954 UV action_word = 0; /* all actions so far */ 15955 UNOP_AUX_item *arg = arg_buf; 15956 UNOP_AUX_item *action_ptr = arg_buf; 15957 15958 arg++; /* reserve slot for first action word */ 15959 15960 switch (action) { 15961 case MDEREF_HV_gvsv_vivify_rv2hv_helem: 15962 case MDEREF_HV_gvhv_helem: 15963 next_is_hash = TRUE; 15964 /* FALLTHROUGH */ 15965 case MDEREF_AV_gvsv_vivify_rv2av_aelem: 15966 case MDEREF_AV_gvav_aelem: 15967 if (pass) { 15968 #ifdef USE_ITHREADS 15969 arg->pad_offset = cPADOPx(start)->op_padix; 15970 /* stop it being swiped when nulled */ 15971 cPADOPx(start)->op_padix = 0; 15972 #else 15973 arg->sv = cSVOPx(start)->op_sv; 15974 cSVOPx(start)->op_sv = NULL; 15975 #endif 15976 } 15977 arg++; 15978 break; 15979 15980 case MDEREF_HV_padhv_helem: 15981 case MDEREF_HV_padsv_vivify_rv2hv_helem: 15982 next_is_hash = TRUE; 15983 /* FALLTHROUGH */ 15984 case MDEREF_AV_padav_aelem: 15985 case MDEREF_AV_padsv_vivify_rv2av_aelem: 15986 if (pass) { 15987 arg->pad_offset = start->op_targ; 15988 /* we skip setting op_targ = 0 for now, since the intact 15989 * OP_PADXV is needed by S_check_hash_fields_and_hekify */ 15990 reset_start_targ = TRUE; 15991 } 15992 arg++; 15993 break; 15994 15995 case MDEREF_HV_pop_rv2hv_helem: 15996 next_is_hash = TRUE; 15997 /* FALLTHROUGH */ 15998 case MDEREF_AV_pop_rv2av_aelem: 15999 break; 16000 16001 default: 16002 NOT_REACHED; /* NOTREACHED */ 16003 return; 16004 } 16005 16006 while (!is_last) { 16007 /* look for another (rv2av/hv; get index; 16008 * aelem/helem/exists/delele) sequence */ 16009 16010 OP *kid; 16011 bool is_deref; 16012 bool ok; 16013 UV index_type = MDEREF_INDEX_none; 16014 16015 if (action_count) { 16016 /* if this is not the first lookup, consume the rv2av/hv */ 16017 16018 /* for N levels of aggregate lookup, we normally expect 16019 * that the first N-1 [ah]elem ops will be flagged as 16020 * /DEREF (so they autovivifiy if necessary), and the last 16021 * lookup op not to be. 16022 * For other things (like @{$h{k1}{k2}}) extra scope or 16023 * leave ops can appear, so abandon the effort in that 16024 * case */ 16025 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV) 16026 return; 16027 16028 /* rv2av or rv2hv sKR/1 */ 16029 16030 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS 16031 |OPf_REF|OPf_MOD|OPf_SPECIAL))); 16032 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF)) 16033 return; 16034 16035 /* at this point, we wouldn't expect any of these 16036 * possible private flags: 16037 * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO 16038 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only) 16039 */ 16040 ASSUME(!(o->op_private & 16041 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING))); 16042 16043 hints = (o->op_private & OPpHINT_STRICT_REFS); 16044 16045 /* make sure the type of the previous /DEREF matches the 16046 * type of the next lookup */ 16047 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV)); 16048 top_op = o; 16049 16050 action = next_is_hash 16051 ? MDEREF_HV_vivify_rv2hv_helem 16052 : MDEREF_AV_vivify_rv2av_aelem; 16053 o = o->op_next; 16054 } 16055 16056 /* if this is the second pass, and we're at the depth where 16057 * previously we encountered a non-simple index expression, 16058 * stop processing the index at this point */ 16059 if (action_count != index_skip) { 16060 16061 /* look for one or more simple ops that return an array 16062 * index or hash key */ 16063 16064 switch (o->op_type) { 16065 case OP_PADSV: 16066 /* it may be a lexical var index */ 16067 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS 16068 |OPf_REF|OPf_MOD|OPf_SPECIAL))); 16069 ASSUME(!(o->op_private & 16070 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO))); 16071 16072 if ( OP_GIMME(o,0) == G_SCALAR 16073 && !(o->op_flags & (OPf_REF|OPf_MOD)) 16074 && o->op_private == 0) 16075 { 16076 if (pass) 16077 arg->pad_offset = o->op_targ; 16078 arg++; 16079 index_type = MDEREF_INDEX_padsv; 16080 o = o->op_next; 16081 } 16082 break; 16083 16084 case OP_CONST: 16085 if (next_is_hash) { 16086 /* it's a constant hash index */ 16087 if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK))) 16088 /* "use constant foo => FOO; $h{+foo}" for 16089 * some weird FOO, can leave you with constants 16090 * that aren't simple strings. It's not worth 16091 * the extra hassle for those edge cases */ 16092 break; 16093 16094 { 16095 UNOP *rop = NULL; 16096 OP * helem_op = o->op_next; 16097 16098 ASSUME( helem_op->op_type == OP_HELEM 16099 || helem_op->op_type == OP_NULL 16100 || pass == 0); 16101 if (helem_op->op_type == OP_HELEM) { 16102 rop = (UNOP*)(((BINOP*)helem_op)->op_first); 16103 if ( helem_op->op_private & OPpLVAL_INTRO 16104 || rop->op_type != OP_RV2HV 16105 ) 16106 rop = NULL; 16107 } 16108 /* on first pass just check; on second pass 16109 * hekify */ 16110 S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo, 16111 pass); 16112 } 16113 16114 if (pass) { 16115 #ifdef USE_ITHREADS 16116 /* Relocate sv to the pad for thread safety */ 16117 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ); 16118 arg->pad_offset = o->op_targ; 16119 o->op_targ = 0; 16120 #else 16121 arg->sv = cSVOPx_sv(o); 16122 #endif 16123 } 16124 } 16125 else { 16126 /* it's a constant array index */ 16127 IV iv; 16128 SV *ix_sv = cSVOPo->op_sv; 16129 if (!SvIOK(ix_sv)) 16130 break; 16131 iv = SvIV(ix_sv); 16132 16133 if ( action_count == 0 16134 && iv >= -128 16135 && iv <= 127 16136 && ( action == MDEREF_AV_padav_aelem 16137 || action == MDEREF_AV_gvav_aelem) 16138 ) 16139 maybe_aelemfast = TRUE; 16140 16141 if (pass) { 16142 arg->iv = iv; 16143 SvREFCNT_dec_NN(cSVOPo->op_sv); 16144 } 16145 } 16146 if (pass) 16147 /* we've taken ownership of the SV */ 16148 cSVOPo->op_sv = NULL; 16149 arg++; 16150 index_type = MDEREF_INDEX_const; 16151 o = o->op_next; 16152 break; 16153 16154 case OP_GV: 16155 /* it may be a package var index */ 16156 16157 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS|OPf_SPECIAL))); 16158 ASSUME(!(o->op_private & ~(OPpEARLY_CV))); 16159 if ( (o->op_flags & ~(OPf_PARENS|OPf_SPECIAL)) != OPf_WANT_SCALAR 16160 || o->op_private != 0 16161 ) 16162 break; 16163 16164 kid = o->op_next; 16165 if (kid->op_type != OP_RV2SV) 16166 break; 16167 16168 ASSUME(!(kid->op_flags & 16169 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF 16170 |OPf_SPECIAL|OPf_PARENS))); 16171 ASSUME(!(kid->op_private & 16172 ~(OPpARG1_MASK 16173 |OPpHINT_STRICT_REFS|OPpOUR_INTRO 16174 |OPpDEREF|OPpLVAL_INTRO))); 16175 if( (kid->op_flags &~ OPf_PARENS) 16176 != (OPf_WANT_SCALAR|OPf_KIDS) 16177 || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS)) 16178 ) 16179 break; 16180 16181 if (pass) { 16182 #ifdef USE_ITHREADS 16183 arg->pad_offset = cPADOPx(o)->op_padix; 16184 /* stop it being swiped when nulled */ 16185 cPADOPx(o)->op_padix = 0; 16186 #else 16187 arg->sv = cSVOPx(o)->op_sv; 16188 cSVOPo->op_sv = NULL; 16189 #endif 16190 } 16191 arg++; 16192 index_type = MDEREF_INDEX_gvsv; 16193 o = kid->op_next; 16194 break; 16195 16196 } /* switch */ 16197 } /* action_count != index_skip */ 16198 16199 action |= index_type; 16200 16201 16202 /* at this point we have either: 16203 * * detected what looks like a simple index expression, 16204 * and expect the next op to be an [ah]elem, or 16205 * an nulled [ah]elem followed by a delete or exists; 16206 * * found a more complex expression, so something other 16207 * than the above follows. 16208 */ 16209 16210 /* possibly an optimised away [ah]elem (where op_next is 16211 * exists or delete) */ 16212 if (o->op_type == OP_NULL) 16213 o = o->op_next; 16214 16215 /* at this point we're looking for an OP_AELEM, OP_HELEM, 16216 * OP_EXISTS or OP_DELETE */ 16217 16218 /* if a custom array/hash access checker is in scope, 16219 * abandon optimisation attempt */ 16220 if ( (o->op_type == OP_AELEM || o->op_type == OP_HELEM) 16221 && PL_check[o->op_type] != Perl_ck_null) 16222 return; 16223 /* similarly for customised exists and delete */ 16224 if ( (o->op_type == OP_EXISTS) 16225 && PL_check[o->op_type] != Perl_ck_exists) 16226 return; 16227 if ( (o->op_type == OP_DELETE) 16228 && PL_check[o->op_type] != Perl_ck_delete) 16229 return; 16230 16231 if ( o->op_type != OP_AELEM 16232 || (o->op_private & 16233 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) 16234 ) 16235 maybe_aelemfast = FALSE; 16236 16237 /* look for aelem/helem/exists/delete. If it's not the last elem 16238 * lookup, it *must* have OPpDEREF_AV/HV, but not many other 16239 * flags; if it's the last, then it mustn't have 16240 * OPpDEREF_AV/HV, but may have lots of other flags, like 16241 * OPpLVAL_INTRO etc 16242 */ 16243 16244 if ( index_type == MDEREF_INDEX_none 16245 || ( o->op_type != OP_AELEM && o->op_type != OP_HELEM 16246 && o->op_type != OP_EXISTS && o->op_type != OP_DELETE) 16247 ) 16248 ok = FALSE; 16249 else { 16250 /* we have aelem/helem/exists/delete with valid simple index */ 16251 16252 is_deref = (o->op_type == OP_AELEM || o->op_type == OP_HELEM) 16253 && ( (o->op_private & OPpDEREF) == OPpDEREF_AV 16254 || (o->op_private & OPpDEREF) == OPpDEREF_HV); 16255 16256 /* This doesn't make much sense but is legal: 16257 * @{ local $x[0][0] } = 1 16258 * Since scope exit will undo the autovivification, 16259 * don't bother in the first place. The OP_LEAVE 16260 * assertion is in case there are other cases of both 16261 * OPpLVAL_INTRO and OPpDEREF which don't include a scope 16262 * exit that would undo the local - in which case this 16263 * block of code would need rethinking. 16264 */ 16265 if (is_deref && (o->op_private & OPpLVAL_INTRO)) { 16266 #ifdef DEBUGGING 16267 OP *n = o->op_next; 16268 while (n && ( n->op_type == OP_NULL 16269 || n->op_type == OP_LIST 16270 || n->op_type == OP_SCALAR)) 16271 n = n->op_next; 16272 assert(n && n->op_type == OP_LEAVE); 16273 #endif 16274 o->op_private &= ~OPpDEREF; 16275 is_deref = FALSE; 16276 } 16277 16278 if (is_deref) { 16279 ASSUME(!(o->op_flags & 16280 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS))); 16281 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF))); 16282 16283 ok = (o->op_flags &~ OPf_PARENS) 16284 == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD) 16285 && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK)); 16286 } 16287 else if (o->op_type == OP_EXISTS) { 16288 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS 16289 |OPf_REF|OPf_MOD|OPf_SPECIAL))); 16290 ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB))); 16291 ok = !(o->op_private & ~OPpARG1_MASK); 16292 } 16293 else if (o->op_type == OP_DELETE) { 16294 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS 16295 |OPf_REF|OPf_MOD|OPf_SPECIAL))); 16296 ASSUME(!(o->op_private & 16297 ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO))); 16298 /* don't handle slices or 'local delete'; the latter 16299 * is fairly rare, and has a complex runtime */ 16300 ok = !(o->op_private & ~OPpARG1_MASK); 16301 if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM)) 16302 /* skip handling run-tome error */ 16303 ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL)); 16304 } 16305 else { 16306 ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM); 16307 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD 16308 |OPf_PARENS|OPf_REF|OPf_SPECIAL))); 16309 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB 16310 |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO))); 16311 ok = (o->op_private & OPpDEREF) != OPpDEREF_SV; 16312 } 16313 } 16314 16315 if (ok) { 16316 if (!first_elem_op) 16317 first_elem_op = o; 16318 top_op = o; 16319 if (is_deref) { 16320 next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV); 16321 o = o->op_next; 16322 } 16323 else { 16324 is_last = TRUE; 16325 action |= MDEREF_FLAG_last; 16326 } 16327 } 16328 else { 16329 /* at this point we have something that started 16330 * promisingly enough (with rv2av or whatever), but failed 16331 * to find a simple index followed by an 16332 * aelem/helem/exists/delete. If this is the first action, 16333 * give up; but if we've already seen at least one 16334 * aelem/helem, then keep them and add a new action with 16335 * MDEREF_INDEX_none, which causes it to do the vivify 16336 * from the end of the previous lookup, and do the deref, 16337 * but stop at that point. So $a[0][expr] will do one 16338 * av_fetch, vivify and deref, then continue executing at 16339 * expr */ 16340 if (!action_count) 16341 return; 16342 is_last = TRUE; 16343 index_skip = action_count; 16344 action |= MDEREF_FLAG_last; 16345 if (index_type != MDEREF_INDEX_none) 16346 arg--; 16347 } 16348 16349 action_word |= (action << (action_ix * MDEREF_SHIFT)); 16350 action_ix++; 16351 action_count++; 16352 /* if there's no space for the next action, reserve a new slot 16353 * for it *before* we start adding args for that action */ 16354 if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) { 16355 if (pass) 16356 action_ptr->uv = action_word; 16357 action_word = 0; 16358 action_ptr = arg; 16359 arg++; 16360 action_ix = 0; 16361 } 16362 } /* while !is_last */ 16363 16364 /* success! */ 16365 16366 if (!action_ix) 16367 /* slot reserved for next action word not now needed */ 16368 arg--; 16369 else if (pass) 16370 action_ptr->uv = action_word; 16371 16372 if (pass) { 16373 OP *mderef; 16374 OP *p, *q; 16375 16376 mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf); 16377 if (index_skip == -1) { 16378 mderef->op_flags = o->op_flags 16379 & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0)); 16380 if (o->op_type == OP_EXISTS) 16381 mderef->op_private = OPpMULTIDEREF_EXISTS; 16382 else if (o->op_type == OP_DELETE) 16383 mderef->op_private = OPpMULTIDEREF_DELETE; 16384 else 16385 mderef->op_private = o->op_private 16386 & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO); 16387 } 16388 /* accumulate strictness from every level (although I don't think 16389 * they can actually vary) */ 16390 mderef->op_private |= hints; 16391 16392 /* integrate the new multideref op into the optree and the 16393 * op_next chain. 16394 * 16395 * In general an op like aelem or helem has two child 16396 * sub-trees: the aggregate expression (a_expr) and the 16397 * index expression (i_expr): 16398 * 16399 * aelem 16400 * | 16401 * a_expr - i_expr 16402 * 16403 * The a_expr returns an AV or HV, while the i-expr returns an 16404 * index. In general a multideref replaces most or all of a 16405 * multi-level tree, e.g. 16406 * 16407 * exists 16408 * | 16409 * ex-aelem 16410 * | 16411 * rv2av - i_expr1 16412 * | 16413 * helem 16414 * | 16415 * rv2hv - i_expr2 16416 * | 16417 * aelem 16418 * | 16419 * a_expr - i_expr3 16420 * 16421 * With multideref, all the i_exprs will be simple vars or 16422 * constants, except that i_expr1 may be arbitrary in the case 16423 * of MDEREF_INDEX_none. 16424 * 16425 * The bottom-most a_expr will be either: 16426 * 1) a simple var (so padXv or gv+rv2Xv); 16427 * 2) a simple scalar var dereferenced (e.g. $r->[0]): 16428 * so a simple var with an extra rv2Xv; 16429 * 3) or an arbitrary expression. 16430 * 16431 * 'start', the first op in the execution chain, will point to 16432 * 1),2): the padXv or gv op; 16433 * 3): the rv2Xv which forms the last op in the a_expr 16434 * execution chain, and the top-most op in the a_expr 16435 * subtree. 16436 * 16437 * For all cases, the 'start' node is no longer required, 16438 * but we can't free it since one or more external nodes 16439 * may point to it. E.g. consider 16440 * $h{foo} = $a ? $b : $c 16441 * Here, both the op_next and op_other branches of the 16442 * cond_expr point to the gv[*h] of the hash expression, so 16443 * we can't free the 'start' op. 16444 * 16445 * For expr->[...], we need to save the subtree containing the 16446 * expression; for the other cases, we just need to save the 16447 * start node. 16448 * So in all cases, we null the start op and keep it around by 16449 * making it the child of the multideref op; for the expr-> 16450 * case, the expr will be a subtree of the start node. 16451 * 16452 * So in the simple 1,2 case the optree above changes to 16453 * 16454 * ex-exists 16455 * | 16456 * multideref 16457 * | 16458 * ex-gv (or ex-padxv) 16459 * 16460 * with the op_next chain being 16461 * 16462 * -> ex-gv -> multideref -> op-following-ex-exists -> 16463 * 16464 * In the 3 case, we have 16465 * 16466 * ex-exists 16467 * | 16468 * multideref 16469 * | 16470 * ex-rv2xv 16471 * | 16472 * rest-of-a_expr 16473 * subtree 16474 * 16475 * and 16476 * 16477 * -> rest-of-a_expr subtree -> 16478 * ex-rv2xv -> multideref -> op-following-ex-exists -> 16479 * 16480 * 16481 * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none, 16482 * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the 16483 * multideref attached as the child, e.g. 16484 * 16485 * exists 16486 * | 16487 * ex-aelem 16488 * | 16489 * ex-rv2av - i_expr1 16490 * | 16491 * multideref 16492 * | 16493 * ex-whatever 16494 * 16495 */ 16496 16497 /* if we free this op, don't free the pad entry */ 16498 if (reset_start_targ) 16499 start->op_targ = 0; 16500 16501 16502 /* Cut the bit we need to save out of the tree and attach to 16503 * the multideref op, then free the rest of the tree */ 16504 16505 /* find parent of node to be detached (for use by splice) */ 16506 p = first_elem_op; 16507 if ( orig_action == MDEREF_AV_pop_rv2av_aelem 16508 || orig_action == MDEREF_HV_pop_rv2hv_helem) 16509 { 16510 /* there is an arbitrary expression preceding us, e.g. 16511 * expr->[..]? so we need to save the 'expr' subtree */ 16512 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE) 16513 p = cUNOPx(p)->op_first; 16514 ASSUME( start->op_type == OP_RV2AV 16515 || start->op_type == OP_RV2HV); 16516 } 16517 else { 16518 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem 16519 * above for exists/delete. */ 16520 while ( (p->op_flags & OPf_KIDS) 16521 && cUNOPx(p)->op_first != start 16522 ) 16523 p = cUNOPx(p)->op_first; 16524 } 16525 ASSUME(cUNOPx(p)->op_first == start); 16526 16527 /* detach from main tree, and re-attach under the multideref */ 16528 op_sibling_splice(mderef, NULL, 0, 16529 op_sibling_splice(p, NULL, 1, NULL)); 16530 op_null(start); 16531 16532 start->op_next = mderef; 16533 16534 mderef->op_next = index_skip == -1 ? o->op_next : o; 16535 16536 /* excise and free the original tree, and replace with 16537 * the multideref op */ 16538 p = op_sibling_splice(top_op, NULL, -1, mderef); 16539 while (p) { 16540 q = OpSIBLING(p); 16541 op_free(p); 16542 p = q; 16543 } 16544 op_null(top_op); 16545 } 16546 else { 16547 Size_t size = arg - arg_buf; 16548 16549 if (maybe_aelemfast && action_count == 1) 16550 return; 16551 16552 arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc( 16553 sizeof(UNOP_AUX_item) * (size + 1)); 16554 /* for dumping etc: store the length in a hidden first slot; 16555 * we set the op_aux pointer to the second slot */ 16556 arg_buf->uv = size; 16557 arg_buf++; 16558 } 16559 } /* for (pass = ...) */ 16560 } 16561 16562 /* See if the ops following o are such that o will always be executed in 16563 * boolean context: that is, the SV which o pushes onto the stack will 16564 * only ever be consumed by later ops via SvTRUE(sv) or similar. 16565 * If so, set a suitable private flag on o. Normally this will be 16566 * bool_flag; but see below why maybe_flag is needed too. 16567 * 16568 * Typically the two flags you pass will be the generic OPpTRUEBOOL and 16569 * OPpMAYBE_TRUEBOOL, buts it's possible that for some ops those bits may 16570 * already be taken, so you'll have to give that op two different flags. 16571 * 16572 * More explanation of 'maybe_flag' and 'safe_and' parameters. 16573 * The binary logical ops &&, ||, // (plus 'if' and 'unless' which use 16574 * those underlying ops) short-circuit, which means that rather than 16575 * necessarily returning a truth value, they may return the LH argument, 16576 * which may not be boolean. For example in $x = (keys %h || -1), keys 16577 * should return a key count rather than a boolean, even though its 16578 * sort-of being used in boolean context. 16579 * 16580 * So we only consider such logical ops to provide boolean context to 16581 * their LH argument if they themselves are in void or boolean context. 16582 * However, sometimes the context isn't known until run-time. In this 16583 * case the op is marked with the maybe_flag flag it. 16584 * 16585 * Consider the following. 16586 * 16587 * sub f { ....; if (%h) { .... } } 16588 * 16589 * This is actually compiled as 16590 * 16591 * sub f { ....; %h && do { .... } } 16592 * 16593 * Here we won't know until runtime whether the final statement (and hence 16594 * the &&) is in void context and so is safe to return a boolean value. 16595 * So mark o with maybe_flag rather than the bool_flag. 16596 * Note that there is cost associated with determining context at runtime 16597 * (e.g. a call to block_gimme()), so it may not be worth setting (at 16598 * compile time) and testing (at runtime) maybe_flag if the scalar verses 16599 * boolean costs savings are marginal. 16600 * 16601 * However, we can do slightly better with && (compared to || and //): 16602 * this op only returns its LH argument when that argument is false. In 16603 * this case, as long as the op promises to return a false value which is 16604 * valid in both boolean and scalar contexts, we can mark an op consumed 16605 * by && with bool_flag rather than maybe_flag. 16606 * For example as long as pp_padhv and pp_rv2hv return &PL_sv_zero rather 16607 * than &PL_sv_no for a false result in boolean context, then it's safe. An 16608 * op which promises to handle this case is indicated by setting safe_and 16609 * to true. 16610 */ 16611 16612 static void 16613 S_check_for_bool_cxt(OP*o, bool safe_and, U8 bool_flag, U8 maybe_flag) 16614 { 16615 OP *lop; 16616 U8 flag = 0; 16617 16618 assert((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR); 16619 16620 /* OPpTARGET_MY and boolean context probably don't mix well. 16621 * If someone finds a valid use case, maybe add an extra flag to this 16622 * function which indicates its safe to do so for this op? */ 16623 assert(!( (PL_opargs[o->op_type] & OA_TARGLEX) 16624 && (o->op_private & OPpTARGET_MY))); 16625 16626 lop = o->op_next; 16627 16628 while (lop) { 16629 switch (lop->op_type) { 16630 case OP_NULL: 16631 case OP_SCALAR: 16632 break; 16633 16634 /* these two consume the stack argument in the scalar case, 16635 * and treat it as a boolean in the non linenumber case */ 16636 case OP_FLIP: 16637 case OP_FLOP: 16638 if ( ((lop->op_flags & OPf_WANT) == OPf_WANT_LIST) 16639 || (lop->op_private & OPpFLIP_LINENUM)) 16640 { 16641 lop = NULL; 16642 break; 16643 } 16644 /* FALLTHROUGH */ 16645 /* these never leave the original value on the stack */ 16646 case OP_NOT: 16647 case OP_XOR: 16648 case OP_COND_EXPR: 16649 case OP_GREPWHILE: 16650 flag = bool_flag; 16651 lop = NULL; 16652 break; 16653 16654 /* OR DOR and AND evaluate their arg as a boolean, but then may 16655 * leave the original scalar value on the stack when following the 16656 * op_next route. If not in void context, we need to ensure 16657 * that whatever follows consumes the arg only in boolean context 16658 * too. 16659 */ 16660 case OP_AND: 16661 if (safe_and) { 16662 flag = bool_flag; 16663 lop = NULL; 16664 break; 16665 } 16666 /* FALLTHROUGH */ 16667 case OP_OR: 16668 case OP_DOR: 16669 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) { 16670 flag = bool_flag; 16671 lop = NULL; 16672 } 16673 else if (!(lop->op_flags & OPf_WANT)) { 16674 /* unknown context - decide at runtime */ 16675 flag = maybe_flag; 16676 lop = NULL; 16677 } 16678 break; 16679 16680 default: 16681 lop = NULL; 16682 break; 16683 } 16684 16685 if (lop) 16686 lop = lop->op_next; 16687 } 16688 16689 o->op_private |= flag; 16690 } 16691 16692 16693 16694 /* mechanism for deferring recursion in rpeep() */ 16695 16696 #define MAX_DEFERRED 4 16697 16698 #define DEFER(o) \ 16699 STMT_START { \ 16700 if (defer_ix == (MAX_DEFERRED-1)) { \ 16701 OP **defer = defer_queue[defer_base]; \ 16702 CALL_RPEEP(*defer); \ 16703 S_prune_chain_head(defer); \ 16704 defer_base = (defer_base + 1) % MAX_DEFERRED; \ 16705 defer_ix--; \ 16706 } \ 16707 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \ 16708 } STMT_END 16709 16710 #define IS_AND_OP(o) (o->op_type == OP_AND) 16711 #define IS_OR_OP(o) (o->op_type == OP_OR) 16712 16713 16714 /* A peephole optimizer. We visit the ops in the order they're to execute. 16715 * See the comments at the top of this file for more details about when 16716 * peep() is called */ 16717 16718 void 16719 Perl_rpeep(pTHX_ OP *o) 16720 { 16721 dVAR; 16722 OP* oldop = NULL; 16723 OP* oldoldop = NULL; 16724 OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */ 16725 int defer_base = 0; 16726 int defer_ix = -1; 16727 16728 if (!o || o->op_opt) 16729 return; 16730 16731 assert(o->op_type != OP_FREED); 16732 16733 ENTER; 16734 SAVEOP(); 16735 SAVEVPTR(PL_curcop); 16736 for (;; o = o->op_next) { 16737 if (o && o->op_opt) 16738 o = NULL; 16739 if (!o) { 16740 while (defer_ix >= 0) { 16741 OP **defer = 16742 defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED]; 16743 CALL_RPEEP(*defer); 16744 S_prune_chain_head(defer); 16745 } 16746 break; 16747 } 16748 16749 redo: 16750 16751 /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */ 16752 assert(!oldoldop || oldoldop->op_next == oldop); 16753 assert(!oldop || oldop->op_next == o); 16754 16755 /* By default, this op has now been optimised. A couple of cases below 16756 clear this again. */ 16757 o->op_opt = 1; 16758 PL_op = o; 16759 16760 /* look for a series of 1 or more aggregate derefs, e.g. 16761 * $a[1]{foo}[$i]{$k} 16762 * and replace with a single OP_MULTIDEREF op. 16763 * Each index must be either a const, or a simple variable, 16764 * 16765 * First, look for likely combinations of starting ops, 16766 * corresponding to (global and lexical variants of) 16767 * $a[...] $h{...} 16768 * $r->[...] $r->{...} 16769 * (preceding expression)->[...] 16770 * (preceding expression)->{...} 16771 * and if so, call maybe_multideref() to do a full inspection 16772 * of the op chain and if appropriate, replace with an 16773 * OP_MULTIDEREF 16774 */ 16775 { 16776 UV action; 16777 OP *o2 = o; 16778 U8 hints = 0; 16779 16780 switch (o2->op_type) { 16781 case OP_GV: 16782 /* $pkg[..] : gv[*pkg] 16783 * $pkg->[...]: gv[*pkg]; rv2sv sKM/DREFAV */ 16784 16785 /* Fail if there are new op flag combinations that we're 16786 * not aware of, rather than: 16787 * * silently failing to optimise, or 16788 * * silently optimising the flag away. 16789 * If this ASSUME starts failing, examine what new flag 16790 * has been added to the op, and decide whether the 16791 * optimisation should still occur with that flag, then 16792 * update the code accordingly. This applies to all the 16793 * other ASSUMEs in the block of code too. 16794 */ 16795 ASSUME(!(o2->op_flags & 16796 ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL))); 16797 ASSUME(!(o2->op_private & ~OPpEARLY_CV)); 16798 16799 o2 = o2->op_next; 16800 16801 if (o2->op_type == OP_RV2AV) { 16802 action = MDEREF_AV_gvav_aelem; 16803 goto do_deref; 16804 } 16805 16806 if (o2->op_type == OP_RV2HV) { 16807 action = MDEREF_HV_gvhv_helem; 16808 goto do_deref; 16809 } 16810 16811 if (o2->op_type != OP_RV2SV) 16812 break; 16813 16814 /* at this point we've seen gv,rv2sv, so the only valid 16815 * construct left is $pkg->[] or $pkg->{} */ 16816 16817 ASSUME(!(o2->op_flags & OPf_STACKED)); 16818 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL)) 16819 != (OPf_WANT_SCALAR|OPf_MOD)) 16820 break; 16821 16822 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS 16823 |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO))); 16824 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO)) 16825 break; 16826 if ( (o2->op_private & OPpDEREF) != OPpDEREF_AV 16827 && (o2->op_private & OPpDEREF) != OPpDEREF_HV) 16828 break; 16829 16830 o2 = o2->op_next; 16831 if (o2->op_type == OP_RV2AV) { 16832 action = MDEREF_AV_gvsv_vivify_rv2av_aelem; 16833 goto do_deref; 16834 } 16835 if (o2->op_type == OP_RV2HV) { 16836 action = MDEREF_HV_gvsv_vivify_rv2hv_helem; 16837 goto do_deref; 16838 } 16839 break; 16840 16841 case OP_PADSV: 16842 /* $lex->[...]: padsv[$lex] sM/DREFAV */ 16843 16844 ASSUME(!(o2->op_flags & 16845 ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL))); 16846 if ((o2->op_flags & 16847 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL)) 16848 != (OPf_WANT_SCALAR|OPf_MOD)) 16849 break; 16850 16851 ASSUME(!(o2->op_private & 16852 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO))); 16853 /* skip if state or intro, or not a deref */ 16854 if ( o2->op_private != OPpDEREF_AV 16855 && o2->op_private != OPpDEREF_HV) 16856 break; 16857 16858 o2 = o2->op_next; 16859 if (o2->op_type == OP_RV2AV) { 16860 action = MDEREF_AV_padsv_vivify_rv2av_aelem; 16861 goto do_deref; 16862 } 16863 if (o2->op_type == OP_RV2HV) { 16864 action = MDEREF_HV_padsv_vivify_rv2hv_helem; 16865 goto do_deref; 16866 } 16867 break; 16868 16869 case OP_PADAV: 16870 case OP_PADHV: 16871 /* $lex[..]: padav[@lex:1,2] sR * 16872 * or $lex{..}: padhv[%lex:1,2] sR */ 16873 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS| 16874 OPf_REF|OPf_SPECIAL))); 16875 if ((o2->op_flags & 16876 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL)) 16877 != (OPf_WANT_SCALAR|OPf_REF)) 16878 break; 16879 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF)) 16880 break; 16881 /* OPf_PARENS isn't currently used in this case; 16882 * if that changes, let us know! */ 16883 ASSUME(!(o2->op_flags & OPf_PARENS)); 16884 16885 /* at this point, we wouldn't expect any of the remaining 16886 * possible private flags: 16887 * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL, 16888 * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB 16889 * 16890 * OPpSLICEWARNING shouldn't affect runtime 16891 */ 16892 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING))); 16893 16894 action = o2->op_type == OP_PADAV 16895 ? MDEREF_AV_padav_aelem 16896 : MDEREF_HV_padhv_helem; 16897 o2 = o2->op_next; 16898 S_maybe_multideref(aTHX_ o, o2, action, 0); 16899 break; 16900 16901 16902 case OP_RV2AV: 16903 case OP_RV2HV: 16904 action = o2->op_type == OP_RV2AV 16905 ? MDEREF_AV_pop_rv2av_aelem 16906 : MDEREF_HV_pop_rv2hv_helem; 16907 /* FALLTHROUGH */ 16908 do_deref: 16909 /* (expr)->[...]: rv2av sKR/1; 16910 * (expr)->{...}: rv2hv sKR/1; */ 16911 16912 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV); 16913 16914 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS 16915 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL))); 16916 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF)) 16917 break; 16918 16919 /* at this point, we wouldn't expect any of these 16920 * possible private flags: 16921 * OPpMAYBE_LVSUB, OPpLVAL_INTRO 16922 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only) 16923 */ 16924 ASSUME(!(o2->op_private & 16925 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING 16926 |OPpOUR_INTRO))); 16927 hints |= (o2->op_private & OPpHINT_STRICT_REFS); 16928 16929 o2 = o2->op_next; 16930 16931 S_maybe_multideref(aTHX_ o, o2, action, hints); 16932 break; 16933 16934 default: 16935 break; 16936 } 16937 } 16938 16939 16940 switch (o->op_type) { 16941 case OP_DBSTATE: 16942 PL_curcop = ((COP*)o); /* for warnings */ 16943 break; 16944 case OP_NEXTSTATE: 16945 PL_curcop = ((COP*)o); /* for warnings */ 16946 16947 /* Optimise a "return ..." at the end of a sub to just be "...". 16948 * This saves 2 ops. Before: 16949 * 1 <;> nextstate(main 1 -e:1) v ->2 16950 * 4 <@> return K ->5 16951 * 2 <0> pushmark s ->3 16952 * - <1> ex-rv2sv sK/1 ->4 16953 * 3 <#> gvsv[*cat] s ->4 16954 * 16955 * After: 16956 * - <@> return K ->- 16957 * - <0> pushmark s ->2 16958 * - <1> ex-rv2sv sK/1 ->- 16959 * 2 <$> gvsv(*cat) s ->3 16960 */ 16961 { 16962 OP *next = o->op_next; 16963 OP *sibling = OpSIBLING(o); 16964 if ( OP_TYPE_IS(next, OP_PUSHMARK) 16965 && OP_TYPE_IS(sibling, OP_RETURN) 16966 && OP_TYPE_IS(sibling->op_next, OP_LINESEQ) 16967 && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB) 16968 ||OP_TYPE_IS(sibling->op_next->op_next, 16969 OP_LEAVESUBLV)) 16970 && cUNOPx(sibling)->op_first == next 16971 && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next 16972 && next->op_next 16973 ) { 16974 /* Look through the PUSHMARK's siblings for one that 16975 * points to the RETURN */ 16976 OP *top = OpSIBLING(next); 16977 while (top && top->op_next) { 16978 if (top->op_next == sibling) { 16979 top->op_next = sibling->op_next; 16980 o->op_next = next->op_next; 16981 break; 16982 } 16983 top = OpSIBLING(top); 16984 } 16985 } 16986 } 16987 16988 /* Optimise 'my $x; my $y;' into 'my ($x, $y);' 16989 * 16990 * This latter form is then suitable for conversion into padrange 16991 * later on. Convert: 16992 * 16993 * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3 16994 * 16995 * into: 16996 * 16997 * nextstate1 -> listop -> nextstate3 16998 * / \ 16999 * pushmark -> padop1 -> padop2 17000 */ 17001 if (o->op_next && ( 17002 o->op_next->op_type == OP_PADSV 17003 || o->op_next->op_type == OP_PADAV 17004 || o->op_next->op_type == OP_PADHV 17005 ) 17006 && !(o->op_next->op_private & ~OPpLVAL_INTRO) 17007 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE 17008 && o->op_next->op_next->op_next && ( 17009 o->op_next->op_next->op_next->op_type == OP_PADSV 17010 || o->op_next->op_next->op_next->op_type == OP_PADAV 17011 || o->op_next->op_next->op_next->op_type == OP_PADHV 17012 ) 17013 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO) 17014 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE 17015 && (!CopLABEL((COP*)o)) /* Don't mess with labels */ 17016 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */ 17017 ) { 17018 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm; 17019 17020 pad1 = o->op_next; 17021 ns2 = pad1->op_next; 17022 pad2 = ns2->op_next; 17023 ns3 = pad2->op_next; 17024 17025 /* we assume here that the op_next chain is the same as 17026 * the op_sibling chain */ 17027 assert(OpSIBLING(o) == pad1); 17028 assert(OpSIBLING(pad1) == ns2); 17029 assert(OpSIBLING(ns2) == pad2); 17030 assert(OpSIBLING(pad2) == ns3); 17031 17032 /* excise and delete ns2 */ 17033 op_sibling_splice(NULL, pad1, 1, NULL); 17034 op_free(ns2); 17035 17036 /* excise pad1 and pad2 */ 17037 op_sibling_splice(NULL, o, 2, NULL); 17038 17039 /* create new listop, with children consisting of: 17040 * a new pushmark, pad1, pad2. */ 17041 newop = newLISTOP(OP_LIST, 0, pad1, pad2); 17042 newop->op_flags |= OPf_PARENS; 17043 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID; 17044 17045 /* insert newop between o and ns3 */ 17046 op_sibling_splice(NULL, o, 0, newop); 17047 17048 /*fixup op_next chain */ 17049 newpm = cUNOPx(newop)->op_first; /* pushmark */ 17050 o ->op_next = newpm; 17051 newpm->op_next = pad1; 17052 pad1 ->op_next = pad2; 17053 pad2 ->op_next = newop; /* listop */ 17054 newop->op_next = ns3; 17055 17056 /* Ensure pushmark has this flag if padops do */ 17057 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) { 17058 newpm->op_flags |= OPf_MOD; 17059 } 17060 17061 break; 17062 } 17063 17064 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen 17065 to carry two labels. For now, take the easier option, and skip 17066 this optimisation if the first NEXTSTATE has a label. */ 17067 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) { 17068 OP *nextop = o->op_next; 17069 while (nextop) { 17070 switch (nextop->op_type) { 17071 case OP_NULL: 17072 case OP_SCALAR: 17073 case OP_LINESEQ: 17074 case OP_SCOPE: 17075 nextop = nextop->op_next; 17076 continue; 17077 } 17078 break; 17079 } 17080 17081 if (nextop && (nextop->op_type == OP_NEXTSTATE)) { 17082 op_null(o); 17083 if (oldop) 17084 oldop->op_next = nextop; 17085 o = nextop; 17086 /* Skip (old)oldop assignment since the current oldop's 17087 op_next already points to the next op. */ 17088 goto redo; 17089 } 17090 } 17091 break; 17092 17093 case OP_CONCAT: 17094 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) { 17095 if (o->op_next->op_private & OPpTARGET_MY) { 17096 if (o->op_flags & OPf_STACKED) /* chained concats */ 17097 break; /* ignore_optimization */ 17098 else { 17099 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */ 17100 o->op_targ = o->op_next->op_targ; 17101 o->op_next->op_targ = 0; 17102 o->op_private |= OPpTARGET_MY; 17103 } 17104 } 17105 op_null(o->op_next); 17106 } 17107 break; 17108 case OP_STUB: 17109 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) { 17110 break; /* Scalar stub must produce undef. List stub is noop */ 17111 } 17112 goto nothin; 17113 case OP_NULL: 17114 if (o->op_targ == OP_NEXTSTATE 17115 || o->op_targ == OP_DBSTATE) 17116 { 17117 PL_curcop = ((COP*)o); 17118 } 17119 /* XXX: We avoid setting op_seq here to prevent later calls 17120 to rpeep() from mistakenly concluding that optimisation 17121 has already occurred. This doesn't fix the real problem, 17122 though (See 20010220.007 (#5874)). AMS 20010719 */ 17123 /* op_seq functionality is now replaced by op_opt */ 17124 o->op_opt = 0; 17125 /* FALLTHROUGH */ 17126 case OP_SCALAR: 17127 case OP_LINESEQ: 17128 case OP_SCOPE: 17129 nothin: 17130 if (oldop) { 17131 oldop->op_next = o->op_next; 17132 o->op_opt = 0; 17133 continue; 17134 } 17135 break; 17136 17137 case OP_PUSHMARK: 17138 17139 /* Given 17140 5 repeat/DOLIST 17141 3 ex-list 17142 1 pushmark 17143 2 scalar or const 17144 4 const[0] 17145 convert repeat into a stub with no kids. 17146 */ 17147 if (o->op_next->op_type == OP_CONST 17148 || ( o->op_next->op_type == OP_PADSV 17149 && !(o->op_next->op_private & OPpLVAL_INTRO)) 17150 || ( o->op_next->op_type == OP_GV 17151 && o->op_next->op_next->op_type == OP_RV2SV 17152 && !(o->op_next->op_next->op_private 17153 & (OPpLVAL_INTRO|OPpOUR_INTRO)))) 17154 { 17155 const OP *kid = o->op_next->op_next; 17156 if (o->op_next->op_type == OP_GV) 17157 kid = kid->op_next; 17158 /* kid is now the ex-list. */ 17159 if (kid->op_type == OP_NULL 17160 && (kid = kid->op_next)->op_type == OP_CONST 17161 /* kid is now the repeat count. */ 17162 && kid->op_next->op_type == OP_REPEAT 17163 && kid->op_next->op_private & OPpREPEAT_DOLIST 17164 && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST 17165 && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0 17166 && oldop) 17167 { 17168 o = kid->op_next; /* repeat */ 17169 oldop->op_next = o; 17170 op_free(cBINOPo->op_first); 17171 op_free(cBINOPo->op_last ); 17172 o->op_flags &=~ OPf_KIDS; 17173 /* stub is a baseop; repeat is a binop */ 17174 STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP)); 17175 OpTYPE_set(o, OP_STUB); 17176 o->op_private = 0; 17177 break; 17178 } 17179 } 17180 17181 /* Convert a series of PAD ops for my vars plus support into a 17182 * single padrange op. Basically 17183 * 17184 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest 17185 * 17186 * becomes, depending on circumstances, one of 17187 * 17188 * padrange ----------------------------------> (list) -> rest 17189 * padrange --------------------------------------------> rest 17190 * 17191 * where all the pad indexes are sequential and of the same type 17192 * (INTRO or not). 17193 * We convert the pushmark into a padrange op, then skip 17194 * any other pad ops, and possibly some trailing ops. 17195 * Note that we don't null() the skipped ops, to make it 17196 * easier for Deparse to undo this optimisation (and none of 17197 * the skipped ops are holding any resourses). It also makes 17198 * it easier for find_uninit_var(), as it can just ignore 17199 * padrange, and examine the original pad ops. 17200 */ 17201 { 17202 OP *p; 17203 OP *followop = NULL; /* the op that will follow the padrange op */ 17204 U8 count = 0; 17205 U8 intro = 0; 17206 PADOFFSET base = 0; /* init only to stop compiler whining */ 17207 bool gvoid = 0; /* init only to stop compiler whining */ 17208 bool defav = 0; /* seen (...) = @_ */ 17209 bool reuse = 0; /* reuse an existing padrange op */ 17210 17211 /* look for a pushmark -> gv[_] -> rv2av */ 17212 17213 { 17214 OP *rv2av, *q; 17215 p = o->op_next; 17216 if ( p->op_type == OP_GV 17217 && cGVOPx_gv(p) == PL_defgv 17218 && (rv2av = p->op_next) 17219 && rv2av->op_type == OP_RV2AV 17220 && !(rv2av->op_flags & OPf_REF) 17221 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB)) 17222 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST) 17223 ) { 17224 q = rv2av->op_next; 17225 if (q->op_type == OP_NULL) 17226 q = q->op_next; 17227 if (q->op_type == OP_PUSHMARK) { 17228 defav = 1; 17229 p = q; 17230 } 17231 } 17232 } 17233 if (!defav) { 17234 p = o; 17235 } 17236 17237 /* scan for PAD ops */ 17238 17239 for (p = p->op_next; p; p = p->op_next) { 17240 if (p->op_type == OP_NULL) 17241 continue; 17242 17243 if (( p->op_type != OP_PADSV 17244 && p->op_type != OP_PADAV 17245 && p->op_type != OP_PADHV 17246 ) 17247 /* any private flag other than INTRO? e.g. STATE */ 17248 || (p->op_private & ~OPpLVAL_INTRO) 17249 ) 17250 break; 17251 17252 /* let $a[N] potentially be optimised into AELEMFAST_LEX 17253 * instead */ 17254 if ( p->op_type == OP_PADAV 17255 && p->op_next 17256 && p->op_next->op_type == OP_CONST 17257 && p->op_next->op_next 17258 && p->op_next->op_next->op_type == OP_AELEM 17259 ) 17260 break; 17261 17262 /* for 1st padop, note what type it is and the range 17263 * start; for the others, check that it's the same type 17264 * and that the targs are contiguous */ 17265 if (count == 0) { 17266 intro = (p->op_private & OPpLVAL_INTRO); 17267 base = p->op_targ; 17268 gvoid = OP_GIMME(p,0) == G_VOID; 17269 } 17270 else { 17271 if ((p->op_private & OPpLVAL_INTRO) != intro) 17272 break; 17273 /* Note that you'd normally expect targs to be 17274 * contiguous in my($a,$b,$c), but that's not the case 17275 * when external modules start doing things, e.g. 17276 * Function::Parameters */ 17277 if (p->op_targ != base + count) 17278 break; 17279 assert(p->op_targ == base + count); 17280 /* Either all the padops or none of the padops should 17281 be in void context. Since we only do the optimisa- 17282 tion for av/hv when the aggregate itself is pushed 17283 on to the stack (one item), there is no need to dis- 17284 tinguish list from scalar context. */ 17285 if (gvoid != (OP_GIMME(p,0) == G_VOID)) 17286 break; 17287 } 17288 17289 /* for AV, HV, only when we're not flattening */ 17290 if ( p->op_type != OP_PADSV 17291 && !gvoid 17292 && !(p->op_flags & OPf_REF) 17293 ) 17294 break; 17295 17296 if (count >= OPpPADRANGE_COUNTMASK) 17297 break; 17298 17299 /* there's a biggest base we can fit into a 17300 * SAVEt_CLEARPADRANGE in pp_padrange. 17301 * (The sizeof() stuff will be constant-folded, and is 17302 * intended to avoid getting "comparison is always false" 17303 * compiler warnings. See the comments above 17304 * MEM_WRAP_CHECK for more explanation on why we do this 17305 * in a weird way to avoid compiler warnings.) 17306 */ 17307 if ( intro 17308 && (8*sizeof(base) > 17309 8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT 17310 ? (Size_t)base 17311 : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)) 17312 ) > 17313 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)) 17314 ) 17315 break; 17316 17317 /* Success! We've got another valid pad op to optimise away */ 17318 count++; 17319 followop = p->op_next; 17320 } 17321 17322 if (count < 1 || (count == 1 && !defav)) 17323 break; 17324 17325 /* pp_padrange in specifically compile-time void context 17326 * skips pushing a mark and lexicals; in all other contexts 17327 * (including unknown till runtime) it pushes a mark and the 17328 * lexicals. We must be very careful then, that the ops we 17329 * optimise away would have exactly the same effect as the 17330 * padrange. 17331 * In particular in void context, we can only optimise to 17332 * a padrange if we see the complete sequence 17333 * pushmark, pad*v, ...., list 17334 * which has the net effect of leaving the markstack as it 17335 * was. Not pushing onto the stack (whereas padsv does touch 17336 * the stack) makes no difference in void context. 17337 */ 17338 assert(followop); 17339 if (gvoid) { 17340 if (followop->op_type == OP_LIST 17341 && OP_GIMME(followop,0) == G_VOID 17342 ) 17343 { 17344 followop = followop->op_next; /* skip OP_LIST */ 17345 17346 /* consolidate two successive my(...);'s */ 17347 17348 if ( oldoldop 17349 && oldoldop->op_type == OP_PADRANGE 17350 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID 17351 && (oldoldop->op_private & OPpLVAL_INTRO) == intro 17352 && !(oldoldop->op_flags & OPf_SPECIAL) 17353 ) { 17354 U8 old_count; 17355 assert(oldoldop->op_next == oldop); 17356 assert( oldop->op_type == OP_NEXTSTATE 17357 || oldop->op_type == OP_DBSTATE); 17358 assert(oldop->op_next == o); 17359 17360 old_count 17361 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK); 17362 17363 /* Do not assume pad offsets for $c and $d are con- 17364 tiguous in 17365 my ($a,$b,$c); 17366 my ($d,$e,$f); 17367 */ 17368 if ( oldoldop->op_targ + old_count == base 17369 && old_count < OPpPADRANGE_COUNTMASK - count) { 17370 base = oldoldop->op_targ; 17371 count += old_count; 17372 reuse = 1; 17373 } 17374 } 17375 17376 /* if there's any immediately following singleton 17377 * my var's; then swallow them and the associated 17378 * nextstates; i.e. 17379 * my ($a,$b); my $c; my $d; 17380 * is treated as 17381 * my ($a,$b,$c,$d); 17382 */ 17383 17384 while ( ((p = followop->op_next)) 17385 && ( p->op_type == OP_PADSV 17386 || p->op_type == OP_PADAV 17387 || p->op_type == OP_PADHV) 17388 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID 17389 && (p->op_private & OPpLVAL_INTRO) == intro 17390 && !(p->op_private & ~OPpLVAL_INTRO) 17391 && p->op_next 17392 && ( p->op_next->op_type == OP_NEXTSTATE 17393 || p->op_next->op_type == OP_DBSTATE) 17394 && count < OPpPADRANGE_COUNTMASK 17395 && base + count == p->op_targ 17396 ) { 17397 count++; 17398 followop = p->op_next; 17399 } 17400 } 17401 else 17402 break; 17403 } 17404 17405 if (reuse) { 17406 assert(oldoldop->op_type == OP_PADRANGE); 17407 oldoldop->op_next = followop; 17408 oldoldop->op_private = (intro | count); 17409 o = oldoldop; 17410 oldop = NULL; 17411 oldoldop = NULL; 17412 } 17413 else { 17414 /* Convert the pushmark into a padrange. 17415 * To make Deparse easier, we guarantee that a padrange was 17416 * *always* formerly a pushmark */ 17417 assert(o->op_type == OP_PUSHMARK); 17418 o->op_next = followop; 17419 OpTYPE_set(o, OP_PADRANGE); 17420 o->op_targ = base; 17421 /* bit 7: INTRO; bit 6..0: count */ 17422 o->op_private = (intro | count); 17423 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL)) 17424 | gvoid * OPf_WANT_VOID 17425 | (defav ? OPf_SPECIAL : 0)); 17426 } 17427 break; 17428 } 17429 17430 case OP_RV2AV: 17431 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR) 17432 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0); 17433 break; 17434 17435 case OP_RV2HV: 17436 case OP_PADHV: 17437 /*'keys %h' in void or scalar context: skip the OP_KEYS 17438 * and perform the functionality directly in the RV2HV/PADHV 17439 * op 17440 */ 17441 if (o->op_flags & OPf_REF) { 17442 OP *k = o->op_next; 17443 U8 want = (k->op_flags & OPf_WANT); 17444 if ( k 17445 && k->op_type == OP_KEYS 17446 && ( want == OPf_WANT_VOID 17447 || want == OPf_WANT_SCALAR) 17448 && !(k->op_private & OPpMAYBE_LVSUB) 17449 && !(k->op_flags & OPf_MOD) 17450 ) { 17451 o->op_next = k->op_next; 17452 o->op_flags &= ~(OPf_REF|OPf_WANT); 17453 o->op_flags |= want; 17454 o->op_private |= (o->op_type == OP_PADHV ? 17455 OPpPADHV_ISKEYS : OPpRV2HV_ISKEYS); 17456 /* for keys(%lex), hold onto the OP_KEYS's targ 17457 * since padhv doesn't have its own targ to return 17458 * an int with */ 17459 if (!(o->op_type ==OP_PADHV && want == OPf_WANT_SCALAR)) 17460 op_null(k); 17461 } 17462 } 17463 17464 /* see if %h is used in boolean context */ 17465 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR) 17466 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL); 17467 17468 17469 if (o->op_type != OP_PADHV) 17470 break; 17471 /* FALLTHROUGH */ 17472 case OP_PADAV: 17473 if ( o->op_type == OP_PADAV 17474 && (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR 17475 ) 17476 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0); 17477 /* FALLTHROUGH */ 17478 case OP_PADSV: 17479 /* Skip over state($x) in void context. */ 17480 if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO) 17481 && (o->op_flags & OPf_WANT) == OPf_WANT_VOID) 17482 { 17483 oldop->op_next = o->op_next; 17484 goto redo_nextstate; 17485 } 17486 if (o->op_type != OP_PADAV) 17487 break; 17488 /* FALLTHROUGH */ 17489 case OP_GV: 17490 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) { 17491 OP* const pop = (o->op_type == OP_PADAV) ? 17492 o->op_next : o->op_next->op_next; 17493 IV i; 17494 if (pop && pop->op_type == OP_CONST && 17495 ((PL_op = pop->op_next)) && 17496 pop->op_next->op_type == OP_AELEM && 17497 !(pop->op_next->op_private & 17498 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) && 17499 (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127) 17500 { 17501 GV *gv; 17502 if (cSVOPx(pop)->op_private & OPpCONST_STRICT) 17503 no_bareword_allowed(pop); 17504 if (o->op_type == OP_GV) 17505 op_null(o->op_next); 17506 op_null(pop->op_next); 17507 op_null(pop); 17508 o->op_flags |= pop->op_next->op_flags & OPf_MOD; 17509 o->op_next = pop->op_next->op_next; 17510 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST]; 17511 o->op_private = (U8)i; 17512 if (o->op_type == OP_GV) { 17513 gv = cGVOPo_gv; 17514 GvAVn(gv); 17515 o->op_type = OP_AELEMFAST; 17516 } 17517 else 17518 o->op_type = OP_AELEMFAST_LEX; 17519 } 17520 if (o->op_type != OP_GV) 17521 break; 17522 } 17523 17524 /* Remove $foo from the op_next chain in void context. */ 17525 if (oldop 17526 && ( o->op_next->op_type == OP_RV2SV 17527 || o->op_next->op_type == OP_RV2AV 17528 || o->op_next->op_type == OP_RV2HV ) 17529 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID 17530 && !(o->op_next->op_private & OPpLVAL_INTRO)) 17531 { 17532 oldop->op_next = o->op_next->op_next; 17533 /* Reprocess the previous op if it is a nextstate, to 17534 allow double-nextstate optimisation. */ 17535 redo_nextstate: 17536 if (oldop->op_type == OP_NEXTSTATE) { 17537 oldop->op_opt = 0; 17538 o = oldop; 17539 oldop = oldoldop; 17540 oldoldop = NULL; 17541 goto redo; 17542 } 17543 o = oldop->op_next; 17544 goto redo; 17545 } 17546 else if (o->op_next->op_type == OP_RV2SV) { 17547 if (!(o->op_next->op_private & OPpDEREF)) { 17548 op_null(o->op_next); 17549 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO 17550 | OPpOUR_INTRO); 17551 o->op_next = o->op_next->op_next; 17552 OpTYPE_set(o, OP_GVSV); 17553 } 17554 } 17555 else if (o->op_next->op_type == OP_READLINE 17556 && o->op_next->op_next->op_type == OP_CONCAT 17557 && (o->op_next->op_next->op_flags & OPf_STACKED)) 17558 { 17559 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */ 17560 OpTYPE_set(o, OP_RCATLINE); 17561 o->op_flags |= OPf_STACKED; 17562 op_null(o->op_next->op_next); 17563 op_null(o->op_next); 17564 } 17565 17566 break; 17567 17568 case OP_NOT: 17569 break; 17570 17571 case OP_AND: 17572 case OP_OR: 17573 case OP_DOR: 17574 case OP_CMPCHAIN_AND: 17575 while (cLOGOP->op_other->op_type == OP_NULL) 17576 cLOGOP->op_other = cLOGOP->op_other->op_next; 17577 while (o->op_next && ( o->op_type == o->op_next->op_type 17578 || o->op_next->op_type == OP_NULL)) 17579 o->op_next = o->op_next->op_next; 17580 17581 /* If we're an OR and our next is an AND in void context, we'll 17582 follow its op_other on short circuit, same for reverse. 17583 We can't do this with OP_DOR since if it's true, its return 17584 value is the underlying value which must be evaluated 17585 by the next op. */ 17586 if (o->op_next && 17587 ( 17588 (IS_AND_OP(o) && IS_OR_OP(o->op_next)) 17589 || (IS_OR_OP(o) && IS_AND_OP(o->op_next)) 17590 ) 17591 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID 17592 ) { 17593 o->op_next = ((LOGOP*)o->op_next)->op_other; 17594 } 17595 DEFER(cLOGOP->op_other); 17596 o->op_opt = 1; 17597 break; 17598 17599 case OP_GREPWHILE: 17600 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR) 17601 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0); 17602 /* FALLTHROUGH */ 17603 case OP_COND_EXPR: 17604 case OP_MAPWHILE: 17605 case OP_ANDASSIGN: 17606 case OP_ORASSIGN: 17607 case OP_DORASSIGN: 17608 case OP_RANGE: 17609 case OP_ONCE: 17610 case OP_ARGDEFELEM: 17611 while (cLOGOP->op_other->op_type == OP_NULL) 17612 cLOGOP->op_other = cLOGOP->op_other->op_next; 17613 DEFER(cLOGOP->op_other); 17614 break; 17615 17616 case OP_ENTERLOOP: 17617 case OP_ENTERITER: 17618 while (cLOOP->op_redoop->op_type == OP_NULL) 17619 cLOOP->op_redoop = cLOOP->op_redoop->op_next; 17620 while (cLOOP->op_nextop->op_type == OP_NULL) 17621 cLOOP->op_nextop = cLOOP->op_nextop->op_next; 17622 while (cLOOP->op_lastop->op_type == OP_NULL) 17623 cLOOP->op_lastop = cLOOP->op_lastop->op_next; 17624 /* a while(1) loop doesn't have an op_next that escapes the 17625 * loop, so we have to explicitly follow the op_lastop to 17626 * process the rest of the code */ 17627 DEFER(cLOOP->op_lastop); 17628 break; 17629 17630 case OP_ENTERTRY: 17631 assert(cLOGOPo->op_other->op_type == OP_LEAVETRY); 17632 DEFER(cLOGOPo->op_other); 17633 break; 17634 17635 case OP_SUBST: 17636 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR) 17637 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0); 17638 assert(!(cPMOP->op_pmflags & PMf_ONCE)); 17639 while (cPMOP->op_pmstashstartu.op_pmreplstart && 17640 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL) 17641 cPMOP->op_pmstashstartu.op_pmreplstart 17642 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next; 17643 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart); 17644 break; 17645 17646 case OP_SORT: { 17647 OP *oright; 17648 17649 if (o->op_flags & OPf_SPECIAL) { 17650 /* first arg is a code block */ 17651 OP * const nullop = OpSIBLING(cLISTOP->op_first); 17652 OP * kid = cUNOPx(nullop)->op_first; 17653 17654 assert(nullop->op_type == OP_NULL); 17655 assert(kid->op_type == OP_SCOPE 17656 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE)); 17657 /* since OP_SORT doesn't have a handy op_other-style 17658 * field that can point directly to the start of the code 17659 * block, store it in the otherwise-unused op_next field 17660 * of the top-level OP_NULL. This will be quicker at 17661 * run-time, and it will also allow us to remove leading 17662 * OP_NULLs by just messing with op_nexts without 17663 * altering the basic op_first/op_sibling layout. */ 17664 kid = kLISTOP->op_first; 17665 assert( 17666 (kid->op_type == OP_NULL 17667 && ( kid->op_targ == OP_NEXTSTATE 17668 || kid->op_targ == OP_DBSTATE )) 17669 || kid->op_type == OP_STUB 17670 || kid->op_type == OP_ENTER 17671 || (PL_parser && PL_parser->error_count)); 17672 nullop->op_next = kid->op_next; 17673 DEFER(nullop->op_next); 17674 } 17675 17676 /* check that RHS of sort is a single plain array */ 17677 oright = cUNOPo->op_first; 17678 if (!oright || oright->op_type != OP_PUSHMARK) 17679 break; 17680 17681 if (o->op_private & OPpSORT_INPLACE) 17682 break; 17683 17684 /* reverse sort ... can be optimised. */ 17685 if (!OpHAS_SIBLING(cUNOPo)) { 17686 /* Nothing follows us on the list. */ 17687 OP * const reverse = o->op_next; 17688 17689 if (reverse->op_type == OP_REVERSE && 17690 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) { 17691 OP * const pushmark = cUNOPx(reverse)->op_first; 17692 if (pushmark && (pushmark->op_type == OP_PUSHMARK) 17693 && (OpSIBLING(cUNOPx(pushmark)) == o)) { 17694 /* reverse -> pushmark -> sort */ 17695 o->op_private |= OPpSORT_REVERSE; 17696 op_null(reverse); 17697 pushmark->op_next = oright->op_next; 17698 op_null(oright); 17699 } 17700 } 17701 } 17702 17703 break; 17704 } 17705 17706 case OP_REVERSE: { 17707 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av; 17708 OP *gvop = NULL; 17709 LISTOP *enter, *exlist; 17710 17711 if (o->op_private & OPpSORT_INPLACE) 17712 break; 17713 17714 enter = (LISTOP *) o->op_next; 17715 if (!enter) 17716 break; 17717 if (enter->op_type == OP_NULL) { 17718 enter = (LISTOP *) enter->op_next; 17719 if (!enter) 17720 break; 17721 } 17722 /* for $a (...) will have OP_GV then OP_RV2GV here. 17723 for (...) just has an OP_GV. */ 17724 if (enter->op_type == OP_GV) { 17725 gvop = (OP *) enter; 17726 enter = (LISTOP *) enter->op_next; 17727 if (!enter) 17728 break; 17729 if (enter->op_type == OP_RV2GV) { 17730 enter = (LISTOP *) enter->op_next; 17731 if (!enter) 17732 break; 17733 } 17734 } 17735 17736 if (enter->op_type != OP_ENTERITER) 17737 break; 17738 17739 iter = enter->op_next; 17740 if (!iter || iter->op_type != OP_ITER) 17741 break; 17742 17743 expushmark = enter->op_first; 17744 if (!expushmark || expushmark->op_type != OP_NULL 17745 || expushmark->op_targ != OP_PUSHMARK) 17746 break; 17747 17748 exlist = (LISTOP *) OpSIBLING(expushmark); 17749 if (!exlist || exlist->op_type != OP_NULL 17750 || exlist->op_targ != OP_LIST) 17751 break; 17752 17753 if (exlist->op_last != o) { 17754 /* Mmm. Was expecting to point back to this op. */ 17755 break; 17756 } 17757 theirmark = exlist->op_first; 17758 if (!theirmark || theirmark->op_type != OP_PUSHMARK) 17759 break; 17760 17761 if (OpSIBLING(theirmark) != o) { 17762 /* There's something between the mark and the reverse, eg 17763 for (1, reverse (...)) 17764 so no go. */ 17765 break; 17766 } 17767 17768 ourmark = ((LISTOP *)o)->op_first; 17769 if (!ourmark || ourmark->op_type != OP_PUSHMARK) 17770 break; 17771 17772 ourlast = ((LISTOP *)o)->op_last; 17773 if (!ourlast || ourlast->op_next != o) 17774 break; 17775 17776 rv2av = OpSIBLING(ourmark); 17777 if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av) 17778 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) { 17779 /* We're just reversing a single array. */ 17780 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF; 17781 enter->op_flags |= OPf_STACKED; 17782 } 17783 17784 /* We don't have control over who points to theirmark, so sacrifice 17785 ours. */ 17786 theirmark->op_next = ourmark->op_next; 17787 theirmark->op_flags = ourmark->op_flags; 17788 ourlast->op_next = gvop ? gvop : (OP *) enter; 17789 op_null(ourmark); 17790 op_null(o); 17791 enter->op_private |= OPpITER_REVERSED; 17792 iter->op_private |= OPpITER_REVERSED; 17793 17794 oldoldop = NULL; 17795 oldop = ourlast; 17796 o = oldop->op_next; 17797 goto redo; 17798 NOT_REACHED; /* NOTREACHED */ 17799 break; 17800 } 17801 17802 case OP_QR: 17803 case OP_MATCH: 17804 if (!(cPMOP->op_pmflags & PMf_ONCE)) { 17805 assert (!cPMOP->op_pmstashstartu.op_pmreplstart); 17806 } 17807 break; 17808 17809 case OP_RUNCV: 17810 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv) 17811 && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb))) 17812 { 17813 SV *sv; 17814 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef; 17815 else { 17816 sv = newRV((SV *)PL_compcv); 17817 sv_rvweaken(sv); 17818 SvREADONLY_on(sv); 17819 } 17820 OpTYPE_set(o, OP_CONST); 17821 o->op_flags |= OPf_SPECIAL; 17822 cSVOPo->op_sv = sv; 17823 } 17824 break; 17825 17826 case OP_SASSIGN: 17827 if (OP_GIMME(o,0) == G_VOID 17828 || ( o->op_next->op_type == OP_LINESEQ 17829 && ( o->op_next->op_next->op_type == OP_LEAVESUB 17830 || ( o->op_next->op_next->op_type == OP_RETURN 17831 && !CvLVALUE(PL_compcv))))) 17832 { 17833 OP *right = cBINOP->op_first; 17834 if (right) { 17835 /* sassign 17836 * RIGHT 17837 * substr 17838 * pushmark 17839 * arg1 17840 * arg2 17841 * ... 17842 * becomes 17843 * 17844 * ex-sassign 17845 * substr 17846 * pushmark 17847 * RIGHT 17848 * arg1 17849 * arg2 17850 * ... 17851 */ 17852 OP *left = OpSIBLING(right); 17853 if (left->op_type == OP_SUBSTR 17854 && (left->op_private & 7) < 4) { 17855 op_null(o); 17856 /* cut out right */ 17857 op_sibling_splice(o, NULL, 1, NULL); 17858 /* and insert it as second child of OP_SUBSTR */ 17859 op_sibling_splice(left, cBINOPx(left)->op_first, 0, 17860 right); 17861 left->op_private |= OPpSUBSTR_REPL_FIRST; 17862 left->op_flags = 17863 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID; 17864 } 17865 } 17866 } 17867 break; 17868 17869 case OP_AASSIGN: { 17870 int l, r, lr, lscalars, rscalars; 17871 17872 /* handle common vars detection, e.g. ($a,$b) = ($b,$a). 17873 Note that we do this now rather than in newASSIGNOP(), 17874 since only by now are aliased lexicals flagged as such 17875 17876 See the essay "Common vars in list assignment" above for 17877 the full details of the rationale behind all the conditions 17878 below. 17879 17880 PL_generation sorcery: 17881 To detect whether there are common vars, the global var 17882 PL_generation is incremented for each assign op we scan. 17883 Then we run through all the lexical variables on the LHS, 17884 of the assignment, setting a spare slot in each of them to 17885 PL_generation. Then we scan the RHS, and if any lexicals 17886 already have that value, we know we've got commonality. 17887 Also, if the generation number is already set to 17888 PERL_INT_MAX, then the variable is involved in aliasing, so 17889 we also have potential commonality in that case. 17890 */ 17891 17892 PL_generation++; 17893 /* scan LHS */ 17894 lscalars = 0; 17895 l = S_aassign_scan(aTHX_ cLISTOPo->op_last, FALSE, &lscalars); 17896 /* scan RHS */ 17897 rscalars = 0; 17898 r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, &rscalars); 17899 lr = (l|r); 17900 17901 17902 /* After looking for things which are *always* safe, this main 17903 * if/else chain selects primarily based on the type of the 17904 * LHS, gradually working its way down from the more dangerous 17905 * to the more restrictive and thus safer cases */ 17906 17907 if ( !l /* () = ....; */ 17908 || !r /* .... = (); */ 17909 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */ 17910 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */ 17911 || (lscalars < 2) /* ($x, undef) = ... */ 17912 ) { 17913 NOOP; /* always safe */ 17914 } 17915 else if (l & AAS_DANGEROUS) { 17916 /* always dangerous */ 17917 o->op_private |= OPpASSIGN_COMMON_SCALAR; 17918 o->op_private |= OPpASSIGN_COMMON_AGG; 17919 } 17920 else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) { 17921 /* package vars are always dangerous - too many 17922 * aliasing possibilities */ 17923 if (l & AAS_PKG_SCALAR) 17924 o->op_private |= OPpASSIGN_COMMON_SCALAR; 17925 if (l & AAS_PKG_AGG) 17926 o->op_private |= OPpASSIGN_COMMON_AGG; 17927 } 17928 else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG 17929 |AAS_LEX_SCALAR|AAS_LEX_AGG)) 17930 { 17931 /* LHS contains only lexicals and safe ops */ 17932 17933 if (l & (AAS_MY_AGG|AAS_LEX_AGG)) 17934 o->op_private |= OPpASSIGN_COMMON_AGG; 17935 17936 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) { 17937 if (lr & AAS_LEX_SCALAR_COMM) 17938 o->op_private |= OPpASSIGN_COMMON_SCALAR; 17939 else if ( !(l & AAS_LEX_SCALAR) 17940 && (r & AAS_DEFAV)) 17941 { 17942 /* falsely mark 17943 * my (...) = @_ 17944 * as scalar-safe for performance reasons. 17945 * (it will still have been marked _AGG if necessary */ 17946 NOOP; 17947 } 17948 else if (r & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS)) 17949 /* if there are only lexicals on the LHS and no 17950 * common ones on the RHS, then we assume that the 17951 * only way those lexicals could also get 17952 * on the RHS is via some sort of dereffing or 17953 * closure, e.g. 17954 * $r = \$lex; 17955 * ($lex, $x) = (1, $$r) 17956 * and in this case we assume the var must have 17957 * a bumped ref count. So if its ref count is 1, 17958 * it must only be on the LHS. 17959 */ 17960 o->op_private |= OPpASSIGN_COMMON_RC1; 17961 } 17962 } 17963 17964 /* ... = ($x) 17965 * may have to handle aggregate on LHS, but we can't 17966 * have common scalars. */ 17967 if (rscalars < 2) 17968 o->op_private &= 17969 ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1); 17970 17971 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR) 17972 S_check_for_bool_cxt(o, 1, OPpASSIGN_TRUEBOOL, 0); 17973 break; 17974 } 17975 17976 case OP_REF: 17977 /* see if ref() is used in boolean context */ 17978 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR) 17979 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL); 17980 break; 17981 17982 case OP_LENGTH: 17983 /* see if the op is used in known boolean context, 17984 * but not if OA_TARGLEX optimisation is enabled */ 17985 if ( (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR 17986 && !(o->op_private & OPpTARGET_MY) 17987 ) 17988 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0); 17989 break; 17990 17991 case OP_POS: 17992 /* see if the op is used in known boolean context */ 17993 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR) 17994 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0); 17995 break; 17996 17997 case OP_CUSTOM: { 17998 Perl_cpeep_t cpeep = 17999 XopENTRYCUSTOM(o, xop_peep); 18000 if (cpeep) 18001 cpeep(aTHX_ o, oldop); 18002 break; 18003 } 18004 18005 } 18006 /* did we just null the current op? If so, re-process it to handle 18007 * eliding "empty" ops from the chain */ 18008 if (o->op_type == OP_NULL && oldop && oldop->op_next == o) { 18009 o->op_opt = 0; 18010 o = oldop; 18011 } 18012 else { 18013 oldoldop = oldop; 18014 oldop = o; 18015 } 18016 } 18017 LEAVE; 18018 } 18019 18020 void 18021 Perl_peep(pTHX_ OP *o) 18022 { 18023 CALL_RPEEP(o); 18024 } 18025 18026 /* 18027 =head1 Custom Operators 18028 18029 =for apidoc Perl_custom_op_xop 18030 Return the XOP structure for a given custom op. This macro should be 18031 considered internal to C<OP_NAME> and the other access macros: use them instead. 18032 This macro does call a function. Prior 18033 to 5.19.6, this was implemented as a 18034 function. 18035 18036 =cut 18037 */ 18038 18039 18040 /* use PERL_MAGIC_ext to call a function to free the xop structure when 18041 * freeing PL_custom_ops */ 18042 18043 static int 18044 custom_op_register_free(pTHX_ SV *sv, MAGIC *mg) 18045 { 18046 XOP *xop; 18047 18048 PERL_UNUSED_ARG(mg); 18049 xop = INT2PTR(XOP *, SvIV(sv)); 18050 Safefree(xop->xop_name); 18051 Safefree(xop->xop_desc); 18052 Safefree(xop); 18053 return 0; 18054 } 18055 18056 18057 static const MGVTBL custom_op_register_vtbl = { 18058 0, /* get */ 18059 0, /* set */ 18060 0, /* len */ 18061 0, /* clear */ 18062 custom_op_register_free, /* free */ 18063 0, /* copy */ 18064 0, /* dup */ 18065 #ifdef MGf_LOCAL 18066 0, /* local */ 18067 #endif 18068 }; 18069 18070 18071 XOPRETANY 18072 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field) 18073 { 18074 SV *keysv; 18075 HE *he = NULL; 18076 XOP *xop; 18077 18078 static const XOP xop_null = { 0, 0, 0, 0, 0 }; 18079 18080 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD; 18081 assert(o->op_type == OP_CUSTOM); 18082 18083 /* This is wrong. It assumes a function pointer can be cast to IV, 18084 * which isn't guaranteed, but this is what the old custom OP code 18085 * did. In principle it should be safer to Copy the bytes of the 18086 * pointer into a PV: since the new interface is hidden behind 18087 * functions, this can be changed later if necessary. */ 18088 /* Change custom_op_xop if this ever happens */ 18089 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr))); 18090 18091 if (PL_custom_ops) 18092 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0); 18093 18094 /* See if the op isn't registered, but its name *is* registered. 18095 * That implies someone is using the pre-5.14 API,where only name and 18096 * description could be registered. If so, fake up a real 18097 * registration. 18098 * We only check for an existing name, and assume no one will have 18099 * just registered a desc */ 18100 if (!he && PL_custom_op_names && 18101 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0)) 18102 ) { 18103 const char *pv; 18104 STRLEN l; 18105 18106 /* XXX does all this need to be shared mem? */ 18107 Newxz(xop, 1, XOP); 18108 pv = SvPV(HeVAL(he), l); 18109 XopENTRY_set(xop, xop_name, savepvn(pv, l)); 18110 if (PL_custom_op_descs && 18111 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0)) 18112 ) { 18113 pv = SvPV(HeVAL(he), l); 18114 XopENTRY_set(xop, xop_desc, savepvn(pv, l)); 18115 } 18116 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop); 18117 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0); 18118 /* add magic to the SV so that the xop struct (pointed to by 18119 * SvIV(sv)) is freed. Normally a static xop is registered, but 18120 * for this backcompat hack, we've alloced one */ 18121 (void)sv_magicext(HeVAL(he), NULL, PERL_MAGIC_ext, 18122 &custom_op_register_vtbl, NULL, 0); 18123 18124 } 18125 else { 18126 if (!he) 18127 xop = (XOP *)&xop_null; 18128 else 18129 xop = INT2PTR(XOP *, SvIV(HeVAL(he))); 18130 } 18131 { 18132 XOPRETANY any; 18133 if(field == XOPe_xop_ptr) { 18134 any.xop_ptr = xop; 18135 } else { 18136 const U32 flags = XopFLAGS(xop); 18137 if(flags & field) { 18138 switch(field) { 18139 case XOPe_xop_name: 18140 any.xop_name = xop->xop_name; 18141 break; 18142 case XOPe_xop_desc: 18143 any.xop_desc = xop->xop_desc; 18144 break; 18145 case XOPe_xop_class: 18146 any.xop_class = xop->xop_class; 18147 break; 18148 case XOPe_xop_peep: 18149 any.xop_peep = xop->xop_peep; 18150 break; 18151 default: 18152 NOT_REACHED; /* NOTREACHED */ 18153 break; 18154 } 18155 } else { 18156 switch(field) { 18157 case XOPe_xop_name: 18158 any.xop_name = XOPd_xop_name; 18159 break; 18160 case XOPe_xop_desc: 18161 any.xop_desc = XOPd_xop_desc; 18162 break; 18163 case XOPe_xop_class: 18164 any.xop_class = XOPd_xop_class; 18165 break; 18166 case XOPe_xop_peep: 18167 any.xop_peep = XOPd_xop_peep; 18168 break; 18169 default: 18170 NOT_REACHED; /* NOTREACHED */ 18171 break; 18172 } 18173 } 18174 } 18175 /* On some platforms (HP-UX, IA64) gcc emits a warning for this function: 18176 * op.c: In function 'Perl_custom_op_get_field': 18177 * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized] 18178 * This is because on those platforms (with -DEBUGGING) NOT_REACHED 18179 * expands to assert(0), which expands to ((0) ? (void)0 : 18180 * __assert(...)), and gcc doesn't know that __assert can never return. */ 18181 return any; 18182 } 18183 } 18184 18185 /* 18186 =for apidoc custom_op_register 18187 Register a custom op. See L<perlguts/"Custom Operators">. 18188 18189 =cut 18190 */ 18191 18192 void 18193 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop) 18194 { 18195 SV *keysv; 18196 18197 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER; 18198 18199 /* see the comment in custom_op_xop */ 18200 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr))); 18201 18202 if (!PL_custom_ops) 18203 PL_custom_ops = newHV(); 18204 18205 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0)) 18206 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name); 18207 } 18208 18209 /* 18210 18211 =for apidoc core_prototype 18212 18213 This function assigns the prototype of the named core function to C<sv>, or 18214 to a new mortal SV if C<sv> is C<NULL>. It returns the modified C<sv>, or 18215 C<NULL> if the core function has no prototype. C<code> is a code as returned 18216 by C<keyword()>. It must not be equal to 0. 18217 18218 =cut 18219 */ 18220 18221 SV * 18222 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code, 18223 int * const opnum) 18224 { 18225 int i = 0, n = 0, seen_question = 0, defgv = 0; 18226 I32 oa; 18227 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2) 18228 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */ 18229 bool nullret = FALSE; 18230 18231 PERL_ARGS_ASSERT_CORE_PROTOTYPE; 18232 18233 assert (code); 18234 18235 if (!sv) sv = sv_newmortal(); 18236 18237 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv 18238 18239 switch (code < 0 ? -code : code) { 18240 case KEY_and : case KEY_chop: case KEY_chomp: 18241 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec : 18242 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto : 18243 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le : 18244 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next : 18245 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr : 18246 case KEY_redo : case KEY_require: case KEY_return: case KEY_say : 18247 case KEY_select: case KEY_sort : case KEY_split : case KEY_system: 18248 case KEY_x : case KEY_xor : 18249 if (!opnum) return NULL; nullret = TRUE; goto findopnum; 18250 case KEY_glob: retsetpvs("_;", OP_GLOB); 18251 case KEY_keys: retsetpvs("\\[%@]", OP_KEYS); 18252 case KEY_values: retsetpvs("\\[%@]", OP_VALUES); 18253 case KEY_each: retsetpvs("\\[%@]", OP_EACH); 18254 case KEY_pos: retsetpvs(";\\[$*]", OP_POS); 18255 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__: 18256 retsetpvs("", 0); 18257 case KEY_evalbytes: 18258 name = "entereval"; break; 18259 case KEY_readpipe: 18260 name = "backtick"; 18261 } 18262 18263 #undef retsetpvs 18264 18265 findopnum: 18266 while (i < MAXO) { /* The slow way. */ 18267 if (strEQ(name, PL_op_name[i]) 18268 || strEQ(name, PL_op_desc[i])) 18269 { 18270 if (nullret) { assert(opnum); *opnum = i; return NULL; } 18271 goto found; 18272 } 18273 i++; 18274 } 18275 return NULL; 18276 found: 18277 defgv = PL_opargs[i] & OA_DEFGV; 18278 oa = PL_opargs[i] >> OASHIFT; 18279 while (oa) { 18280 if (oa & OA_OPTIONAL && !seen_question && ( 18281 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF 18282 )) { 18283 seen_question = 1; 18284 str[n++] = ';'; 18285 } 18286 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF 18287 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF 18288 /* But globs are already references (kinda) */ 18289 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF 18290 ) { 18291 str[n++] = '\\'; 18292 } 18293 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF 18294 && !scalar_mod_type(NULL, i)) { 18295 str[n++] = '['; 18296 str[n++] = '$'; 18297 str[n++] = '@'; 18298 str[n++] = '%'; 18299 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&'; 18300 str[n++] = '*'; 18301 str[n++] = ']'; 18302 } 18303 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)]; 18304 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') { 18305 str[n-1] = '_'; defgv = 0; 18306 } 18307 oa = oa >> 4; 18308 } 18309 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';'; 18310 str[n++] = '\0'; 18311 sv_setpvn(sv, str, n - 1); 18312 if (opnum) *opnum = i; 18313 return sv; 18314 } 18315 18316 OP * 18317 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code, 18318 const int opnum) 18319 { 18320 OP * const argop = (opnum == OP_SELECT && code) ? NULL : 18321 newSVOP(OP_COREARGS,0,coreargssv); 18322 OP *o; 18323 18324 PERL_ARGS_ASSERT_CORESUB_OP; 18325 18326 switch(opnum) { 18327 case 0: 18328 return op_append_elem(OP_LINESEQ, 18329 argop, 18330 newSLICEOP(0, 18331 newSVOP(OP_CONST, 0, newSViv(-code % 3)), 18332 newOP(OP_CALLER,0) 18333 ) 18334 ); 18335 case OP_EACH: 18336 case OP_KEYS: 18337 case OP_VALUES: 18338 o = newUNOP(OP_AVHVSWITCH,0,argop); 18339 o->op_private = opnum-OP_EACH; 18340 return o; 18341 case OP_SELECT: /* which represents OP_SSELECT as well */ 18342 if (code) 18343 return newCONDOP( 18344 0, 18345 newBINOP(OP_GT, 0, 18346 newAVREF(newGVOP(OP_GV, 0, PL_defgv)), 18347 newSVOP(OP_CONST, 0, newSVuv(1)) 18348 ), 18349 coresub_op(newSVuv((UV)OP_SSELECT), 0, 18350 OP_SSELECT), 18351 coresub_op(coreargssv, 0, OP_SELECT) 18352 ); 18353 /* FALLTHROUGH */ 18354 default: 18355 switch (PL_opargs[opnum] & OA_CLASS_MASK) { 18356 case OA_BASEOP: 18357 return op_append_elem( 18358 OP_LINESEQ, argop, 18359 newOP(opnum, 18360 opnum == OP_WANTARRAY || opnum == OP_RUNCV 18361 ? OPpOFFBYONE << 8 : 0) 18362 ); 18363 case OA_BASEOP_OR_UNOP: 18364 if (opnum == OP_ENTEREVAL) { 18365 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop); 18366 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES; 18367 } 18368 else o = newUNOP(opnum,0,argop); 18369 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE; 18370 else { 18371 onearg: 18372 if (is_handle_constructor(o, 1)) 18373 argop->op_private |= OPpCOREARGS_DEREF1; 18374 if (scalar_mod_type(NULL, opnum)) 18375 argop->op_private |= OPpCOREARGS_SCALARMOD; 18376 } 18377 return o; 18378 default: 18379 o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop); 18380 if (is_handle_constructor(o, 2)) 18381 argop->op_private |= OPpCOREARGS_DEREF2; 18382 if (opnum == OP_SUBSTR) { 18383 o->op_private |= OPpMAYBE_LVSUB; 18384 return o; 18385 } 18386 else goto onearg; 18387 } 18388 } 18389 } 18390 18391 void 18392 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv, 18393 SV * const *new_const_svp) 18394 { 18395 const char *hvname; 18396 bool is_const = !!CvCONST(old_cv); 18397 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL; 18398 18399 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV; 18400 18401 if (is_const && new_const_svp && old_const_sv == *new_const_svp) 18402 return; 18403 /* They are 2 constant subroutines generated from 18404 the same constant. This probably means that 18405 they are really the "same" proxy subroutine 18406 instantiated in 2 places. Most likely this is 18407 when a constant is exported twice. Don't warn. 18408 */ 18409 if ( 18410 (ckWARN(WARN_REDEFINE) 18411 && !( 18412 CvGV(old_cv) && GvSTASH(CvGV(old_cv)) 18413 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7 18414 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))), 18415 strEQ(hvname, "autouse")) 18416 ) 18417 ) 18418 || (is_const 18419 && ckWARN_d(WARN_REDEFINE) 18420 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp)) 18421 ) 18422 ) 18423 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), 18424 is_const 18425 ? "Constant subroutine %" SVf " redefined" 18426 : "Subroutine %" SVf " redefined", 18427 SVfARG(name)); 18428 } 18429 18430 /* 18431 =head1 Hook manipulation 18432 18433 These functions provide convenient and thread-safe means of manipulating 18434 hook variables. 18435 18436 =cut 18437 */ 18438 18439 /* 18440 =for apidoc wrap_op_checker 18441 18442 Puts a C function into the chain of check functions for a specified op 18443 type. This is the preferred way to manipulate the L</PL_check> array. 18444 C<opcode> specifies which type of op is to be affected. C<new_checker> 18445 is a pointer to the C function that is to be added to that opcode's 18446 check chain, and C<old_checker_p> points to the storage location where a 18447 pointer to the next function in the chain will be stored. The value of 18448 C<new_checker> is written into the L</PL_check> array, while the value 18449 previously stored there is written to C<*old_checker_p>. 18450 18451 L</PL_check> is global to an entire process, and a module wishing to 18452 hook op checking may find itself invoked more than once per process, 18453 typically in different threads. To handle that situation, this function 18454 is idempotent. The location C<*old_checker_p> must initially (once 18455 per process) contain a null pointer. A C variable of static duration 18456 (declared at file scope, typically also marked C<static> to give 18457 it internal linkage) will be implicitly initialised appropriately, 18458 if it does not have an explicit initialiser. This function will only 18459 actually modify the check chain if it finds C<*old_checker_p> to be null. 18460 This function is also thread safe on the small scale. It uses appropriate 18461 locking to avoid race conditions in accessing L</PL_check>. 18462 18463 When this function is called, the function referenced by C<new_checker> 18464 must be ready to be called, except for C<*old_checker_p> being unfilled. 18465 In a threading situation, C<new_checker> may be called immediately, 18466 even before this function has returned. C<*old_checker_p> will always 18467 be appropriately set before C<new_checker> is called. If C<new_checker> 18468 decides not to do anything special with an op that it is given (which 18469 is the usual case for most uses of op check hooking), it must chain the 18470 check function referenced by C<*old_checker_p>. 18471 18472 Taken all together, XS code to hook an op checker should typically look 18473 something like this: 18474 18475 static Perl_check_t nxck_frob; 18476 static OP *myck_frob(pTHX_ OP *op) { 18477 ... 18478 op = nxck_frob(aTHX_ op); 18479 ... 18480 return op; 18481 } 18482 BOOT: 18483 wrap_op_checker(OP_FROB, myck_frob, &nxck_frob); 18484 18485 If you want to influence compilation of calls to a specific subroutine, 18486 then use L</cv_set_call_checker_flags> rather than hooking checking of 18487 all C<entersub> ops. 18488 18489 =cut 18490 */ 18491 18492 void 18493 Perl_wrap_op_checker(pTHX_ Optype opcode, 18494 Perl_check_t new_checker, Perl_check_t *old_checker_p) 18495 { 18496 dVAR; 18497 18498 PERL_UNUSED_CONTEXT; 18499 PERL_ARGS_ASSERT_WRAP_OP_CHECKER; 18500 if (*old_checker_p) return; 18501 OP_CHECK_MUTEX_LOCK; 18502 if (!*old_checker_p) { 18503 *old_checker_p = PL_check[opcode]; 18504 PL_check[opcode] = new_checker; 18505 } 18506 OP_CHECK_MUTEX_UNLOCK; 18507 } 18508 18509 #include "XSUB.h" 18510 18511 /* Efficient sub that returns a constant scalar value. */ 18512 static void 18513 const_sv_xsub(pTHX_ CV* cv) 18514 { 18515 dXSARGS; 18516 SV *const sv = MUTABLE_SV(XSANY.any_ptr); 18517 PERL_UNUSED_ARG(items); 18518 if (!sv) { 18519 XSRETURN(0); 18520 } 18521 EXTEND(sp, 1); 18522 ST(0) = sv; 18523 XSRETURN(1); 18524 } 18525 18526 static void 18527 const_av_xsub(pTHX_ CV* cv) 18528 { 18529 dXSARGS; 18530 AV * const av = MUTABLE_AV(XSANY.any_ptr); 18531 SP -= items; 18532 assert(av); 18533 #ifndef DEBUGGING 18534 if (!av) { 18535 XSRETURN(0); 18536 } 18537 #endif 18538 if (SvRMAGICAL(av)) 18539 Perl_croak(aTHX_ "Magical list constants are not supported"); 18540 if (GIMME_V != G_ARRAY) { 18541 EXTEND(SP, 1); 18542 ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1)); 18543 XSRETURN(1); 18544 } 18545 EXTEND(SP, AvFILLp(av)+1); 18546 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *); 18547 XSRETURN(AvFILLp(av)+1); 18548 } 18549 18550 /* Copy an existing cop->cop_warnings field. 18551 * If it's one of the standard addresses, just re-use the address. 18552 * This is the e implementation for the DUP_WARNINGS() macro 18553 */ 18554 18555 STRLEN* 18556 Perl_dup_warnings(pTHX_ STRLEN* warnings) 18557 { 18558 Size_t size; 18559 STRLEN *new_warnings; 18560 18561 if (warnings == NULL || specialWARN(warnings)) 18562 return warnings; 18563 18564 size = sizeof(*warnings) + *warnings; 18565 18566 new_warnings = (STRLEN*)PerlMemShared_malloc(size); 18567 Copy(warnings, new_warnings, size, char); 18568 return new_warnings; 18569 } 18570 18571 /* 18572 * ex: set ts=8 sts=4 sw=4 et: 18573 */ 18574