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 * A Perl program is compiled into a tree of OPs. Each op contains 26 * structural pointers (eg to its siblings and the next op in the 27 * execution sequence), a pointer to the function that would execute the 28 * op, plus any data specific to that op. For example, an OP_CONST op 29 * points to the pp_const() function and to an SV containing the constant 30 * value. When pp_const() is executed, its job is to push that SV onto the 31 * stack. 32 * 33 * OPs are mainly created by the newFOO() functions, which are mainly 34 * called from the parser (in perly.y) as the code is parsed. For example 35 * the Perl code $a + $b * $c would cause the equivalent of the following 36 * to be called (oversimplifying a bit): 37 * 38 * newBINOP(OP_ADD, flags, 39 * newSVREF($a), 40 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c)) 41 * ) 42 * 43 * Note that during the build of miniperl, a temporary copy of this file 44 * is made, called opmini.c. 45 */ 46 47 /* 48 Perl's compiler is essentially a 3-pass compiler with interleaved phases: 49 50 A bottom-up pass 51 A top-down pass 52 An execution-order pass 53 54 The bottom-up pass is represented by all the "newOP" routines and 55 the ck_ routines. The bottom-upness is actually driven by yacc. 56 So at the point that a ck_ routine fires, we have no idea what the 57 context is, either upward in the syntax tree, or either forward or 58 backward in the execution order. (The bottom-up parser builds that 59 part of the execution order it knows about, but if you follow the "next" 60 links around, you'll find it's actually a closed loop through the 61 top level node.) 62 63 Whenever the bottom-up parser gets to a node that supplies context to 64 its components, it invokes that portion of the top-down pass that applies 65 to that part of the subtree (and marks the top node as processed, so 66 if a node further up supplies context, it doesn't have to take the 67 plunge again). As a particular subcase of this, as the new node is 68 built, it takes all the closed execution loops of its subcomponents 69 and links them into a new closed loop for the higher level node. But 70 it's still not the real execution order. 71 72 The actual execution order is not known till we get a grammar reduction 73 to a top-level unit like a subroutine or file that will be called by 74 "name" rather than via a "next" pointer. At that point, we can call 75 into peep() to do that code's portion of the 3rd pass. It has to be 76 recursive, but it's recursive on basic blocks, not on tree nodes. 77 */ 78 79 /* To implement user lexical pragmas, there needs to be a way at run time to 80 get the compile time state of %^H for that block. Storing %^H in every 81 block (or even COP) would be very expensive, so a different approach is 82 taken. The (running) state of %^H is serialised into a tree of HE-like 83 structs. Stores into %^H are chained onto the current leaf as a struct 84 refcounted_he * with the key and the value. Deletes from %^H are saved 85 with a value of PL_sv_placeholder. The state of %^H at any point can be 86 turned back into a regular HV by walking back up the tree from that point's 87 leaf, ignoring any key you've already seen (placeholder or not), storing 88 the rest into the HV structure, then removing the placeholders. Hence 89 memory is only used to store the %^H deltas from the enclosing COP, rather 90 than the entire %^H on each COP. 91 92 To cause actions on %^H to write out the serialisation records, it has 93 magic type 'H'. This magic (itself) does nothing, but its presence causes 94 the values to gain magic type 'h', which has entries for set and clear. 95 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store 96 record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS> 97 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that 98 it will be correctly restored when any inner compiling scope is exited. 99 */ 100 101 #include "EXTERN.h" 102 #define PERL_IN_OP_C 103 #include "perl.h" 104 #include "keywords.h" 105 #include "feature.h" 106 #include "regcomp.h" 107 108 #define CALL_PEEP(o) PL_peepp(aTHX_ o) 109 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o) 110 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o) 111 112 /* remove any leading "empty" ops from the op_next chain whose first 113 * node's address is stored in op_p. Store the updated address of the 114 * first node in op_p. 115 */ 116 117 STATIC void 118 S_prune_chain_head(pTHX_ OP** op_p) 119 { 120 while (*op_p 121 && ( (*op_p)->op_type == OP_NULL 122 || (*op_p)->op_type == OP_SCOPE 123 || (*op_p)->op_type == OP_SCALAR 124 || (*op_p)->op_type == OP_LINESEQ) 125 ) 126 *op_p = (*op_p)->op_next; 127 } 128 129 130 /* See the explanatory comments above struct opslab in op.h. */ 131 132 #ifdef PERL_DEBUG_READONLY_OPS 133 # define PERL_SLAB_SIZE 128 134 # define PERL_MAX_SLAB_SIZE 4096 135 # include <sys/mman.h> 136 #endif 137 138 #ifndef PERL_SLAB_SIZE 139 # define PERL_SLAB_SIZE 64 140 #endif 141 #ifndef PERL_MAX_SLAB_SIZE 142 # define PERL_MAX_SLAB_SIZE 2048 143 #endif 144 145 /* rounds up to nearest pointer */ 146 #define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *)) 147 #define DIFF(o,p) ((size_t)((I32 **)(p) - (I32**)(o))) 148 149 static OPSLAB * 150 S_new_slab(pTHX_ size_t sz) 151 { 152 #ifdef PERL_DEBUG_READONLY_OPS 153 OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *), 154 PROT_READ|PROT_WRITE, 155 MAP_ANON|MAP_PRIVATE, -1, 0); 156 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n", 157 (unsigned long) sz, slab)); 158 if (slab == MAP_FAILED) { 159 perror("mmap failed"); 160 abort(); 161 } 162 slab->opslab_size = (U16)sz; 163 #else 164 OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *)); 165 #endif 166 slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1); 167 return slab; 168 } 169 170 /* requires double parens and aTHX_ */ 171 #define DEBUG_S_warn(args) \ 172 DEBUG_S( \ 173 PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \ 174 ) 175 176 void * 177 Perl_Slab_Alloc(pTHX_ size_t sz) 178 { 179 dVAR; 180 OPSLAB *slab; 181 OPSLAB *slab2; 182 OPSLOT *slot; 183 OP *o; 184 size_t opsz, space; 185 186 /* We only allocate ops from the slab during subroutine compilation. 187 We find the slab via PL_compcv, hence that must be non-NULL. It could 188 also be pointing to a subroutine which is now fully set up (CvROOT() 189 pointing to the top of the optree for that sub), or a subroutine 190 which isn't using the slab allocator. If our sanity checks aren't met, 191 don't use a slab, but allocate the OP directly from the heap. */ 192 if (!PL_compcv || CvROOT(PL_compcv) 193 || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv))) 194 return PerlMemShared_calloc(1, sz); 195 196 /* While the subroutine is under construction, the slabs are accessed via 197 CvSTART(), to avoid needing to expand PVCV by one pointer for something 198 unneeded at runtime. Once a subroutine is constructed, the slabs are 199 accessed via CvROOT(). So if CvSTART() is NULL, no slab has been 200 allocated yet. See the commit message for 8be227ab5eaa23f2 for more 201 details. */ 202 if (!CvSTART(PL_compcv)) { 203 CvSTART(PL_compcv) = 204 (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE)); 205 CvSLABBED_on(PL_compcv); 206 slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */ 207 } 208 else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt; 209 210 opsz = SIZE_TO_PSIZE(sz); 211 sz = opsz + OPSLOT_HEADER_P; 212 213 /* The slabs maintain a free list of OPs. In particular, constant folding 214 will free up OPs, so it makes sense to re-use them where possible. A 215 freed up slot is used in preference to a new allocation. */ 216 if (slab->opslab_freed) { 217 OP **too = &slab->opslab_freed; 218 o = *too; 219 DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", o, slab)); 220 while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) { 221 DEBUG_S_warn((aTHX_ "Alas! too small")); 222 o = *(too = &o->op_next); 223 if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", o)); } 224 } 225 if (o) { 226 *too = o->op_next; 227 Zero(o, opsz, I32 *); 228 o->op_slabbed = 1; 229 return (void *)o; 230 } 231 } 232 233 #define INIT_OPSLOT \ 234 slot->opslot_slab = slab; \ 235 slot->opslot_next = slab2->opslab_first; \ 236 slab2->opslab_first = slot; \ 237 o = &slot->opslot_op; \ 238 o->op_slabbed = 1 239 240 /* The partially-filled slab is next in the chain. */ 241 slab2 = slab->opslab_next ? slab->opslab_next : slab; 242 if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) { 243 /* Remaining space is too small. */ 244 245 /* If we can fit a BASEOP, add it to the free chain, so as not 246 to waste it. */ 247 if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) { 248 slot = &slab2->opslab_slots; 249 INIT_OPSLOT; 250 o->op_type = OP_FREED; 251 o->op_next = slab->opslab_freed; 252 slab->opslab_freed = o; 253 } 254 255 /* Create a new slab. Make this one twice as big. */ 256 slot = slab2->opslab_first; 257 while (slot->opslot_next) slot = slot->opslot_next; 258 slab2 = S_new_slab(aTHX_ 259 (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE 260 ? PERL_MAX_SLAB_SIZE 261 : (DIFF(slab2, slot)+1)*2); 262 slab2->opslab_next = slab->opslab_next; 263 slab->opslab_next = slab2; 264 } 265 assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz); 266 267 /* Create a new op slot */ 268 slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz); 269 assert(slot >= &slab2->opslab_slots); 270 if (DIFF(&slab2->opslab_slots, slot) 271 < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) 272 slot = &slab2->opslab_slots; 273 INIT_OPSLOT; 274 DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", o, slab)); 275 return (void *)o; 276 } 277 278 #undef INIT_OPSLOT 279 280 #ifdef PERL_DEBUG_READONLY_OPS 281 void 282 Perl_Slab_to_ro(pTHX_ OPSLAB *slab) 283 { 284 PERL_ARGS_ASSERT_SLAB_TO_RO; 285 286 if (slab->opslab_readonly) return; 287 slab->opslab_readonly = 1; 288 for (; slab; slab = slab->opslab_next) { 289 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n", 290 (unsigned long) slab->opslab_size, slab));*/ 291 if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ)) 292 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab, 293 (unsigned long)slab->opslab_size, errno); 294 } 295 } 296 297 void 298 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab) 299 { 300 OPSLAB *slab2; 301 302 PERL_ARGS_ASSERT_SLAB_TO_RW; 303 304 if (!slab->opslab_readonly) return; 305 slab2 = slab; 306 for (; slab2; slab2 = slab2->opslab_next) { 307 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n", 308 (unsigned long) size, slab2));*/ 309 if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *), 310 PROT_READ|PROT_WRITE)) { 311 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab, 312 (unsigned long)slab2->opslab_size, errno); 313 } 314 } 315 slab->opslab_readonly = 0; 316 } 317 318 #else 319 # define Slab_to_rw(op) NOOP 320 #endif 321 322 /* This cannot possibly be right, but it was copied from the old slab 323 allocator, to which it was originally added, without explanation, in 324 commit 083fcd5. */ 325 #ifdef NETWARE 326 # define PerlMemShared PerlMem 327 #endif 328 329 void 330 Perl_Slab_Free(pTHX_ void *op) 331 { 332 dVAR; 333 OP * const o = (OP *)op; 334 OPSLAB *slab; 335 336 PERL_ARGS_ASSERT_SLAB_FREE; 337 338 if (!o->op_slabbed) { 339 if (!o->op_static) 340 PerlMemShared_free(op); 341 return; 342 } 343 344 slab = OpSLAB(o); 345 /* If this op is already freed, our refcount will get screwy. */ 346 assert(o->op_type != OP_FREED); 347 o->op_type = OP_FREED; 348 o->op_next = slab->opslab_freed; 349 slab->opslab_freed = o; 350 DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", o, slab)); 351 OpslabREFCNT_dec_padok(slab); 352 } 353 354 void 355 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab) 356 { 357 dVAR; 358 const bool havepad = !!PL_comppad; 359 PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD; 360 if (havepad) { 361 ENTER; 362 PAD_SAVE_SETNULLPAD(); 363 } 364 opslab_free(slab); 365 if (havepad) LEAVE; 366 } 367 368 void 369 Perl_opslab_free(pTHX_ OPSLAB *slab) 370 { 371 dVAR; 372 OPSLAB *slab2; 373 PERL_ARGS_ASSERT_OPSLAB_FREE; 374 DEBUG_S_warn((aTHX_ "freeing slab %p", slab)); 375 assert(slab->opslab_refcnt == 1); 376 for (; slab; slab = slab2) { 377 slab2 = slab->opslab_next; 378 #ifdef DEBUGGING 379 slab->opslab_refcnt = ~(size_t)0; 380 #endif 381 #ifdef PERL_DEBUG_READONLY_OPS 382 DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n", 383 slab)); 384 if (munmap(slab, slab->opslab_size * sizeof(I32 *))) { 385 perror("munmap failed"); 386 abort(); 387 } 388 #else 389 PerlMemShared_free(slab); 390 #endif 391 } 392 } 393 394 void 395 Perl_opslab_force_free(pTHX_ OPSLAB *slab) 396 { 397 OPSLAB *slab2; 398 OPSLOT *slot; 399 #ifdef DEBUGGING 400 size_t savestack_count = 0; 401 #endif 402 PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE; 403 slab2 = slab; 404 do { 405 for (slot = slab2->opslab_first; 406 slot->opslot_next; 407 slot = slot->opslot_next) { 408 if (slot->opslot_op.op_type != OP_FREED 409 && !(slot->opslot_op.op_savefree 410 #ifdef DEBUGGING 411 && ++savestack_count 412 #endif 413 ) 414 ) { 415 assert(slot->opslot_op.op_slabbed); 416 op_free(&slot->opslot_op); 417 if (slab->opslab_refcnt == 1) goto free; 418 } 419 } 420 } while ((slab2 = slab2->opslab_next)); 421 /* > 1 because the CV still holds a reference count. */ 422 if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */ 423 #ifdef DEBUGGING 424 assert(savestack_count == slab->opslab_refcnt-1); 425 #endif 426 /* Remove the CV’s reference count. */ 427 slab->opslab_refcnt--; 428 return; 429 } 430 free: 431 opslab_free(slab); 432 } 433 434 #ifdef PERL_DEBUG_READONLY_OPS 435 OP * 436 Perl_op_refcnt_inc(pTHX_ OP *o) 437 { 438 if(o) { 439 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL; 440 if (slab && slab->opslab_readonly) { 441 Slab_to_rw(slab); 442 ++o->op_targ; 443 Slab_to_ro(slab); 444 } else { 445 ++o->op_targ; 446 } 447 } 448 return o; 449 450 } 451 452 PADOFFSET 453 Perl_op_refcnt_dec(pTHX_ OP *o) 454 { 455 PADOFFSET result; 456 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL; 457 458 PERL_ARGS_ASSERT_OP_REFCNT_DEC; 459 460 if (slab && slab->opslab_readonly) { 461 Slab_to_rw(slab); 462 result = --o->op_targ; 463 Slab_to_ro(slab); 464 } else { 465 result = --o->op_targ; 466 } 467 return result; 468 } 469 #endif 470 /* 471 * In the following definition, the ", (OP*)0" is just to make the compiler 472 * think the expression is of the right type: croak actually does a Siglongjmp. 473 */ 474 #define CHECKOP(type,o) \ 475 ((PL_op_mask && PL_op_mask[type]) \ 476 ? ( op_free((OP*)o), \ 477 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \ 478 (OP*)0 ) \ 479 : PL_check[type](aTHX_ (OP*)o)) 480 481 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2) 482 483 #define CHANGE_TYPE(o,type) \ 484 STMT_START { \ 485 o->op_type = (OPCODE)type; \ 486 o->op_ppaddr = PL_ppaddr[type]; \ 487 } STMT_END 488 489 STATIC SV* 490 S_gv_ename(pTHX_ GV *gv) 491 { 492 SV* const tmpsv = sv_newmortal(); 493 494 PERL_ARGS_ASSERT_GV_ENAME; 495 496 gv_efullname3(tmpsv, gv, NULL); 497 return tmpsv; 498 } 499 500 STATIC OP * 501 S_no_fh_allowed(pTHX_ OP *o) 502 { 503 PERL_ARGS_ASSERT_NO_FH_ALLOWED; 504 505 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function", 506 OP_DESC(o))); 507 return o; 508 } 509 510 STATIC OP * 511 S_too_few_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags) 512 { 513 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_SV; 514 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, namesv), 515 SvUTF8(namesv) | flags); 516 return o; 517 } 518 519 STATIC OP * 520 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags) 521 { 522 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV; 523 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags); 524 return o; 525 } 526 527 STATIC OP * 528 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags) 529 { 530 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV; 531 532 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags); 533 return o; 534 } 535 536 STATIC OP * 537 S_too_many_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags) 538 { 539 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_SV; 540 541 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, SVfARG(namesv)), 542 SvUTF8(namesv) | flags); 543 return o; 544 } 545 546 STATIC void 547 S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid) 548 { 549 PERL_ARGS_ASSERT_BAD_TYPE_PV; 550 551 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)", 552 (int)n, name, t, OP_DESC(kid)), flags); 553 } 554 555 STATIC void 556 S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid) 557 { 558 SV * const namesv = gv_ename(gv); 559 PERL_ARGS_ASSERT_BAD_TYPE_GV; 560 561 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)", 562 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags); 563 } 564 565 STATIC void 566 S_no_bareword_allowed(pTHX_ OP *o) 567 { 568 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED; 569 570 if (PL_madskills) 571 return; /* various ok barewords are hidden in extra OP_NULL */ 572 qerror(Perl_mess(aTHX_ 573 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use", 574 SVfARG(cSVOPo_sv))); 575 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */ 576 } 577 578 /* "register" allocation */ 579 580 PADOFFSET 581 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags) 582 { 583 dVAR; 584 PADOFFSET off; 585 const bool is_our = (PL_parser->in_my == KEY_our); 586 587 PERL_ARGS_ASSERT_ALLOCMY; 588 589 if (flags & ~SVf_UTF8) 590 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf, 591 (UV)flags); 592 593 /* Until we're using the length for real, cross check that we're being 594 told the truth. */ 595 assert(strlen(name) == len); 596 597 /* complain about "my $<special_var>" etc etc */ 598 if (len && 599 !(is_our || 600 isALPHA(name[1]) || 601 ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) || 602 (name[1] == '_' && (*name == '$' || len > 2)))) 603 { 604 /* name[2] is true if strlen(name) > 2 */ 605 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1])) 606 && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) { 607 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"", 608 name[0], toCTRL(name[1]), (int)(len - 2), name + 2, 609 PL_parser->in_my == KEY_state ? "state" : "my")); 610 } else { 611 yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name, 612 PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8); 613 } 614 } 615 else if (len == 2 && name[1] == '_' && !is_our) 616 /* diag_listed_as: Use of my $_ is experimental */ 617 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__LEXICAL_TOPIC), 618 "Use of %s $_ is experimental", 619 PL_parser->in_my == KEY_state 620 ? "state" 621 : "my"); 622 623 /* allocate a spare slot and store the name in that slot */ 624 625 off = pad_add_name_pvn(name, len, 626 (is_our ? padadd_OUR : 627 PL_parser->in_my == KEY_state ? padadd_STATE : 0) 628 | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ), 629 PL_parser->in_my_stash, 630 (is_our 631 /* $_ is always in main::, even with our */ 632 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash) 633 : NULL 634 ) 635 ); 636 /* anon sub prototypes contains state vars should always be cloned, 637 * otherwise the state var would be shared between anon subs */ 638 639 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv)) 640 CvCLONE_on(PL_compcv); 641 642 return off; 643 } 644 645 /* 646 =for apidoc alloccopstash 647 648 Available only under threaded builds, this function allocates an entry in 649 C<PL_stashpad> for the stash passed to it. 650 651 =cut 652 */ 653 654 #ifdef USE_ITHREADS 655 PADOFFSET 656 Perl_alloccopstash(pTHX_ HV *hv) 657 { 658 PADOFFSET off = 0, o = 1; 659 bool found_slot = FALSE; 660 661 PERL_ARGS_ASSERT_ALLOCCOPSTASH; 662 663 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix; 664 665 for (; o < PL_stashpadmax; ++o) { 666 if (PL_stashpad[o] == hv) return PL_stashpadix = o; 667 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV) 668 found_slot = TRUE, off = o; 669 } 670 if (!found_slot) { 671 Renew(PL_stashpad, PL_stashpadmax + 10, HV *); 672 Zero(PL_stashpad + PL_stashpadmax, 10, HV *); 673 off = PL_stashpadmax; 674 PL_stashpadmax += 10; 675 } 676 677 PL_stashpad[PL_stashpadix = off] = hv; 678 return off; 679 } 680 #endif 681 682 /* free the body of an op without examining its contents. 683 * Always use this rather than FreeOp directly */ 684 685 static void 686 S_op_destroy(pTHX_ OP *o) 687 { 688 FreeOp(o); 689 } 690 691 /* Destructor */ 692 693 /* 694 =for apidoc Am|void|op_free|OP *o 695 696 Free an op. Only use this when an op is no longer linked to from any 697 optree. 698 699 =cut 700 */ 701 702 void 703 Perl_op_free(pTHX_ OP *o) 704 { 705 dVAR; 706 OPCODE type; 707 708 /* Though ops may be freed twice, freeing the op after its slab is a 709 big no-no. */ 710 assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0); 711 /* During the forced freeing of ops after compilation failure, kidops 712 may be freed before their parents. */ 713 if (!o || o->op_type == OP_FREED) 714 return; 715 716 type = o->op_type; 717 if (o->op_private & OPpREFCOUNTED) { 718 switch (type) { 719 case OP_LEAVESUB: 720 case OP_LEAVESUBLV: 721 case OP_LEAVEEVAL: 722 case OP_LEAVE: 723 case OP_SCOPE: 724 case OP_LEAVEWRITE: 725 { 726 PADOFFSET refcnt; 727 OP_REFCNT_LOCK; 728 refcnt = OpREFCNT_dec(o); 729 OP_REFCNT_UNLOCK; 730 if (refcnt) { 731 /* Need to find and remove any pattern match ops from the list 732 we maintain for reset(). */ 733 find_and_forget_pmops(o); 734 return; 735 } 736 } 737 break; 738 default: 739 break; 740 } 741 } 742 743 /* Call the op_free hook if it has been set. Do it now so that it's called 744 * at the right time for refcounted ops, but still before all of the kids 745 * are freed. */ 746 CALL_OPFREEHOOK(o); 747 748 if (o->op_flags & OPf_KIDS) { 749 OP *kid, *nextkid; 750 for (kid = cUNOPo->op_first; kid; kid = nextkid) { 751 nextkid = kid->op_sibling; /* Get before next freeing kid */ 752 op_free(kid); 753 } 754 } 755 if (type == OP_NULL) 756 type = (OPCODE)o->op_targ; 757 758 if (o->op_slabbed) 759 Slab_to_rw(OpSLAB(o)); 760 761 /* COP* is not cleared by op_clear() so that we may track line 762 * numbers etc even after null() */ 763 if (type == OP_NEXTSTATE || type == OP_DBSTATE) { 764 cop_free((COP*)o); 765 } 766 767 op_clear(o); 768 FreeOp(o); 769 #ifdef DEBUG_LEAKING_SCALARS 770 if (PL_op == o) 771 PL_op = NULL; 772 #endif 773 } 774 775 void 776 Perl_op_clear(pTHX_ OP *o) 777 { 778 779 dVAR; 780 781 PERL_ARGS_ASSERT_OP_CLEAR; 782 783 #ifdef PERL_MAD 784 mad_free(o->op_madprop); 785 o->op_madprop = 0; 786 #endif 787 788 retry: 789 switch (o->op_type) { 790 case OP_NULL: /* Was holding old type, if any. */ 791 if (PL_madskills && o->op_targ != OP_NULL) { 792 o->op_type = (Optype)o->op_targ; 793 o->op_targ = 0; 794 goto retry; 795 } 796 case OP_ENTERTRY: 797 case OP_ENTEREVAL: /* Was holding hints. */ 798 o->op_targ = 0; 799 break; 800 default: 801 if (!(o->op_flags & OPf_REF) 802 || (PL_check[o->op_type] != Perl_ck_ftst)) 803 break; 804 /* FALL THROUGH */ 805 case OP_GVSV: 806 case OP_GV: 807 case OP_AELEMFAST: 808 { 809 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV) 810 #ifdef USE_ITHREADS 811 && PL_curpad 812 #endif 813 ? cGVOPo_gv : NULL; 814 /* It's possible during global destruction that the GV is freed 815 before the optree. Whilst the SvREFCNT_inc is happy to bump from 816 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0 817 will trigger an assertion failure, because the entry to sv_clear 818 checks that the scalar is not already freed. A check of for 819 !SvIS_FREED(gv) turns out to be invalid, because during global 820 destruction the reference count can be forced down to zero 821 (with SVf_BREAK set). In which case raising to 1 and then 822 dropping to 0 triggers cleanup before it should happen. I 823 *think* that this might actually be a general, systematic, 824 weakness of the whole idea of SVf_BREAK, in that code *is* 825 allowed to raise and lower references during global destruction, 826 so any *valid* code that happens to do this during global 827 destruction might well trigger premature cleanup. */ 828 bool still_valid = gv && SvREFCNT(gv); 829 830 if (still_valid) 831 SvREFCNT_inc_simple_void(gv); 832 #ifdef USE_ITHREADS 833 if (cPADOPo->op_padix > 0) { 834 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references 835 * may still exist on the pad */ 836 pad_swipe(cPADOPo->op_padix, TRUE); 837 cPADOPo->op_padix = 0; 838 } 839 #else 840 SvREFCNT_dec(cSVOPo->op_sv); 841 cSVOPo->op_sv = NULL; 842 #endif 843 if (still_valid) { 844 int try_downgrade = SvREFCNT(gv) == 2; 845 SvREFCNT_dec_NN(gv); 846 if (try_downgrade) 847 gv_try_downgrade(gv); 848 } 849 } 850 break; 851 case OP_METHOD_NAMED: 852 case OP_CONST: 853 case OP_HINTSEVAL: 854 SvREFCNT_dec(cSVOPo->op_sv); 855 cSVOPo->op_sv = NULL; 856 #ifdef USE_ITHREADS 857 /** Bug #15654 858 Even if op_clear does a pad_free for the target of the op, 859 pad_free doesn't actually remove the sv that exists in the pad; 860 instead it lives on. This results in that it could be reused as 861 a target later on when the pad was reallocated. 862 **/ 863 if(o->op_targ) { 864 pad_swipe(o->op_targ,1); 865 o->op_targ = 0; 866 } 867 #endif 868 break; 869 case OP_DUMP: 870 case OP_GOTO: 871 case OP_NEXT: 872 case OP_LAST: 873 case OP_REDO: 874 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS)) 875 break; 876 /* FALL THROUGH */ 877 case OP_TRANS: 878 case OP_TRANSR: 879 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) { 880 assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR); 881 #ifdef USE_ITHREADS 882 if (cPADOPo->op_padix > 0) { 883 pad_swipe(cPADOPo->op_padix, TRUE); 884 cPADOPo->op_padix = 0; 885 } 886 #else 887 SvREFCNT_dec(cSVOPo->op_sv); 888 cSVOPo->op_sv = NULL; 889 #endif 890 } 891 else { 892 PerlMemShared_free(cPVOPo->op_pv); 893 cPVOPo->op_pv = NULL; 894 } 895 break; 896 case OP_SUBST: 897 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot); 898 goto clear_pmop; 899 case OP_PUSHRE: 900 #ifdef USE_ITHREADS 901 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) { 902 /* No GvIN_PAD_off here, because other references may still 903 * exist on the pad */ 904 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE); 905 } 906 #else 907 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv)); 908 #endif 909 /* FALL THROUGH */ 910 case OP_MATCH: 911 case OP_QR: 912 clear_pmop: 913 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE)) 914 op_free(cPMOPo->op_code_list); 915 cPMOPo->op_code_list = NULL; 916 forget_pmop(cPMOPo); 917 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL; 918 /* we use the same protection as the "SAFE" version of the PM_ macros 919 * here since sv_clean_all might release some PMOPs 920 * after PL_regex_padav has been cleared 921 * and the clearing of PL_regex_padav needs to 922 * happen before sv_clean_all 923 */ 924 #ifdef USE_ITHREADS 925 if(PL_regex_pad) { /* We could be in destruction */ 926 const IV offset = (cPMOPo)->op_pmoffset; 927 ReREFCNT_dec(PM_GETRE(cPMOPo)); 928 PL_regex_pad[offset] = &PL_sv_undef; 929 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset, 930 sizeof(offset)); 931 } 932 #else 933 ReREFCNT_dec(PM_GETRE(cPMOPo)); 934 PM_SETRE(cPMOPo, NULL); 935 #endif 936 937 break; 938 } 939 940 if (o->op_targ > 0) { 941 pad_free(o->op_targ); 942 o->op_targ = 0; 943 } 944 } 945 946 STATIC void 947 S_cop_free(pTHX_ COP* cop) 948 { 949 PERL_ARGS_ASSERT_COP_FREE; 950 951 CopFILE_free(cop); 952 if (! specialWARN(cop->cop_warnings)) 953 PerlMemShared_free(cop->cop_warnings); 954 cophh_free(CopHINTHASH_get(cop)); 955 if (PL_curcop == cop) 956 PL_curcop = NULL; 957 } 958 959 STATIC void 960 S_forget_pmop(pTHX_ PMOP *const o 961 ) 962 { 963 HV * const pmstash = PmopSTASH(o); 964 965 PERL_ARGS_ASSERT_FORGET_PMOP; 966 967 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) { 968 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab); 969 if (mg) { 970 PMOP **const array = (PMOP**) mg->mg_ptr; 971 U32 count = mg->mg_len / sizeof(PMOP**); 972 U32 i = count; 973 974 while (i--) { 975 if (array[i] == o) { 976 /* Found it. Move the entry at the end to overwrite it. */ 977 array[i] = array[--count]; 978 mg->mg_len = count * sizeof(PMOP**); 979 /* Could realloc smaller at this point always, but probably 980 not worth it. Probably worth free()ing if we're the 981 last. */ 982 if(!count) { 983 Safefree(mg->mg_ptr); 984 mg->mg_ptr = NULL; 985 } 986 break; 987 } 988 } 989 } 990 } 991 if (PL_curpm == o) 992 PL_curpm = NULL; 993 } 994 995 STATIC void 996 S_find_and_forget_pmops(pTHX_ OP *o) 997 { 998 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS; 999 1000 if (o->op_flags & OPf_KIDS) { 1001 OP *kid = cUNOPo->op_first; 1002 while (kid) { 1003 switch (kid->op_type) { 1004 case OP_SUBST: 1005 case OP_PUSHRE: 1006 case OP_MATCH: 1007 case OP_QR: 1008 forget_pmop((PMOP*)kid); 1009 } 1010 find_and_forget_pmops(kid); 1011 kid = kid->op_sibling; 1012 } 1013 } 1014 } 1015 1016 /* 1017 =for apidoc Am|void|op_null|OP *o 1018 1019 Neutralizes an op when it is no longer needed, but is still linked to from 1020 other ops. 1021 1022 =cut 1023 */ 1024 1025 void 1026 Perl_op_null(pTHX_ OP *o) 1027 { 1028 dVAR; 1029 1030 PERL_ARGS_ASSERT_OP_NULL; 1031 1032 if (o->op_type == OP_NULL) 1033 return; 1034 if (!PL_madskills) 1035 op_clear(o); 1036 o->op_targ = o->op_type; 1037 o->op_type = OP_NULL; 1038 o->op_ppaddr = PL_ppaddr[OP_NULL]; 1039 } 1040 1041 void 1042 Perl_op_refcnt_lock(pTHX) 1043 { 1044 dVAR; 1045 PERL_UNUSED_CONTEXT; 1046 OP_REFCNT_LOCK; 1047 } 1048 1049 void 1050 Perl_op_refcnt_unlock(pTHX) 1051 { 1052 dVAR; 1053 PERL_UNUSED_CONTEXT; 1054 OP_REFCNT_UNLOCK; 1055 } 1056 1057 /* Contextualizers */ 1058 1059 /* 1060 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context 1061 1062 Applies a syntactic context to an op tree representing an expression. 1063 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>, 1064 or C<G_VOID> to specify the context to apply. The modified op tree 1065 is returned. 1066 1067 =cut 1068 */ 1069 1070 OP * 1071 Perl_op_contextualize(pTHX_ OP *o, I32 context) 1072 { 1073 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE; 1074 switch (context) { 1075 case G_SCALAR: return scalar(o); 1076 case G_ARRAY: return list(o); 1077 case G_VOID: return scalarvoid(o); 1078 default: 1079 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld", 1080 (long) context); 1081 return o; 1082 } 1083 } 1084 1085 /* 1086 =head1 Optree Manipulation Functions 1087 1088 =for apidoc Am|OP*|op_linklist|OP *o 1089 This function is the implementation of the L</LINKLIST> macro. It should 1090 not be called directly. 1091 1092 =cut 1093 */ 1094 1095 OP * 1096 Perl_op_linklist(pTHX_ OP *o) 1097 { 1098 OP *first; 1099 1100 PERL_ARGS_ASSERT_OP_LINKLIST; 1101 1102 if (o->op_next) 1103 return o->op_next; 1104 1105 /* establish postfix order */ 1106 first = cUNOPo->op_first; 1107 if (first) { 1108 OP *kid; 1109 o->op_next = LINKLIST(first); 1110 kid = first; 1111 for (;;) { 1112 if (kid->op_sibling) { 1113 kid->op_next = LINKLIST(kid->op_sibling); 1114 kid = kid->op_sibling; 1115 } else { 1116 kid->op_next = o; 1117 break; 1118 } 1119 } 1120 } 1121 else 1122 o->op_next = o; 1123 1124 return o->op_next; 1125 } 1126 1127 static OP * 1128 S_scalarkids(pTHX_ OP *o) 1129 { 1130 if (o && o->op_flags & OPf_KIDS) { 1131 OP *kid; 1132 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 1133 scalar(kid); 1134 } 1135 return o; 1136 } 1137 1138 STATIC OP * 1139 S_scalarboolean(pTHX_ OP *o) 1140 { 1141 dVAR; 1142 1143 PERL_ARGS_ASSERT_SCALARBOOLEAN; 1144 1145 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST 1146 && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) { 1147 if (ckWARN(WARN_SYNTAX)) { 1148 const line_t oldline = CopLINE(PL_curcop); 1149 1150 if (PL_parser && PL_parser->copline != NOLINE) { 1151 /* This ensures that warnings are reported at the first line 1152 of the conditional, not the last. */ 1153 CopLINE_set(PL_curcop, PL_parser->copline); 1154 } 1155 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be =="); 1156 CopLINE_set(PL_curcop, oldline); 1157 } 1158 } 1159 return scalar(o); 1160 } 1161 1162 static SV * 1163 S_op_varname(pTHX_ const OP *o) 1164 { 1165 assert(o); 1166 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV || 1167 o->op_type == OP_PADHV || o->op_type == OP_RV2HV); 1168 { 1169 const char funny = o->op_type == OP_PADAV 1170 || o->op_type == OP_RV2AV ? '@' : '%'; 1171 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) { 1172 GV *gv; 1173 if (cUNOPo->op_first->op_type != OP_GV 1174 || !(gv = cGVOPx_gv(cUNOPo->op_first))) 1175 return NULL; 1176 return varname(gv, funny, 0, NULL, 0, 1); 1177 } 1178 return 1179 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, 1); 1180 } 1181 } 1182 1183 static void 1184 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv) 1185 { /* or not so pretty :-) */ 1186 if (o->op_type == OP_CONST) { 1187 *retsv = cSVOPo_sv; 1188 if (SvPOK(*retsv)) { 1189 SV *sv = *retsv; 1190 *retsv = sv_newmortal(); 1191 pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL, 1192 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT); 1193 } 1194 else if (!SvOK(*retsv)) 1195 *retpv = "undef"; 1196 } 1197 else *retpv = "..."; 1198 } 1199 1200 static void 1201 S_scalar_slice_warning(pTHX_ const OP *o) 1202 { 1203 OP *kid; 1204 const char lbrack = 1205 o->op_type == OP_HSLICE ? '{' : '['; 1206 const char rbrack = 1207 o->op_type == OP_HSLICE ? '}' : ']'; 1208 SV *name; 1209 SV *keysv = NULL; /* just to silence compiler warnings */ 1210 const char *key = NULL; 1211 1212 if (!(o->op_private & OPpSLICEWARNING)) 1213 return; 1214 if (PL_parser && PL_parser->error_count) 1215 /* This warning can be nonsensical when there is a syntax error. */ 1216 return; 1217 1218 kid = cLISTOPo->op_first; 1219 kid = kid->op_sibling; /* get past pushmark */ 1220 /* weed out false positives: any ops that can return lists */ 1221 switch (kid->op_type) { 1222 case OP_BACKTICK: 1223 case OP_GLOB: 1224 case OP_READLINE: 1225 case OP_MATCH: 1226 case OP_RV2AV: 1227 case OP_EACH: 1228 case OP_VALUES: 1229 case OP_KEYS: 1230 case OP_SPLIT: 1231 case OP_LIST: 1232 case OP_SORT: 1233 case OP_REVERSE: 1234 case OP_ENTERSUB: 1235 case OP_CALLER: 1236 case OP_LSTAT: 1237 case OP_STAT: 1238 case OP_READDIR: 1239 case OP_SYSTEM: 1240 case OP_TMS: 1241 case OP_LOCALTIME: 1242 case OP_GMTIME: 1243 case OP_ENTEREVAL: 1244 case OP_REACH: 1245 case OP_RKEYS: 1246 case OP_RVALUES: 1247 return; 1248 } 1249 1250 /* Don't warn if we have a nulled list either. */ 1251 if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST) 1252 return; 1253 1254 assert(kid->op_sibling); 1255 name = S_op_varname(aTHX_ kid->op_sibling); 1256 if (!name) /* XS module fiddling with the op tree */ 1257 return; 1258 S_op_pretty(aTHX_ kid, &keysv, &key); 1259 assert(SvPOK(name)); 1260 sv_chop(name,SvPVX(name)+1); 1261 if (key) 1262 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */ 1263 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 1264 "Scalar value @%"SVf"%c%s%c better written as $%"SVf 1265 "%c%s%c", 1266 SVfARG(name), lbrack, key, rbrack, SVfARG(name), 1267 lbrack, key, rbrack); 1268 else 1269 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */ 1270 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 1271 "Scalar value @%"SVf"%c%"SVf"%c better written as $%" 1272 SVf"%c%"SVf"%c", 1273 SVfARG(name), lbrack, keysv, rbrack, 1274 SVfARG(name), lbrack, keysv, rbrack); 1275 } 1276 1277 OP * 1278 Perl_scalar(pTHX_ OP *o) 1279 { 1280 dVAR; 1281 OP *kid; 1282 1283 /* assumes no premature commitment */ 1284 if (!o || (PL_parser && PL_parser->error_count) 1285 || (o->op_flags & OPf_WANT) 1286 || o->op_type == OP_RETURN) 1287 { 1288 return o; 1289 } 1290 1291 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR; 1292 1293 switch (o->op_type) { 1294 case OP_REPEAT: 1295 scalar(cBINOPo->op_first); 1296 break; 1297 case OP_OR: 1298 case OP_AND: 1299 case OP_COND_EXPR: 1300 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) 1301 scalar(kid); 1302 break; 1303 /* FALL THROUGH */ 1304 case OP_SPLIT: 1305 case OP_MATCH: 1306 case OP_QR: 1307 case OP_SUBST: 1308 case OP_NULL: 1309 default: 1310 if (o->op_flags & OPf_KIDS) { 1311 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) 1312 scalar(kid); 1313 } 1314 break; 1315 case OP_LEAVE: 1316 case OP_LEAVETRY: 1317 kid = cLISTOPo->op_first; 1318 scalar(kid); 1319 kid = kid->op_sibling; 1320 do_kids: 1321 while (kid) { 1322 OP *sib = kid->op_sibling; 1323 if (sib && kid->op_type != OP_LEAVEWHEN) 1324 scalarvoid(kid); 1325 else 1326 scalar(kid); 1327 kid = sib; 1328 } 1329 PL_curcop = &PL_compiling; 1330 break; 1331 case OP_SCOPE: 1332 case OP_LINESEQ: 1333 case OP_LIST: 1334 kid = cLISTOPo->op_first; 1335 goto do_kids; 1336 case OP_SORT: 1337 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context"); 1338 break; 1339 case OP_KVHSLICE: 1340 case OP_KVASLICE: 1341 { 1342 /* Warn about scalar context */ 1343 const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '['; 1344 const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']'; 1345 SV *name; 1346 SV *keysv; 1347 const char *key = NULL; 1348 1349 /* This warning can be nonsensical when there is a syntax error. */ 1350 if (PL_parser && PL_parser->error_count) 1351 break; 1352 1353 if (!ckWARN(WARN_SYNTAX)) break; 1354 1355 kid = cLISTOPo->op_first; 1356 kid = kid->op_sibling; /* get past pushmark */ 1357 assert(kid->op_sibling); 1358 name = S_op_varname(aTHX_ kid->op_sibling); 1359 if (!name) /* XS module fiddling with the op tree */ 1360 break; 1361 S_op_pretty(aTHX_ kid, &keysv, &key); 1362 assert(SvPOK(name)); 1363 sv_chop(name,SvPVX(name)+1); 1364 if (key) 1365 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */ 1366 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 1367 "%%%"SVf"%c%s%c in scalar context better written " 1368 "as $%"SVf"%c%s%c", 1369 SVfARG(name), lbrack, key, rbrack, SVfARG(name), 1370 lbrack, key, rbrack); 1371 else 1372 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */ 1373 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 1374 "%%%"SVf"%c%"SVf"%c in scalar context better " 1375 "written as $%"SVf"%c%"SVf"%c", 1376 SVfARG(name), lbrack, keysv, rbrack, 1377 SVfARG(name), lbrack, keysv, rbrack); 1378 } 1379 } 1380 return o; 1381 } 1382 1383 OP * 1384 Perl_scalarvoid(pTHX_ OP *o) 1385 { 1386 dVAR; 1387 OP *kid; 1388 SV *useless_sv = NULL; 1389 const char* useless = NULL; 1390 SV* sv; 1391 U8 want; 1392 1393 PERL_ARGS_ASSERT_SCALARVOID; 1394 1395 /* trailing mad null ops don't count as "there" for void processing */ 1396 if (PL_madskills && 1397 o->op_type != OP_NULL && 1398 o->op_sibling && 1399 o->op_sibling->op_type == OP_NULL) 1400 { 1401 OP *sib; 1402 for (sib = o->op_sibling; 1403 sib && sib->op_type == OP_NULL; 1404 sib = sib->op_sibling) ; 1405 1406 if (!sib) 1407 return o; 1408 } 1409 1410 if (o->op_type == OP_NEXTSTATE 1411 || o->op_type == OP_DBSTATE 1412 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE 1413 || o->op_targ == OP_DBSTATE))) 1414 PL_curcop = (COP*)o; /* for warning below */ 1415 1416 /* assumes no premature commitment */ 1417 want = o->op_flags & OPf_WANT; 1418 if ((want && want != OPf_WANT_SCALAR) 1419 || (PL_parser && PL_parser->error_count) 1420 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN) 1421 { 1422 return o; 1423 } 1424 1425 if ((o->op_private & OPpTARGET_MY) 1426 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */ 1427 { 1428 return scalar(o); /* As if inside SASSIGN */ 1429 } 1430 1431 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID; 1432 1433 switch (o->op_type) { 1434 default: 1435 if (!(PL_opargs[o->op_type] & OA_FOLDCONST)) 1436 break; 1437 /* FALL THROUGH */ 1438 case OP_REPEAT: 1439 if (o->op_flags & OPf_STACKED) 1440 break; 1441 goto func_ops; 1442 case OP_SUBSTR: 1443 if (o->op_private == 4) 1444 break; 1445 /* FALL THROUGH */ 1446 case OP_GVSV: 1447 case OP_WANTARRAY: 1448 case OP_GV: 1449 case OP_SMARTMATCH: 1450 case OP_PADSV: 1451 case OP_PADAV: 1452 case OP_PADHV: 1453 case OP_PADANY: 1454 case OP_AV2ARYLEN: 1455 case OP_REF: 1456 case OP_REFGEN: 1457 case OP_SREFGEN: 1458 case OP_DEFINED: 1459 case OP_HEX: 1460 case OP_OCT: 1461 case OP_LENGTH: 1462 case OP_VEC: 1463 case OP_INDEX: 1464 case OP_RINDEX: 1465 case OP_SPRINTF: 1466 case OP_AELEM: 1467 case OP_AELEMFAST: 1468 case OP_AELEMFAST_LEX: 1469 case OP_ASLICE: 1470 case OP_KVASLICE: 1471 case OP_HELEM: 1472 case OP_HSLICE: 1473 case OP_KVHSLICE: 1474 case OP_UNPACK: 1475 case OP_PACK: 1476 case OP_JOIN: 1477 case OP_LSLICE: 1478 case OP_ANONLIST: 1479 case OP_ANONHASH: 1480 case OP_SORT: 1481 case OP_REVERSE: 1482 case OP_RANGE: 1483 case OP_FLIP: 1484 case OP_FLOP: 1485 case OP_CALLER: 1486 case OP_FILENO: 1487 case OP_EOF: 1488 case OP_TELL: 1489 case OP_GETSOCKNAME: 1490 case OP_GETPEERNAME: 1491 case OP_READLINK: 1492 case OP_TELLDIR: 1493 case OP_GETPPID: 1494 case OP_GETPGRP: 1495 case OP_GETPRIORITY: 1496 case OP_TIME: 1497 case OP_TMS: 1498 case OP_LOCALTIME: 1499 case OP_GMTIME: 1500 case OP_GHBYNAME: 1501 case OP_GHBYADDR: 1502 case OP_GHOSTENT: 1503 case OP_GNBYNAME: 1504 case OP_GNBYADDR: 1505 case OP_GNETENT: 1506 case OP_GPBYNAME: 1507 case OP_GPBYNUMBER: 1508 case OP_GPROTOENT: 1509 case OP_GSBYNAME: 1510 case OP_GSBYPORT: 1511 case OP_GSERVENT: 1512 case OP_GPWNAM: 1513 case OP_GPWUID: 1514 case OP_GGRNAM: 1515 case OP_GGRGID: 1516 case OP_GETLOGIN: 1517 case OP_PROTOTYPE: 1518 case OP_RUNCV: 1519 func_ops: 1520 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO))) 1521 /* Otherwise it's "Useless use of grep iterator" */ 1522 useless = OP_DESC(o); 1523 break; 1524 1525 case OP_SPLIT: 1526 kid = cLISTOPo->op_first; 1527 if (kid && kid->op_type == OP_PUSHRE 1528 #ifdef USE_ITHREADS 1529 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff) 1530 #else 1531 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv) 1532 #endif 1533 useless = OP_DESC(o); 1534 break; 1535 1536 case OP_NOT: 1537 kid = cUNOPo->op_first; 1538 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST && 1539 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) { 1540 goto func_ops; 1541 } 1542 useless = "negative pattern binding (!~)"; 1543 break; 1544 1545 case OP_SUBST: 1546 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT) 1547 useless = "non-destructive substitution (s///r)"; 1548 break; 1549 1550 case OP_TRANSR: 1551 useless = "non-destructive transliteration (tr///r)"; 1552 break; 1553 1554 case OP_RV2GV: 1555 case OP_RV2SV: 1556 case OP_RV2AV: 1557 case OP_RV2HV: 1558 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) && 1559 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE)) 1560 useless = "a variable"; 1561 break; 1562 1563 case OP_CONST: 1564 sv = cSVOPo_sv; 1565 if (cSVOPo->op_private & OPpCONST_STRICT) 1566 no_bareword_allowed(o); 1567 else { 1568 if (ckWARN(WARN_VOID)) { 1569 /* don't warn on optimised away booleans, eg 1570 * use constant Foo, 5; Foo || print; */ 1571 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT) 1572 useless = NULL; 1573 /* the constants 0 and 1 are permitted as they are 1574 conventionally used as dummies in constructs like 1575 1 while some_condition_with_side_effects; */ 1576 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0)) 1577 useless = NULL; 1578 else if (SvPOK(sv)) { 1579 SV * const dsv = newSVpvs(""); 1580 useless_sv 1581 = Perl_newSVpvf(aTHX_ 1582 "a constant (%s)", 1583 pv_pretty(dsv, SvPVX_const(sv), 1584 SvCUR(sv), 32, NULL, NULL, 1585 PERL_PV_PRETTY_DUMP 1586 | PERL_PV_ESCAPE_NOCLEAR 1587 | PERL_PV_ESCAPE_UNI_DETECT)); 1588 SvREFCNT_dec_NN(dsv); 1589 } 1590 else if (SvOK(sv)) { 1591 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", sv); 1592 } 1593 else 1594 useless = "a constant (undef)"; 1595 } 1596 } 1597 op_null(o); /* don't execute or even remember it */ 1598 break; 1599 1600 case OP_POSTINC: 1601 o->op_type = OP_PREINC; /* pre-increment is faster */ 1602 o->op_ppaddr = PL_ppaddr[OP_PREINC]; 1603 break; 1604 1605 case OP_POSTDEC: 1606 o->op_type = OP_PREDEC; /* pre-decrement is faster */ 1607 o->op_ppaddr = PL_ppaddr[OP_PREDEC]; 1608 break; 1609 1610 case OP_I_POSTINC: 1611 o->op_type = OP_I_PREINC; /* pre-increment is faster */ 1612 o->op_ppaddr = PL_ppaddr[OP_I_PREINC]; 1613 break; 1614 1615 case OP_I_POSTDEC: 1616 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */ 1617 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC]; 1618 break; 1619 1620 case OP_SASSIGN: { 1621 OP *rv2gv; 1622 UNOP *refgen, *rv2cv; 1623 LISTOP *exlist; 1624 1625 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2) 1626 break; 1627 1628 rv2gv = ((BINOP *)o)->op_last; 1629 if (!rv2gv || rv2gv->op_type != OP_RV2GV) 1630 break; 1631 1632 refgen = (UNOP *)((BINOP *)o)->op_first; 1633 1634 if (!refgen || refgen->op_type != OP_REFGEN) 1635 break; 1636 1637 exlist = (LISTOP *)refgen->op_first; 1638 if (!exlist || exlist->op_type != OP_NULL 1639 || exlist->op_targ != OP_LIST) 1640 break; 1641 1642 if (exlist->op_first->op_type != OP_PUSHMARK) 1643 break; 1644 1645 rv2cv = (UNOP*)exlist->op_last; 1646 1647 if (rv2cv->op_type != OP_RV2CV) 1648 break; 1649 1650 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0); 1651 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0); 1652 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0); 1653 1654 o->op_private |= OPpASSIGN_CV_TO_GV; 1655 rv2gv->op_private |= OPpDONT_INIT_GV; 1656 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT; 1657 1658 break; 1659 } 1660 1661 case OP_AASSIGN: { 1662 inplace_aassign(o); 1663 break; 1664 } 1665 1666 case OP_OR: 1667 case OP_AND: 1668 kid = cLOGOPo->op_first; 1669 if (kid->op_type == OP_NOT 1670 && (kid->op_flags & OPf_KIDS) 1671 && !PL_madskills) { 1672 if (o->op_type == OP_AND) { 1673 o->op_type = OP_OR; 1674 o->op_ppaddr = PL_ppaddr[OP_OR]; 1675 } else { 1676 o->op_type = OP_AND; 1677 o->op_ppaddr = PL_ppaddr[OP_AND]; 1678 } 1679 op_null(kid); 1680 } 1681 1682 case OP_DOR: 1683 case OP_COND_EXPR: 1684 case OP_ENTERGIVEN: 1685 case OP_ENTERWHEN: 1686 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) 1687 scalarvoid(kid); 1688 break; 1689 1690 case OP_NULL: 1691 if (o->op_flags & OPf_STACKED) 1692 break; 1693 /* FALL THROUGH */ 1694 case OP_NEXTSTATE: 1695 case OP_DBSTATE: 1696 case OP_ENTERTRY: 1697 case OP_ENTER: 1698 if (!(o->op_flags & OPf_KIDS)) 1699 break; 1700 /* FALL THROUGH */ 1701 case OP_SCOPE: 1702 case OP_LEAVE: 1703 case OP_LEAVETRY: 1704 case OP_LEAVELOOP: 1705 case OP_LINESEQ: 1706 case OP_LIST: 1707 case OP_LEAVEGIVEN: 1708 case OP_LEAVEWHEN: 1709 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 1710 scalarvoid(kid); 1711 break; 1712 case OP_ENTEREVAL: 1713 scalarkids(o); 1714 break; 1715 case OP_SCALAR: 1716 return scalar(o); 1717 } 1718 1719 if (useless_sv) { 1720 /* mortalise it, in case warnings are fatal. */ 1721 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), 1722 "Useless use of %"SVf" in void context", 1723 sv_2mortal(useless_sv)); 1724 } 1725 else if (useless) { 1726 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), 1727 "Useless use of %s in void context", 1728 useless); 1729 } 1730 return o; 1731 } 1732 1733 static OP * 1734 S_listkids(pTHX_ OP *o) 1735 { 1736 if (o && o->op_flags & OPf_KIDS) { 1737 OP *kid; 1738 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 1739 list(kid); 1740 } 1741 return o; 1742 } 1743 1744 OP * 1745 Perl_list(pTHX_ OP *o) 1746 { 1747 dVAR; 1748 OP *kid; 1749 1750 /* assumes no premature commitment */ 1751 if (!o || (o->op_flags & OPf_WANT) 1752 || (PL_parser && PL_parser->error_count) 1753 || o->op_type == OP_RETURN) 1754 { 1755 return o; 1756 } 1757 1758 if ((o->op_private & OPpTARGET_MY) 1759 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */ 1760 { 1761 return o; /* As if inside SASSIGN */ 1762 } 1763 1764 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST; 1765 1766 switch (o->op_type) { 1767 case OP_FLOP: 1768 case OP_REPEAT: 1769 list(cBINOPo->op_first); 1770 break; 1771 case OP_OR: 1772 case OP_AND: 1773 case OP_COND_EXPR: 1774 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) 1775 list(kid); 1776 break; 1777 default: 1778 case OP_MATCH: 1779 case OP_QR: 1780 case OP_SUBST: 1781 case OP_NULL: 1782 if (!(o->op_flags & OPf_KIDS)) 1783 break; 1784 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) { 1785 list(cBINOPo->op_first); 1786 return gen_constant_list(o); 1787 } 1788 case OP_LIST: 1789 listkids(o); 1790 break; 1791 case OP_LEAVE: 1792 case OP_LEAVETRY: 1793 kid = cLISTOPo->op_first; 1794 list(kid); 1795 kid = kid->op_sibling; 1796 do_kids: 1797 while (kid) { 1798 OP *sib = kid->op_sibling; 1799 if (sib && kid->op_type != OP_LEAVEWHEN) 1800 scalarvoid(kid); 1801 else 1802 list(kid); 1803 kid = sib; 1804 } 1805 PL_curcop = &PL_compiling; 1806 break; 1807 case OP_SCOPE: 1808 case OP_LINESEQ: 1809 kid = cLISTOPo->op_first; 1810 goto do_kids; 1811 } 1812 return o; 1813 } 1814 1815 static OP * 1816 S_scalarseq(pTHX_ OP *o) 1817 { 1818 dVAR; 1819 if (o) { 1820 const OPCODE type = o->op_type; 1821 1822 if (type == OP_LINESEQ || type == OP_SCOPE || 1823 type == OP_LEAVE || type == OP_LEAVETRY) 1824 { 1825 OP *kid; 1826 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { 1827 if (kid->op_sibling) { 1828 scalarvoid(kid); 1829 } 1830 } 1831 PL_curcop = &PL_compiling; 1832 } 1833 o->op_flags &= ~OPf_PARENS; 1834 if (PL_hints & HINT_BLOCK_SCOPE) 1835 o->op_flags |= OPf_PARENS; 1836 } 1837 else 1838 o = newOP(OP_STUB, 0); 1839 return o; 1840 } 1841 1842 STATIC OP * 1843 S_modkids(pTHX_ OP *o, I32 type) 1844 { 1845 if (o && o->op_flags & OPf_KIDS) { 1846 OP *kid; 1847 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 1848 op_lvalue(kid, type); 1849 } 1850 return o; 1851 } 1852 1853 /* 1854 =for apidoc finalize_optree 1855 1856 This function finalizes the optree. Should be called directly after 1857 the complete optree is built. It does some additional 1858 checking which can't be done in the normal ck_xxx functions and makes 1859 the tree thread-safe. 1860 1861 =cut 1862 */ 1863 void 1864 Perl_finalize_optree(pTHX_ OP* o) 1865 { 1866 PERL_ARGS_ASSERT_FINALIZE_OPTREE; 1867 1868 ENTER; 1869 SAVEVPTR(PL_curcop); 1870 1871 finalize_op(o); 1872 1873 LEAVE; 1874 } 1875 1876 STATIC void 1877 S_finalize_op(pTHX_ OP* o) 1878 { 1879 PERL_ARGS_ASSERT_FINALIZE_OP; 1880 1881 #if defined(PERL_MAD) && defined(USE_ITHREADS) 1882 { 1883 /* Make sure mad ops are also thread-safe */ 1884 MADPROP *mp = o->op_madprop; 1885 while (mp) { 1886 if (mp->mad_type == MAD_OP && mp->mad_vlen) { 1887 OP *prop_op = (OP *) mp->mad_val; 1888 /* We only need "Relocate sv to the pad for thread safety.", but this 1889 easiest way to make sure it traverses everything */ 1890 if (prop_op->op_type == OP_CONST) 1891 cSVOPx(prop_op)->op_private &= ~OPpCONST_STRICT; 1892 finalize_op(prop_op); 1893 } 1894 mp = mp->mad_next; 1895 } 1896 } 1897 #endif 1898 1899 switch (o->op_type) { 1900 case OP_NEXTSTATE: 1901 case OP_DBSTATE: 1902 PL_curcop = ((COP*)o); /* for warnings */ 1903 break; 1904 case OP_EXEC: 1905 if ( o->op_sibling 1906 && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE) 1907 && ckWARN(WARN_EXEC)) 1908 { 1909 if (o->op_sibling->op_sibling) { 1910 const OPCODE type = o->op_sibling->op_sibling->op_type; 1911 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) { 1912 const line_t oldline = CopLINE(PL_curcop); 1913 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_sibling)); 1914 Perl_warner(aTHX_ packWARN(WARN_EXEC), 1915 "Statement unlikely to be reached"); 1916 Perl_warner(aTHX_ packWARN(WARN_EXEC), 1917 "\t(Maybe you meant system() when you said exec()?)\n"); 1918 CopLINE_set(PL_curcop, oldline); 1919 } 1920 } 1921 } 1922 break; 1923 1924 case OP_GV: 1925 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) { 1926 GV * const gv = cGVOPo_gv; 1927 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) { 1928 /* XXX could check prototype here instead of just carping */ 1929 SV * const sv = sv_newmortal(); 1930 gv_efullname3(sv, gv, NULL); 1931 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), 1932 "%"SVf"() called too early to check prototype", 1933 SVfARG(sv)); 1934 } 1935 } 1936 break; 1937 1938 case OP_CONST: 1939 if (cSVOPo->op_private & OPpCONST_STRICT) 1940 no_bareword_allowed(o); 1941 /* FALLTHROUGH */ 1942 #ifdef USE_ITHREADS 1943 case OP_HINTSEVAL: 1944 case OP_METHOD_NAMED: 1945 /* Relocate sv to the pad for thread safety. 1946 * Despite being a "constant", the SV is written to, 1947 * for reference counts, sv_upgrade() etc. */ 1948 if (cSVOPo->op_sv) { 1949 const PADOFFSET ix = pad_alloc(OP_CONST, SVf_READONLY); 1950 SvREFCNT_dec(PAD_SVl(ix)); 1951 PAD_SETSV(ix, cSVOPo->op_sv); 1952 /* XXX I don't know how this isn't readonly already. */ 1953 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix)); 1954 cSVOPo->op_sv = NULL; 1955 o->op_targ = ix; 1956 } 1957 #endif 1958 break; 1959 1960 case OP_HELEM: { 1961 UNOP *rop; 1962 SV *lexname; 1963 GV **fields; 1964 SVOP *key_op; 1965 OP *kid; 1966 bool check_fields; 1967 1968 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST) 1969 break; 1970 1971 rop = (UNOP*)((BINOP*)o)->op_first; 1972 1973 goto check_keys; 1974 1975 case OP_HSLICE: 1976 S_scalar_slice_warning(aTHX_ o); 1977 1978 case OP_KVHSLICE: 1979 kid = cLISTOPo->op_first->op_sibling; 1980 if (/* I bet there's always a pushmark... */ 1981 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST) 1982 && OP_TYPE_ISNT_NN(kid, OP_CONST)) 1983 { 1984 break; 1985 } 1986 1987 key_op = (SVOP*)(kid->op_type == OP_CONST 1988 ? kid 1989 : kLISTOP->op_first->op_sibling); 1990 1991 rop = (UNOP*)((LISTOP*)o)->op_last; 1992 1993 check_keys: 1994 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV) 1995 rop = NULL; 1996 else if (rop->op_first->op_type == OP_PADSV) 1997 /* @$hash{qw(keys here)} */ 1998 rop = (UNOP*)rop->op_first; 1999 else { 2000 /* @{$hash}{qw(keys here)} */ 2001 if (rop->op_first->op_type == OP_SCOPE 2002 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV) 2003 { 2004 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last; 2005 } 2006 else 2007 rop = NULL; 2008 } 2009 2010 lexname = NULL; /* just to silence compiler warnings */ 2011 fields = NULL; /* just to silence compiler warnings */ 2012 2013 check_fields = 2014 rop 2015 && (lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE), 2016 SvPAD_TYPED(lexname)) 2017 && (fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE)) 2018 && isGV(*fields) && GvHV(*fields); 2019 for (; key_op; 2020 key_op = (SVOP*)key_op->op_sibling) { 2021 SV **svp, *sv; 2022 if (key_op->op_type != OP_CONST) 2023 continue; 2024 svp = cSVOPx_svp(key_op); 2025 2026 /* Make the CONST have a shared SV */ 2027 if ((!SvIsCOW_shared_hash(sv = *svp)) 2028 && SvTYPE(sv) < SVt_PVMG && SvOK(sv) && !SvROK(sv)) { 2029 SSize_t keylen; 2030 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen); 2031 SV *nsv = newSVpvn_share(key, 2032 SvUTF8(sv) ? -keylen : keylen, 0); 2033 SvREFCNT_dec_NN(sv); 2034 *svp = nsv; 2035 } 2036 2037 if (check_fields 2038 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0)) { 2039 Perl_croak(aTHX_ "No such class field \"%"SVf"\" " 2040 "in variable %"SVf" of type %"HEKf, 2041 SVfARG(*svp), SVfARG(lexname), 2042 HEKfARG(HvNAME_HEK(SvSTASH(lexname)))); 2043 } 2044 } 2045 break; 2046 } 2047 case OP_ASLICE: 2048 S_scalar_slice_warning(aTHX_ o); 2049 break; 2050 2051 case OP_SUBST: { 2052 if (cPMOPo->op_pmreplrootu.op_pmreplroot) 2053 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot); 2054 break; 2055 } 2056 default: 2057 break; 2058 } 2059 2060 if (o->op_flags & OPf_KIDS) { 2061 OP *kid; 2062 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) 2063 finalize_op(kid); 2064 } 2065 } 2066 2067 /* 2068 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type 2069 2070 Propagate lvalue ("modifiable") context to an op and its children. 2071 I<type> represents the context type, roughly based on the type of op that 2072 would do the modifying, although C<local()> is represented by OP_NULL, 2073 because it has no op type of its own (it is signalled by a flag on 2074 the lvalue op). 2075 2076 This function detects things that can't be modified, such as C<$x+1>, and 2077 generates errors for them. For example, C<$x+1 = 2> would cause it to be 2078 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN. 2079 2080 It also flags things that need to behave specially in an lvalue context, 2081 such as C<$$x = 5> which might have to vivify a reference in C<$x>. 2082 2083 =cut 2084 */ 2085 2086 static bool 2087 S_vivifies(const OPCODE type) 2088 { 2089 switch(type) { 2090 case OP_RV2AV: case OP_ASLICE: 2091 case OP_RV2HV: case OP_KVASLICE: 2092 case OP_RV2SV: case OP_HSLICE: 2093 case OP_AELEMFAST: case OP_KVHSLICE: 2094 case OP_HELEM: 2095 case OP_AELEM: 2096 return 1; 2097 } 2098 return 0; 2099 } 2100 2101 OP * 2102 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) 2103 { 2104 dVAR; 2105 OP *kid; 2106 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */ 2107 int localize = -1; 2108 2109 if (!o || (PL_parser && PL_parser->error_count)) 2110 return o; 2111 2112 if ((o->op_private & OPpTARGET_MY) 2113 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */ 2114 { 2115 return o; 2116 } 2117 2118 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID ); 2119 2120 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB; 2121 2122 switch (o->op_type) { 2123 case OP_UNDEF: 2124 PL_modcount++; 2125 return o; 2126 case OP_STUB: 2127 if ((o->op_flags & OPf_PARENS) || PL_madskills) 2128 break; 2129 goto nomod; 2130 case OP_ENTERSUB: 2131 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) && 2132 !(o->op_flags & OPf_STACKED)) { 2133 o->op_type = OP_RV2CV; /* entersub => rv2cv */ 2134 /* Both ENTERSUB and RV2CV use this bit, but for different pur- 2135 poses, so we need it clear. */ 2136 o->op_private &= ~1; 2137 o->op_ppaddr = PL_ppaddr[OP_RV2CV]; 2138 assert(cUNOPo->op_first->op_type == OP_NULL); 2139 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */ 2140 break; 2141 } 2142 else { /* lvalue subroutine call */ 2143 o->op_private |= OPpLVAL_INTRO 2144 |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV)); 2145 PL_modcount = RETURN_UNLIMITED_NUMBER; 2146 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) { 2147 /* Potential lvalue context: */ 2148 o->op_private |= OPpENTERSUB_INARGS; 2149 break; 2150 } 2151 else { /* Compile-time error message: */ 2152 OP *kid = cUNOPo->op_first; 2153 CV *cv; 2154 2155 if (kid->op_type != OP_PUSHMARK) { 2156 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST) 2157 Perl_croak(aTHX_ 2158 "panic: unexpected lvalue entersub " 2159 "args: type/targ %ld:%"UVuf, 2160 (long)kid->op_type, (UV)kid->op_targ); 2161 kid = kLISTOP->op_first; 2162 } 2163 while (kid->op_sibling) 2164 kid = kid->op_sibling; 2165 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) { 2166 break; /* Postpone until runtime */ 2167 } 2168 2169 kid = kUNOP->op_first; 2170 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV) 2171 kid = kUNOP->op_first; 2172 if (kid->op_type == OP_NULL) 2173 Perl_croak(aTHX_ 2174 "Unexpected constant lvalue entersub " 2175 "entry via type/targ %ld:%"UVuf, 2176 (long)kid->op_type, (UV)kid->op_targ); 2177 if (kid->op_type != OP_GV) { 2178 break; 2179 } 2180 2181 cv = GvCV(kGVOP_gv); 2182 if (!cv) 2183 break; 2184 if (CvLVALUE(cv)) 2185 break; 2186 } 2187 } 2188 /* FALL THROUGH */ 2189 default: 2190 nomod: 2191 if (flags & OP_LVALUE_NO_CROAK) return NULL; 2192 /* grep, foreach, subcalls, refgen */ 2193 if (type == OP_GREPSTART || type == OP_ENTERSUB 2194 || type == OP_REFGEN || type == OP_LEAVESUBLV) 2195 break; 2196 yyerror(Perl_form(aTHX_ "Can't modify %s in %s", 2197 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL) 2198 ? "do block" 2199 : (o->op_type == OP_ENTERSUB 2200 ? "non-lvalue subroutine call" 2201 : OP_DESC(o))), 2202 type ? PL_op_desc[type] : "local")); 2203 return o; 2204 2205 case OP_PREINC: 2206 case OP_PREDEC: 2207 case OP_POW: 2208 case OP_MULTIPLY: 2209 case OP_DIVIDE: 2210 case OP_MODULO: 2211 case OP_REPEAT: 2212 case OP_ADD: 2213 case OP_SUBTRACT: 2214 case OP_CONCAT: 2215 case OP_LEFT_SHIFT: 2216 case OP_RIGHT_SHIFT: 2217 case OP_BIT_AND: 2218 case OP_BIT_XOR: 2219 case OP_BIT_OR: 2220 case OP_I_MULTIPLY: 2221 case OP_I_DIVIDE: 2222 case OP_I_MODULO: 2223 case OP_I_ADD: 2224 case OP_I_SUBTRACT: 2225 if (!(o->op_flags & OPf_STACKED)) 2226 goto nomod; 2227 PL_modcount++; 2228 break; 2229 2230 case OP_COND_EXPR: 2231 localize = 1; 2232 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) 2233 op_lvalue(kid, type); 2234 break; 2235 2236 case OP_RV2AV: 2237 case OP_RV2HV: 2238 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) { 2239 PL_modcount = RETURN_UNLIMITED_NUMBER; 2240 return o; /* Treat \(@foo) like ordinary list. */ 2241 } 2242 /* FALL THROUGH */ 2243 case OP_RV2GV: 2244 if (scalar_mod_type(o, type)) 2245 goto nomod; 2246 ref(cUNOPo->op_first, o->op_type); 2247 /* FALL THROUGH */ 2248 case OP_ASLICE: 2249 case OP_HSLICE: 2250 localize = 1; 2251 /* FALL THROUGH */ 2252 case OP_AASSIGN: 2253 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */ 2254 if (type == OP_LEAVESUBLV && ( 2255 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV) 2256 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR 2257 )) 2258 o->op_private |= OPpMAYBE_LVSUB; 2259 /* FALL THROUGH */ 2260 case OP_NEXTSTATE: 2261 case OP_DBSTATE: 2262 PL_modcount = RETURN_UNLIMITED_NUMBER; 2263 break; 2264 case OP_KVHSLICE: 2265 case OP_KVASLICE: 2266 if (type == OP_LEAVESUBLV) 2267 o->op_private |= OPpMAYBE_LVSUB; 2268 goto nomod; 2269 case OP_AV2ARYLEN: 2270 PL_hints |= HINT_BLOCK_SCOPE; 2271 if (type == OP_LEAVESUBLV) 2272 o->op_private |= OPpMAYBE_LVSUB; 2273 PL_modcount++; 2274 break; 2275 case OP_RV2SV: 2276 ref(cUNOPo->op_first, o->op_type); 2277 localize = 1; 2278 /* FALL THROUGH */ 2279 case OP_GV: 2280 PL_hints |= HINT_BLOCK_SCOPE; 2281 case OP_SASSIGN: 2282 case OP_ANDASSIGN: 2283 case OP_ORASSIGN: 2284 case OP_DORASSIGN: 2285 PL_modcount++; 2286 break; 2287 2288 case OP_AELEMFAST: 2289 case OP_AELEMFAST_LEX: 2290 localize = -1; 2291 PL_modcount++; 2292 break; 2293 2294 case OP_PADAV: 2295 case OP_PADHV: 2296 PL_modcount = RETURN_UNLIMITED_NUMBER; 2297 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) 2298 return o; /* Treat \(@foo) like ordinary list. */ 2299 if (scalar_mod_type(o, type)) 2300 goto nomod; 2301 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR 2302 && type == OP_LEAVESUBLV) 2303 o->op_private |= OPpMAYBE_LVSUB; 2304 /* FALL THROUGH */ 2305 case OP_PADSV: 2306 PL_modcount++; 2307 if (!type) /* local() */ 2308 Perl_croak(aTHX_ "Can't localize lexical variable %"SVf, 2309 PAD_COMPNAME_SV(o->op_targ)); 2310 break; 2311 2312 case OP_PUSHMARK: 2313 localize = 0; 2314 break; 2315 2316 case OP_KEYS: 2317 case OP_RKEYS: 2318 if (type != OP_SASSIGN && type != OP_LEAVESUBLV) 2319 goto nomod; 2320 goto lvalue_func; 2321 case OP_SUBSTR: 2322 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */ 2323 goto nomod; 2324 /* FALL THROUGH */ 2325 case OP_POS: 2326 case OP_VEC: 2327 lvalue_func: 2328 if (type == OP_LEAVESUBLV) 2329 o->op_private |= OPpMAYBE_LVSUB; 2330 if (o->op_flags & OPf_KIDS) 2331 op_lvalue(cBINOPo->op_first->op_sibling, type); 2332 break; 2333 2334 case OP_AELEM: 2335 case OP_HELEM: 2336 ref(cBINOPo->op_first, o->op_type); 2337 if (type == OP_ENTERSUB && 2338 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF))) 2339 o->op_private |= OPpLVAL_DEFER; 2340 if (type == OP_LEAVESUBLV) 2341 o->op_private |= OPpMAYBE_LVSUB; 2342 localize = 1; 2343 PL_modcount++; 2344 break; 2345 2346 case OP_LEAVE: 2347 case OP_LEAVELOOP: 2348 o->op_private |= OPpLVALUE; 2349 case OP_SCOPE: 2350 case OP_ENTER: 2351 case OP_LINESEQ: 2352 localize = 0; 2353 if (o->op_flags & OPf_KIDS) 2354 op_lvalue(cLISTOPo->op_last, type); 2355 break; 2356 2357 case OP_NULL: 2358 localize = 0; 2359 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */ 2360 goto nomod; 2361 else if (!(o->op_flags & OPf_KIDS)) 2362 break; 2363 if (o->op_targ != OP_LIST) { 2364 op_lvalue(cBINOPo->op_first, type); 2365 break; 2366 } 2367 /* FALL THROUGH */ 2368 case OP_LIST: 2369 localize = 0; 2370 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 2371 /* elements might be in void context because the list is 2372 in scalar context or because they are attribute sub calls */ 2373 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID ) 2374 op_lvalue(kid, type); 2375 break; 2376 2377 case OP_RETURN: 2378 if (type != OP_LEAVESUBLV) 2379 goto nomod; 2380 break; /* op_lvalue()ing was handled by ck_return() */ 2381 2382 case OP_COREARGS: 2383 return o; 2384 2385 case OP_AND: 2386 case OP_OR: 2387 if (type == OP_LEAVESUBLV 2388 || !S_vivifies(cLOGOPo->op_first->op_type)) 2389 op_lvalue(cLOGOPo->op_first, type); 2390 if (type == OP_LEAVESUBLV 2391 || !S_vivifies(cLOGOPo->op_first->op_sibling->op_type)) 2392 op_lvalue(cLOGOPo->op_first->op_sibling, type); 2393 goto nomod; 2394 } 2395 2396 /* [20011101.069] File test operators interpret OPf_REF to mean that 2397 their argument is a filehandle; thus \stat(".") should not set 2398 it. AMS 20011102 */ 2399 if (type == OP_REFGEN && 2400 PL_check[o->op_type] == Perl_ck_ftst) 2401 return o; 2402 2403 if (type != OP_LEAVESUBLV) 2404 o->op_flags |= OPf_MOD; 2405 2406 if (type == OP_AASSIGN || type == OP_SASSIGN) 2407 o->op_flags |= OPf_SPECIAL|OPf_REF; 2408 else if (!type) { /* local() */ 2409 switch (localize) { 2410 case 1: 2411 o->op_private |= OPpLVAL_INTRO; 2412 o->op_flags &= ~OPf_SPECIAL; 2413 PL_hints |= HINT_BLOCK_SCOPE; 2414 break; 2415 case 0: 2416 break; 2417 case -1: 2418 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), 2419 "Useless localization of %s", OP_DESC(o)); 2420 } 2421 } 2422 else if (type != OP_GREPSTART && type != OP_ENTERSUB 2423 && type != OP_LEAVESUBLV) 2424 o->op_flags |= OPf_REF; 2425 return o; 2426 } 2427 2428 STATIC bool 2429 S_scalar_mod_type(const OP *o, I32 type) 2430 { 2431 switch (type) { 2432 case OP_POS: 2433 case OP_SASSIGN: 2434 if (o && o->op_type == OP_RV2GV) 2435 return FALSE; 2436 /* FALL THROUGH */ 2437 case OP_PREINC: 2438 case OP_PREDEC: 2439 case OP_POSTINC: 2440 case OP_POSTDEC: 2441 case OP_I_PREINC: 2442 case OP_I_PREDEC: 2443 case OP_I_POSTINC: 2444 case OP_I_POSTDEC: 2445 case OP_POW: 2446 case OP_MULTIPLY: 2447 case OP_DIVIDE: 2448 case OP_MODULO: 2449 case OP_REPEAT: 2450 case OP_ADD: 2451 case OP_SUBTRACT: 2452 case OP_I_MULTIPLY: 2453 case OP_I_DIVIDE: 2454 case OP_I_MODULO: 2455 case OP_I_ADD: 2456 case OP_I_SUBTRACT: 2457 case OP_LEFT_SHIFT: 2458 case OP_RIGHT_SHIFT: 2459 case OP_BIT_AND: 2460 case OP_BIT_XOR: 2461 case OP_BIT_OR: 2462 case OP_CONCAT: 2463 case OP_SUBST: 2464 case OP_TRANS: 2465 case OP_TRANSR: 2466 case OP_READ: 2467 case OP_SYSREAD: 2468 case OP_RECV: 2469 case OP_ANDASSIGN: 2470 case OP_ORASSIGN: 2471 case OP_DORASSIGN: 2472 return TRUE; 2473 default: 2474 return FALSE; 2475 } 2476 } 2477 2478 STATIC bool 2479 S_is_handle_constructor(const OP *o, I32 numargs) 2480 { 2481 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR; 2482 2483 switch (o->op_type) { 2484 case OP_PIPE_OP: 2485 case OP_SOCKPAIR: 2486 if (numargs == 2) 2487 return TRUE; 2488 /* FALL THROUGH */ 2489 case OP_SYSOPEN: 2490 case OP_OPEN: 2491 case OP_SELECT: /* XXX c.f. SelectSaver.pm */ 2492 case OP_SOCKET: 2493 case OP_OPEN_DIR: 2494 case OP_ACCEPT: 2495 if (numargs == 1) 2496 return TRUE; 2497 /* FALLTHROUGH */ 2498 default: 2499 return FALSE; 2500 } 2501 } 2502 2503 static OP * 2504 S_refkids(pTHX_ OP *o, I32 type) 2505 { 2506 if (o && o->op_flags & OPf_KIDS) { 2507 OP *kid; 2508 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 2509 ref(kid, type); 2510 } 2511 return o; 2512 } 2513 2514 OP * 2515 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref) 2516 { 2517 dVAR; 2518 OP *kid; 2519 2520 PERL_ARGS_ASSERT_DOREF; 2521 2522 if (!o || (PL_parser && PL_parser->error_count)) 2523 return o; 2524 2525 switch (o->op_type) { 2526 case OP_ENTERSUB: 2527 if ((type == OP_EXISTS || type == OP_DEFINED) && 2528 !(o->op_flags & OPf_STACKED)) { 2529 o->op_type = OP_RV2CV; /* entersub => rv2cv */ 2530 o->op_ppaddr = PL_ppaddr[OP_RV2CV]; 2531 assert(cUNOPo->op_first->op_type == OP_NULL); 2532 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */ 2533 o->op_flags |= OPf_SPECIAL; 2534 o->op_private &= ~1; 2535 } 2536 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){ 2537 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV 2538 : type == OP_RV2HV ? OPpDEREF_HV 2539 : OPpDEREF_SV); 2540 o->op_flags |= OPf_MOD; 2541 } 2542 2543 break; 2544 2545 case OP_COND_EXPR: 2546 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) 2547 doref(kid, type, set_op_ref); 2548 break; 2549 case OP_RV2SV: 2550 if (type == OP_DEFINED) 2551 o->op_flags |= OPf_SPECIAL; /* don't create GV */ 2552 doref(cUNOPo->op_first, o->op_type, set_op_ref); 2553 /* FALL THROUGH */ 2554 case OP_PADSV: 2555 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) { 2556 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV 2557 : type == OP_RV2HV ? OPpDEREF_HV 2558 : OPpDEREF_SV); 2559 o->op_flags |= OPf_MOD; 2560 } 2561 break; 2562 2563 case OP_RV2AV: 2564 case OP_RV2HV: 2565 if (set_op_ref) 2566 o->op_flags |= OPf_REF; 2567 /* FALL THROUGH */ 2568 case OP_RV2GV: 2569 if (type == OP_DEFINED) 2570 o->op_flags |= OPf_SPECIAL; /* don't create GV */ 2571 doref(cUNOPo->op_first, o->op_type, set_op_ref); 2572 break; 2573 2574 case OP_PADAV: 2575 case OP_PADHV: 2576 if (set_op_ref) 2577 o->op_flags |= OPf_REF; 2578 break; 2579 2580 case OP_SCALAR: 2581 case OP_NULL: 2582 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED) 2583 break; 2584 doref(cBINOPo->op_first, type, set_op_ref); 2585 break; 2586 case OP_AELEM: 2587 case OP_HELEM: 2588 doref(cBINOPo->op_first, o->op_type, set_op_ref); 2589 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) { 2590 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV 2591 : type == OP_RV2HV ? OPpDEREF_HV 2592 : OPpDEREF_SV); 2593 o->op_flags |= OPf_MOD; 2594 } 2595 break; 2596 2597 case OP_SCOPE: 2598 case OP_LEAVE: 2599 set_op_ref = FALSE; 2600 /* FALL THROUGH */ 2601 case OP_ENTER: 2602 case OP_LIST: 2603 if (!(o->op_flags & OPf_KIDS)) 2604 break; 2605 doref(cLISTOPo->op_last, type, set_op_ref); 2606 break; 2607 default: 2608 break; 2609 } 2610 return scalar(o); 2611 2612 } 2613 2614 STATIC OP * 2615 S_dup_attrlist(pTHX_ OP *o) 2616 { 2617 dVAR; 2618 OP *rop; 2619 2620 PERL_ARGS_ASSERT_DUP_ATTRLIST; 2621 2622 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids, 2623 * where the first kid is OP_PUSHMARK and the remaining ones 2624 * are OP_CONST. We need to push the OP_CONST values. 2625 */ 2626 if (o->op_type == OP_CONST) 2627 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv)); 2628 #ifdef PERL_MAD 2629 else if (o->op_type == OP_NULL) 2630 rop = NULL; 2631 #endif 2632 else { 2633 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS)); 2634 rop = NULL; 2635 for (o = cLISTOPo->op_first; o; o=o->op_sibling) { 2636 if (o->op_type == OP_CONST) 2637 rop = op_append_elem(OP_LIST, rop, 2638 newSVOP(OP_CONST, o->op_flags, 2639 SvREFCNT_inc_NN(cSVOPo->op_sv))); 2640 } 2641 } 2642 return rop; 2643 } 2644 2645 STATIC void 2646 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs) 2647 { 2648 dVAR; 2649 SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no; 2650 2651 PERL_ARGS_ASSERT_APPLY_ATTRS; 2652 2653 /* fake up C<use attributes $pkg,$rv,@attrs> */ 2654 2655 #define ATTRSMODULE "attributes" 2656 #define ATTRSMODULE_PM "attributes.pm" 2657 2658 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS, 2659 newSVpvs(ATTRSMODULE), 2660 NULL, 2661 op_prepend_elem(OP_LIST, 2662 newSVOP(OP_CONST, 0, stashsv), 2663 op_prepend_elem(OP_LIST, 2664 newSVOP(OP_CONST, 0, 2665 newRV(target)), 2666 dup_attrlist(attrs)))); 2667 } 2668 2669 STATIC void 2670 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) 2671 { 2672 dVAR; 2673 OP *pack, *imop, *arg; 2674 SV *meth, *stashsv, **svp; 2675 2676 PERL_ARGS_ASSERT_APPLY_ATTRS_MY; 2677 2678 if (!attrs) 2679 return; 2680 2681 assert(target->op_type == OP_PADSV || 2682 target->op_type == OP_PADHV || 2683 target->op_type == OP_PADAV); 2684 2685 /* Ensure that attributes.pm is loaded. */ 2686 /* Don't force the C<use> if we don't need it. */ 2687 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE); 2688 if (svp && *svp != &PL_sv_undef) 2689 NOOP; /* already in %INC */ 2690 else 2691 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, 2692 newSVpvs(ATTRSMODULE), NULL); 2693 2694 /* Need package name for method call. */ 2695 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE)); 2696 2697 /* Build up the real arg-list. */ 2698 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no; 2699 2700 arg = newOP(OP_PADSV, 0); 2701 arg->op_targ = target->op_targ; 2702 arg = op_prepend_elem(OP_LIST, 2703 newSVOP(OP_CONST, 0, stashsv), 2704 op_prepend_elem(OP_LIST, 2705 newUNOP(OP_REFGEN, 0, 2706 op_lvalue(arg, OP_REFGEN)), 2707 dup_attrlist(attrs))); 2708 2709 /* Fake up a method call to import */ 2710 meth = newSVpvs_share("import"); 2711 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID, 2712 op_append_elem(OP_LIST, 2713 op_prepend_elem(OP_LIST, pack, list(arg)), 2714 newSVOP(OP_METHOD_NAMED, 0, meth))); 2715 2716 /* Combine the ops. */ 2717 *imopsp = op_append_elem(OP_LIST, *imopsp, imop); 2718 } 2719 2720 /* 2721 =notfor apidoc apply_attrs_string 2722 2723 Attempts to apply a list of attributes specified by the C<attrstr> and 2724 C<len> arguments to the subroutine identified by the C<cv> argument which 2725 is expected to be associated with the package identified by the C<stashpv> 2726 argument (see L<attributes>). It gets this wrong, though, in that it 2727 does not correctly identify the boundaries of the individual attribute 2728 specifications within C<attrstr>. This is not really intended for the 2729 public API, but has to be listed here for systems such as AIX which 2730 need an explicit export list for symbols. (It's called from XS code 2731 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it 2732 to respect attribute syntax properly would be welcome. 2733 2734 =cut 2735 */ 2736 2737 void 2738 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv, 2739 const char *attrstr, STRLEN len) 2740 { 2741 OP *attrs = NULL; 2742 2743 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING; 2744 2745 if (!len) { 2746 len = strlen(attrstr); 2747 } 2748 2749 while (len) { 2750 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ; 2751 if (len) { 2752 const char * const sstr = attrstr; 2753 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ; 2754 attrs = op_append_elem(OP_LIST, attrs, 2755 newSVOP(OP_CONST, 0, 2756 newSVpvn(sstr, attrstr-sstr))); 2757 } 2758 } 2759 2760 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS, 2761 newSVpvs(ATTRSMODULE), 2762 NULL, op_prepend_elem(OP_LIST, 2763 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)), 2764 op_prepend_elem(OP_LIST, 2765 newSVOP(OP_CONST, 0, 2766 newRV(MUTABLE_SV(cv))), 2767 attrs))); 2768 } 2769 2770 STATIC void 2771 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name) 2772 { 2773 OP *new_proto = NULL; 2774 STRLEN pvlen; 2775 char *pv; 2776 OP *o; 2777 2778 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR; 2779 2780 if (!*attrs) 2781 return; 2782 2783 o = *attrs; 2784 if (o->op_type == OP_CONST) { 2785 pv = SvPV(cSVOPo_sv, pvlen); 2786 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) { 2787 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv)); 2788 SV ** const tmpo = cSVOPx_svp(o); 2789 SvREFCNT_dec(cSVOPo_sv); 2790 *tmpo = tmpsv; 2791 new_proto = o; 2792 *attrs = NULL; 2793 } 2794 } else if (o->op_type == OP_LIST) { 2795 OP * lasto = NULL; 2796 assert(o->op_flags & OPf_KIDS); 2797 assert(cLISTOPo->op_first->op_type == OP_PUSHMARK); 2798 /* Counting on the first op to hit the lasto = o line */ 2799 for (o = cLISTOPo->op_first; o; o=o->op_sibling) { 2800 if (o->op_type == OP_CONST) { 2801 pv = SvPV(cSVOPo_sv, pvlen); 2802 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) { 2803 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv)); 2804 SV ** const tmpo = cSVOPx_svp(o); 2805 SvREFCNT_dec(cSVOPo_sv); 2806 *tmpo = tmpsv; 2807 if (new_proto && ckWARN(WARN_MISC)) { 2808 STRLEN new_len; 2809 const char * newp = SvPV(cSVOPo_sv, new_len); 2810 Perl_warner(aTHX_ packWARN(WARN_MISC), 2811 "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub", 2812 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp)); 2813 op_free(new_proto); 2814 } 2815 else if (new_proto) 2816 op_free(new_proto); 2817 new_proto = o; 2818 lasto->op_sibling = o->op_sibling; 2819 continue; 2820 } 2821 } 2822 lasto = o; 2823 } 2824 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs 2825 would get pulled in with no real need */ 2826 if (!cLISTOPx(*attrs)->op_first->op_sibling) { 2827 op_free(*attrs); 2828 *attrs = NULL; 2829 } 2830 } 2831 2832 if (new_proto) { 2833 SV *svname; 2834 if (isGV(name)) { 2835 svname = sv_newmortal(); 2836 gv_efullname3(svname, name, NULL); 2837 } 2838 else if (SvPOK(name) && *SvPVX((SV *)name) == '&') 2839 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP); 2840 else 2841 svname = (SV *)name; 2842 if (ckWARN(WARN_ILLEGALPROTO)) 2843 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE); 2844 if (*proto && ckWARN(WARN_PROTOTYPE)) { 2845 STRLEN old_len, new_len; 2846 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len); 2847 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len); 2848 2849 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), 2850 "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'" 2851 " in %"SVf, 2852 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp), 2853 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp), 2854 SVfARG(svname)); 2855 } 2856 if (*proto) 2857 op_free(*proto); 2858 *proto = new_proto; 2859 } 2860 } 2861 2862 static void 2863 S_cant_declare(pTHX_ OP *o) 2864 { 2865 if (o->op_type == OP_NULL 2866 && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS) 2867 o = cUNOPo->op_first; 2868 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"", 2869 o->op_type == OP_NULL 2870 && o->op_flags & OPf_SPECIAL 2871 ? "do block" 2872 : OP_DESC(o), 2873 PL_parser->in_my == KEY_our ? "our" : 2874 PL_parser->in_my == KEY_state ? "state" : 2875 "my")); 2876 } 2877 2878 STATIC OP * 2879 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) 2880 { 2881 dVAR; 2882 I32 type; 2883 const bool stately = PL_parser && PL_parser->in_my == KEY_state; 2884 2885 PERL_ARGS_ASSERT_MY_KID; 2886 2887 if (!o || (PL_parser && PL_parser->error_count)) 2888 return o; 2889 2890 type = o->op_type; 2891 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) { 2892 (void)my_kid(cUNOPo->op_first, attrs, imopsp); 2893 return o; 2894 } 2895 2896 if (type == OP_LIST) { 2897 OP *kid; 2898 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 2899 my_kid(kid, attrs, imopsp); 2900 return o; 2901 } else if (type == OP_UNDEF || type == OP_STUB) { 2902 return o; 2903 } else if (type == OP_RV2SV || /* "our" declaration */ 2904 type == OP_RV2AV || 2905 type == OP_RV2HV) { /* XXX does this let anything illegal in? */ 2906 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */ 2907 S_cant_declare(aTHX_ o); 2908 } else if (attrs) { 2909 GV * const gv = cGVOPx_gv(cUNOPo->op_first); 2910 PL_parser->in_my = FALSE; 2911 PL_parser->in_my_stash = NULL; 2912 apply_attrs(GvSTASH(gv), 2913 (type == OP_RV2SV ? GvSV(gv) : 2914 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) : 2915 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)), 2916 attrs); 2917 } 2918 o->op_private |= OPpOUR_INTRO; 2919 return o; 2920 } 2921 else if (type != OP_PADSV && 2922 type != OP_PADAV && 2923 type != OP_PADHV && 2924 type != OP_PUSHMARK) 2925 { 2926 S_cant_declare(aTHX_ o); 2927 return o; 2928 } 2929 else if (attrs && type != OP_PUSHMARK) { 2930 HV *stash; 2931 2932 PL_parser->in_my = FALSE; 2933 PL_parser->in_my_stash = NULL; 2934 2935 /* check for C<my Dog $spot> when deciding package */ 2936 stash = PAD_COMPNAME_TYPE(o->op_targ); 2937 if (!stash) 2938 stash = PL_curstash; 2939 apply_attrs_my(stash, o, attrs, imopsp); 2940 } 2941 o->op_flags |= OPf_MOD; 2942 o->op_private |= OPpLVAL_INTRO; 2943 if (stately) 2944 o->op_private |= OPpPAD_STATE; 2945 return o; 2946 } 2947 2948 OP * 2949 Perl_my_attrs(pTHX_ OP *o, OP *attrs) 2950 { 2951 dVAR; 2952 OP *rops; 2953 int maybe_scalar = 0; 2954 2955 PERL_ARGS_ASSERT_MY_ATTRS; 2956 2957 /* [perl #17376]: this appears to be premature, and results in code such as 2958 C< our(%x); > executing in list mode rather than void mode */ 2959 #if 0 2960 if (o->op_flags & OPf_PARENS) 2961 list(o); 2962 else 2963 maybe_scalar = 1; 2964 #else 2965 maybe_scalar = 1; 2966 #endif 2967 if (attrs) 2968 SAVEFREEOP(attrs); 2969 rops = NULL; 2970 o = my_kid(o, attrs, &rops); 2971 if (rops) { 2972 if (maybe_scalar && o->op_type == OP_PADSV) { 2973 o = scalar(op_append_list(OP_LIST, rops, o)); 2974 o->op_private |= OPpLVAL_INTRO; 2975 } 2976 else { 2977 /* The listop in rops might have a pushmark at the beginning, 2978 which will mess up list assignment. */ 2979 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */ 2980 if (rops->op_type == OP_LIST && 2981 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK) 2982 { 2983 OP * const pushmark = lrops->op_first; 2984 lrops->op_first = pushmark->op_sibling; 2985 op_free(pushmark); 2986 } 2987 o = op_append_list(OP_LIST, o, rops); 2988 } 2989 } 2990 PL_parser->in_my = FALSE; 2991 PL_parser->in_my_stash = NULL; 2992 return o; 2993 } 2994 2995 OP * 2996 Perl_sawparens(pTHX_ OP *o) 2997 { 2998 PERL_UNUSED_CONTEXT; 2999 if (o) 3000 o->op_flags |= OPf_PARENS; 3001 return o; 3002 } 3003 3004 OP * 3005 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) 3006 { 3007 OP *o; 3008 bool ismatchop = 0; 3009 const OPCODE ltype = left->op_type; 3010 const OPCODE rtype = right->op_type; 3011 3012 PERL_ARGS_ASSERT_BIND_MATCH; 3013 3014 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV 3015 || ltype == OP_PADHV) && ckWARN(WARN_MISC)) 3016 { 3017 const char * const desc 3018 = PL_op_desc[( 3019 rtype == OP_SUBST || rtype == OP_TRANS 3020 || rtype == OP_TRANSR 3021 ) 3022 ? (int)rtype : OP_MATCH]; 3023 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV; 3024 SV * const name = 3025 S_op_varname(aTHX_ left); 3026 if (name) 3027 Perl_warner(aTHX_ packWARN(WARN_MISC), 3028 "Applying %s to %"SVf" will act on scalar(%"SVf")", 3029 desc, name, name); 3030 else { 3031 const char * const sample = (isary 3032 ? "@array" : "%hash"); 3033 Perl_warner(aTHX_ packWARN(WARN_MISC), 3034 "Applying %s to %s will act on scalar(%s)", 3035 desc, sample, sample); 3036 } 3037 } 3038 3039 if (rtype == OP_CONST && 3040 cSVOPx(right)->op_private & OPpCONST_BARE && 3041 cSVOPx(right)->op_private & OPpCONST_STRICT) 3042 { 3043 no_bareword_allowed(right); 3044 } 3045 3046 /* !~ doesn't make sense with /r, so error on it for now */ 3047 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) && 3048 type == OP_NOT) 3049 /* diag_listed_as: Using !~ with %s doesn't make sense */ 3050 yyerror("Using !~ with s///r doesn't make sense"); 3051 if (rtype == OP_TRANSR && type == OP_NOT) 3052 /* diag_listed_as: Using !~ with %s doesn't make sense */ 3053 yyerror("Using !~ with tr///r doesn't make sense"); 3054 3055 ismatchop = (rtype == OP_MATCH || 3056 rtype == OP_SUBST || 3057 rtype == OP_TRANS || rtype == OP_TRANSR) 3058 && !(right->op_flags & OPf_SPECIAL); 3059 if (ismatchop && right->op_private & OPpTARGET_MY) { 3060 right->op_targ = 0; 3061 right->op_private &= ~OPpTARGET_MY; 3062 } 3063 if (!(right->op_flags & OPf_STACKED) && ismatchop) { 3064 OP *newleft; 3065 3066 right->op_flags |= OPf_STACKED; 3067 if (rtype != OP_MATCH && rtype != OP_TRANSR && 3068 ! (rtype == OP_TRANS && 3069 right->op_private & OPpTRANS_IDENTICAL) && 3070 ! (rtype == OP_SUBST && 3071 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT))) 3072 newleft = op_lvalue(left, rtype); 3073 else 3074 newleft = left; 3075 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR) 3076 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right); 3077 else 3078 o = op_prepend_elem(rtype, scalar(newleft), right); 3079 if (type == OP_NOT) 3080 return newUNOP(OP_NOT, 0, scalar(o)); 3081 return o; 3082 } 3083 else 3084 return bind_match(type, left, 3085 pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0)); 3086 } 3087 3088 OP * 3089 Perl_invert(pTHX_ OP *o) 3090 { 3091 if (!o) 3092 return NULL; 3093 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o)); 3094 } 3095 3096 /* 3097 =for apidoc Amx|OP *|op_scope|OP *o 3098 3099 Wraps up an op tree with some additional ops so that at runtime a dynamic 3100 scope will be created. The original ops run in the new dynamic scope, 3101 and then, provided that they exit normally, the scope will be unwound. 3102 The additional ops used to create and unwind the dynamic scope will 3103 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used 3104 instead if the ops are simple enough to not need the full dynamic scope 3105 structure. 3106 3107 =cut 3108 */ 3109 3110 OP * 3111 Perl_op_scope(pTHX_ OP *o) 3112 { 3113 dVAR; 3114 if (o) { 3115 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) { 3116 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o); 3117 o->op_type = OP_LEAVE; 3118 o->op_ppaddr = PL_ppaddr[OP_LEAVE]; 3119 } 3120 else if (o->op_type == OP_LINESEQ) { 3121 OP *kid; 3122 o->op_type = OP_SCOPE; 3123 o->op_ppaddr = PL_ppaddr[OP_SCOPE]; 3124 kid = ((LISTOP*)o)->op_first; 3125 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) { 3126 op_null(kid); 3127 3128 /* The following deals with things like 'do {1 for 1}' */ 3129 kid = kid->op_sibling; 3130 if (kid && 3131 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)) 3132 op_null(kid); 3133 } 3134 } 3135 else 3136 o = newLISTOP(OP_SCOPE, 0, o, NULL); 3137 } 3138 return o; 3139 } 3140 3141 OP * 3142 Perl_op_unscope(pTHX_ OP *o) 3143 { 3144 if (o && o->op_type == OP_LINESEQ) { 3145 OP *kid = cLISTOPo->op_first; 3146 for(; kid; kid = kid->op_sibling) 3147 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) 3148 op_null(kid); 3149 } 3150 return o; 3151 } 3152 3153 int 3154 Perl_block_start(pTHX_ int full) 3155 { 3156 dVAR; 3157 const int retval = PL_savestack_ix; 3158 3159 pad_block_start(full); 3160 SAVEHINTS(); 3161 PL_hints &= ~HINT_BLOCK_SCOPE; 3162 SAVECOMPILEWARNINGS(); 3163 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings); 3164 3165 CALL_BLOCK_HOOKS(bhk_start, full); 3166 3167 return retval; 3168 } 3169 3170 OP* 3171 Perl_block_end(pTHX_ I32 floor, OP *seq) 3172 { 3173 dVAR; 3174 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE; 3175 OP* retval = scalarseq(seq); 3176 OP *o; 3177 3178 CALL_BLOCK_HOOKS(bhk_pre_end, &retval); 3179 3180 LEAVE_SCOPE(floor); 3181 if (needblockscope) 3182 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */ 3183 o = pad_leavemy(); 3184 3185 if (o) { 3186 /* pad_leavemy has created a sequence of introcv ops for all my 3187 subs declared in the block. We have to replicate that list with 3188 clonecv ops, to deal with this situation: 3189 3190 sub { 3191 my sub s1; 3192 my sub s2; 3193 sub s1 { state sub foo { \&s2 } } 3194 }->() 3195 3196 Originally, I was going to have introcv clone the CV and turn 3197 off the stale flag. Since &s1 is declared before &s2, the 3198 introcv op for &s1 is executed (on sub entry) before the one for 3199 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is 3200 cloned, since it is a state sub) closes over &s2 and expects 3201 to see it in its outer CV’s pad. If the introcv op clones &s1, 3202 then &s2 is still marked stale. Since &s1 is not active, and 3203 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia- 3204 ble will not stay shared’ warning. Because it is the same stub 3205 that will be used when the introcv op for &s2 is executed, clos- 3206 ing over it is safe. Hence, we have to turn off the stale flag 3207 on all lexical subs in the block before we clone any of them. 3208 Hence, having introcv clone the sub cannot work. So we create a 3209 list of ops like this: 3210 3211 lineseq 3212 | 3213 +-- introcv 3214 | 3215 +-- introcv 3216 | 3217 +-- introcv 3218 | 3219 . 3220 . 3221 . 3222 | 3223 +-- clonecv 3224 | 3225 +-- clonecv 3226 | 3227 +-- clonecv 3228 | 3229 . 3230 . 3231 . 3232 */ 3233 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o; 3234 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o; 3235 for (;; kid = kid->op_sibling) { 3236 OP *newkid = newOP(OP_CLONECV, 0); 3237 newkid->op_targ = kid->op_targ; 3238 o = op_append_elem(OP_LINESEQ, o, newkid); 3239 if (kid == last) break; 3240 } 3241 retval = op_prepend_elem(OP_LINESEQ, o, retval); 3242 } 3243 3244 CALL_BLOCK_HOOKS(bhk_post_end, &retval); 3245 3246 return retval; 3247 } 3248 3249 /* 3250 =head1 Compile-time scope hooks 3251 3252 =for apidoc Aox||blockhook_register 3253 3254 Register a set of hooks to be called when the Perl lexical scope changes 3255 at compile time. See L<perlguts/"Compile-time scope hooks">. 3256 3257 =cut 3258 */ 3259 3260 void 3261 Perl_blockhook_register(pTHX_ BHK *hk) 3262 { 3263 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER; 3264 3265 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk))); 3266 } 3267 3268 STATIC OP * 3269 S_newDEFSVOP(pTHX) 3270 { 3271 dVAR; 3272 const PADOFFSET offset = pad_findmy_pvs("$_", 0); 3273 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) { 3274 return newSVREF(newGVOP(OP_GV, 0, PL_defgv)); 3275 } 3276 else { 3277 OP * const o = newOP(OP_PADSV, 0); 3278 o->op_targ = offset; 3279 return o; 3280 } 3281 } 3282 3283 void 3284 Perl_newPROG(pTHX_ OP *o) 3285 { 3286 dVAR; 3287 3288 PERL_ARGS_ASSERT_NEWPROG; 3289 3290 if (PL_in_eval) { 3291 PERL_CONTEXT *cx; 3292 I32 i; 3293 if (PL_eval_root) 3294 return; 3295 PL_eval_root = newUNOP(OP_LEAVEEVAL, 3296 ((PL_in_eval & EVAL_KEEPERR) 3297 ? OPf_SPECIAL : 0), o); 3298 3299 cx = &cxstack[cxstack_ix]; 3300 assert(CxTYPE(cx) == CXt_EVAL); 3301 3302 if ((cx->blk_gimme & G_WANT) == G_VOID) 3303 scalarvoid(PL_eval_root); 3304 else if ((cx->blk_gimme & G_WANT) == G_ARRAY) 3305 list(PL_eval_root); 3306 else 3307 scalar(PL_eval_root); 3308 3309 PL_eval_start = op_linklist(PL_eval_root); 3310 PL_eval_root->op_private |= OPpREFCOUNTED; 3311 OpREFCNT_set(PL_eval_root, 1); 3312 PL_eval_root->op_next = 0; 3313 i = PL_savestack_ix; 3314 SAVEFREEOP(o); 3315 ENTER; 3316 CALL_PEEP(PL_eval_start); 3317 finalize_optree(PL_eval_root); 3318 S_prune_chain_head(aTHX_ &PL_eval_start); 3319 LEAVE; 3320 PL_savestack_ix = i; 3321 } 3322 else { 3323 if (o->op_type == OP_STUB) { 3324 /* This block is entered if nothing is compiled for the main 3325 program. This will be the case for an genuinely empty main 3326 program, or one which only has BEGIN blocks etc, so already 3327 run and freed. 3328 3329 Historically (5.000) the guard above was !o. However, commit 3330 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as 3331 c71fccf11fde0068, changed perly.y so that newPROG() is now 3332 called with the output of block_end(), which returns a new 3333 OP_STUB for the case of an empty optree. ByteLoader (and 3334 maybe other things) also take this path, because they set up 3335 PL_main_start and PL_main_root directly, without generating an 3336 optree. 3337 3338 If the parsing the main program aborts (due to parse errors, 3339 or due to BEGIN or similar calling exit), then newPROG() 3340 isn't even called, and hence this code path and its cleanups 3341 are skipped. This shouldn't make a make a difference: 3342 * a non-zero return from perl_parse is a failure, and 3343 perl_destruct() should be called immediately. 3344 * however, if exit(0) is called during the parse, then 3345 perl_parse() returns 0, and perl_run() is called. As 3346 PL_main_start will be NULL, perl_run() will return 3347 promptly, and the exit code will remain 0. 3348 */ 3349 3350 PL_comppad_name = 0; 3351 PL_compcv = 0; 3352 S_op_destroy(aTHX_ o); 3353 return; 3354 } 3355 PL_main_root = op_scope(sawparens(scalarvoid(o))); 3356 PL_curcop = &PL_compiling; 3357 PL_main_start = LINKLIST(PL_main_root); 3358 PL_main_root->op_private |= OPpREFCOUNTED; 3359 OpREFCNT_set(PL_main_root, 1); 3360 PL_main_root->op_next = 0; 3361 CALL_PEEP(PL_main_start); 3362 finalize_optree(PL_main_root); 3363 S_prune_chain_head(aTHX_ &PL_main_start); 3364 cv_forget_slab(PL_compcv); 3365 PL_compcv = 0; 3366 3367 /* Register with debugger */ 3368 if (PERLDB_INTER) { 3369 CV * const cv = get_cvs("DB::postponed", 0); 3370 if (cv) { 3371 dSP; 3372 PUSHMARK(SP); 3373 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling))); 3374 PUTBACK; 3375 call_sv(MUTABLE_SV(cv), G_DISCARD); 3376 } 3377 } 3378 } 3379 } 3380 3381 OP * 3382 Perl_localize(pTHX_ OP *o, I32 lex) 3383 { 3384 dVAR; 3385 3386 PERL_ARGS_ASSERT_LOCALIZE; 3387 3388 if (o->op_flags & OPf_PARENS) 3389 /* [perl #17376]: this appears to be premature, and results in code such as 3390 C< our(%x); > executing in list mode rather than void mode */ 3391 #if 0 3392 list(o); 3393 #else 3394 NOOP; 3395 #endif 3396 else { 3397 if ( PL_parser->bufptr > PL_parser->oldbufptr 3398 && PL_parser->bufptr[-1] == ',' 3399 && ckWARN(WARN_PARENTHESIS)) 3400 { 3401 char *s = PL_parser->bufptr; 3402 bool sigil = FALSE; 3403 3404 /* some heuristics to detect a potential error */ 3405 while (*s && (strchr(", \t\n", *s))) 3406 s++; 3407 3408 while (1) { 3409 if (*s && strchr("@$%*", *s) && *++s 3410 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) { 3411 s++; 3412 sigil = TRUE; 3413 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) 3414 s++; 3415 while (*s && (strchr(", \t\n", *s))) 3416 s++; 3417 } 3418 else 3419 break; 3420 } 3421 if (sigil && (*s == ';' || *s == '=')) { 3422 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS), 3423 "Parentheses missing around \"%s\" list", 3424 lex 3425 ? (PL_parser->in_my == KEY_our 3426 ? "our" 3427 : PL_parser->in_my == KEY_state 3428 ? "state" 3429 : "my") 3430 : "local"); 3431 } 3432 } 3433 } 3434 if (lex) 3435 o = my(o); 3436 else 3437 o = op_lvalue(o, OP_NULL); /* a bit kludgey */ 3438 PL_parser->in_my = FALSE; 3439 PL_parser->in_my_stash = NULL; 3440 return o; 3441 } 3442 3443 OP * 3444 Perl_jmaybe(pTHX_ OP *o) 3445 { 3446 PERL_ARGS_ASSERT_JMAYBE; 3447 3448 if (o->op_type == OP_LIST) { 3449 OP * const o2 3450 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV))); 3451 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o)); 3452 } 3453 return o; 3454 } 3455 3456 PERL_STATIC_INLINE OP * 3457 S_op_std_init(pTHX_ OP *o) 3458 { 3459 I32 type = o->op_type; 3460 3461 PERL_ARGS_ASSERT_OP_STD_INIT; 3462 3463 if (PL_opargs[type] & OA_RETSCALAR) 3464 scalar(o); 3465 if (PL_opargs[type] & OA_TARGET && !o->op_targ) 3466 o->op_targ = pad_alloc(type, SVs_PADTMP); 3467 3468 return o; 3469 } 3470 3471 PERL_STATIC_INLINE OP * 3472 S_op_integerize(pTHX_ OP *o) 3473 { 3474 I32 type = o->op_type; 3475 3476 PERL_ARGS_ASSERT_OP_INTEGERIZE; 3477 3478 /* integerize op. */ 3479 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)) 3480 { 3481 dVAR; 3482 o->op_ppaddr = PL_ppaddr[++(o->op_type)]; 3483 } 3484 3485 if (type == OP_NEGATE) 3486 /* XXX might want a ck_negate() for this */ 3487 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT; 3488 3489 return o; 3490 } 3491 3492 static OP * 3493 S_fold_constants(pTHX_ OP *o) 3494 { 3495 dVAR; 3496 OP * VOL curop; 3497 OP *newop; 3498 VOL I32 type = o->op_type; 3499 SV * VOL sv = NULL; 3500 int ret = 0; 3501 I32 oldscope; 3502 OP *old_next; 3503 SV * const oldwarnhook = PL_warnhook; 3504 SV * const olddiehook = PL_diehook; 3505 COP not_compiling; 3506 dJMPENV; 3507 3508 PERL_ARGS_ASSERT_FOLD_CONSTANTS; 3509 3510 if (!(PL_opargs[type] & OA_FOLDCONST)) 3511 goto nope; 3512 3513 switch (type) { 3514 case OP_UCFIRST: 3515 case OP_LCFIRST: 3516 case OP_UC: 3517 case OP_LC: 3518 case OP_FC: 3519 case OP_SLT: 3520 case OP_SGT: 3521 case OP_SLE: 3522 case OP_SGE: 3523 case OP_SCMP: 3524 case OP_SPRINTF: 3525 /* XXX what about the numeric ops? */ 3526 if (IN_LOCALE_COMPILETIME) 3527 goto nope; 3528 break; 3529 case OP_PACK: 3530 if (!cLISTOPo->op_first->op_sibling 3531 || cLISTOPo->op_first->op_sibling->op_type != OP_CONST) 3532 goto nope; 3533 { 3534 SV * const sv = cSVOPx_sv(cLISTOPo->op_first->op_sibling); 3535 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope; 3536 { 3537 const char *s = SvPVX_const(sv); 3538 while (s < SvEND(sv)) { 3539 if (*s == 'p' || *s == 'P') goto nope; 3540 s++; 3541 } 3542 } 3543 } 3544 break; 3545 case OP_REPEAT: 3546 if (o->op_private & OPpREPEAT_DOLIST) goto nope; 3547 break; 3548 case OP_SREFGEN: 3549 if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST 3550 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first))) 3551 goto nope; 3552 } 3553 3554 if (PL_parser && PL_parser->error_count) 3555 goto nope; /* Don't try to run w/ errors */ 3556 3557 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) { 3558 const OPCODE type = curop->op_type; 3559 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) && 3560 type != OP_LIST && 3561 type != OP_SCALAR && 3562 type != OP_NULL && 3563 type != OP_PUSHMARK) 3564 { 3565 goto nope; 3566 } 3567 } 3568 3569 curop = LINKLIST(o); 3570 old_next = o->op_next; 3571 o->op_next = 0; 3572 PL_op = curop; 3573 3574 oldscope = PL_scopestack_ix; 3575 create_eval_scope(G_FAKINGEVAL); 3576 3577 /* Verify that we don't need to save it: */ 3578 assert(PL_curcop == &PL_compiling); 3579 StructCopy(&PL_compiling, ¬_compiling, COP); 3580 PL_curcop = ¬_compiling; 3581 /* The above ensures that we run with all the correct hints of the 3582 currently compiling COP, but that IN_PERL_RUNTIME is not true. */ 3583 assert(IN_PERL_RUNTIME); 3584 PL_warnhook = PERL_WARNHOOK_FATAL; 3585 PL_diehook = NULL; 3586 JMPENV_PUSH(ret); 3587 3588 switch (ret) { 3589 case 0: 3590 CALLRUNOPS(aTHX); 3591 sv = *(PL_stack_sp--); 3592 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */ 3593 #ifdef PERL_MAD 3594 /* Can't simply swipe the SV from the pad, because that relies on 3595 the op being freed "real soon now". Under MAD, this doesn't 3596 happen (see the #ifdef below). */ 3597 sv = newSVsv(sv); 3598 #else 3599 pad_swipe(o->op_targ, FALSE); 3600 #endif 3601 } 3602 else if (SvTEMP(sv)) { /* grab mortal temp? */ 3603 SvREFCNT_inc_simple_void(sv); 3604 SvTEMP_off(sv); 3605 } 3606 else { assert(SvIMMORTAL(sv)); } 3607 break; 3608 case 3: 3609 /* Something tried to die. Abandon constant folding. */ 3610 /* Pretend the error never happened. */ 3611 CLEAR_ERRSV(); 3612 o->op_next = old_next; 3613 break; 3614 default: 3615 JMPENV_POP; 3616 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */ 3617 PL_warnhook = oldwarnhook; 3618 PL_diehook = olddiehook; 3619 /* XXX note that this croak may fail as we've already blown away 3620 * the stack - eg any nested evals */ 3621 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret); 3622 } 3623 JMPENV_POP; 3624 PL_warnhook = oldwarnhook; 3625 PL_diehook = olddiehook; 3626 PL_curcop = &PL_compiling; 3627 3628 if (PL_scopestack_ix > oldscope) 3629 delete_eval_scope(); 3630 3631 if (ret) 3632 goto nope; 3633 3634 #ifndef PERL_MAD 3635 op_free(o); 3636 #endif 3637 assert(sv); 3638 if (type == OP_STRINGIFY) SvPADTMP_off(sv); 3639 else if (!SvIMMORTAL(sv)) { 3640 SvPADTMP_on(sv); 3641 SvREADONLY_on(sv); 3642 } 3643 if (type == OP_RV2GV) 3644 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv)); 3645 else 3646 { 3647 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv)); 3648 if (type != OP_STRINGIFY) newop->op_folded = 1; 3649 } 3650 op_getmad(o,newop,'f'); 3651 return newop; 3652 3653 nope: 3654 return o; 3655 } 3656 3657 static OP * 3658 S_gen_constant_list(pTHX_ OP *o) 3659 { 3660 dVAR; 3661 OP *curop; 3662 const SSize_t oldtmps_floor = PL_tmps_floor; 3663 SV **svp; 3664 AV *av; 3665 3666 list(o); 3667 if (PL_parser && PL_parser->error_count) 3668 return o; /* Don't attempt to run with errors */ 3669 3670 curop = LINKLIST(o); 3671 o->op_next = 0; 3672 CALL_PEEP(curop); 3673 S_prune_chain_head(aTHX_ &curop); 3674 PL_op = curop; 3675 Perl_pp_pushmark(aTHX); 3676 CALLRUNOPS(aTHX); 3677 PL_op = curop; 3678 assert (!(curop->op_flags & OPf_SPECIAL)); 3679 assert(curop->op_type == OP_RANGE); 3680 Perl_pp_anonlist(aTHX); 3681 PL_tmps_floor = oldtmps_floor; 3682 3683 o->op_type = OP_RV2AV; 3684 o->op_ppaddr = PL_ppaddr[OP_RV2AV]; 3685 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */ 3686 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */ 3687 o->op_opt = 0; /* needs to be revisited in rpeep() */ 3688 curop = ((UNOP*)o)->op_first; 3689 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--); 3690 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, (SV *)av); 3691 if (AvFILLp(av) != -1) 3692 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp) 3693 { 3694 SvPADTMP_on(*svp); 3695 SvREADONLY_on(*svp); 3696 } 3697 #ifdef PERL_MAD 3698 op_getmad(curop,o,'O'); 3699 #else 3700 op_free(curop); 3701 #endif 3702 LINKLIST(o); 3703 return list(o); 3704 } 3705 3706 OP * 3707 Perl_convert(pTHX_ I32 type, I32 flags, OP *o) 3708 { 3709 dVAR; 3710 if (type < 0) type = -type, flags |= OPf_SPECIAL; 3711 if (!o || o->op_type != OP_LIST) 3712 o = newLISTOP(OP_LIST, 0, o, NULL); 3713 else 3714 o->op_flags &= ~OPf_WANT; 3715 3716 if (!(PL_opargs[type] & OA_MARK)) 3717 op_null(cLISTOPo->op_first); 3718 else { 3719 OP * const kid2 = cLISTOPo->op_first->op_sibling; 3720 if (kid2 && kid2->op_type == OP_COREARGS) { 3721 op_null(cLISTOPo->op_first); 3722 kid2->op_private |= OPpCOREARGS_PUSHMARK; 3723 } 3724 } 3725 3726 o->op_type = (OPCODE)type; 3727 o->op_ppaddr = PL_ppaddr[type]; 3728 o->op_flags |= flags; 3729 3730 o = CHECKOP(type, o); 3731 if (o->op_type != (unsigned)type) 3732 return o; 3733 3734 return fold_constants(op_integerize(op_std_init(o))); 3735 } 3736 3737 /* 3738 =head1 Optree Manipulation Functions 3739 */ 3740 3741 /* List constructors */ 3742 3743 /* 3744 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last 3745 3746 Append an item to the list of ops contained directly within a list-type 3747 op, returning the lengthened list. I<first> is the list-type op, 3748 and I<last> is the op to append to the list. I<optype> specifies the 3749 intended opcode for the list. If I<first> is not already a list of the 3750 right type, it will be upgraded into one. If either I<first> or I<last> 3751 is null, the other is returned unchanged. 3752 3753 =cut 3754 */ 3755 3756 OP * 3757 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last) 3758 { 3759 if (!first) 3760 return last; 3761 3762 if (!last) 3763 return first; 3764 3765 if (first->op_type != (unsigned)type 3766 || (type == OP_LIST && (first->op_flags & OPf_PARENS))) 3767 { 3768 return newLISTOP(type, 0, first, last); 3769 } 3770 3771 if (first->op_flags & OPf_KIDS) 3772 ((LISTOP*)first)->op_last->op_sibling = last; 3773 else { 3774 first->op_flags |= OPf_KIDS; 3775 ((LISTOP*)first)->op_first = last; 3776 } 3777 ((LISTOP*)first)->op_last = last; 3778 return first; 3779 } 3780 3781 /* 3782 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last 3783 3784 Concatenate the lists of ops contained directly within two list-type ops, 3785 returning the combined list. I<first> and I<last> are the list-type ops 3786 to concatenate. I<optype> specifies the intended opcode for the list. 3787 If either I<first> or I<last> is not already a list of the right type, 3788 it will be upgraded into one. If either I<first> or I<last> is null, 3789 the other is returned unchanged. 3790 3791 =cut 3792 */ 3793 3794 OP * 3795 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last) 3796 { 3797 if (!first) 3798 return last; 3799 3800 if (!last) 3801 return first; 3802 3803 if (first->op_type != (unsigned)type) 3804 return op_prepend_elem(type, first, last); 3805 3806 if (last->op_type != (unsigned)type) 3807 return op_append_elem(type, first, last); 3808 3809 ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first; 3810 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last; 3811 first->op_flags |= (last->op_flags & OPf_KIDS); 3812 3813 #ifdef PERL_MAD 3814 if (((LISTOP*)last)->op_first && first->op_madprop) { 3815 MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop; 3816 if (mp) { 3817 while (mp->mad_next) 3818 mp = mp->mad_next; 3819 mp->mad_next = first->op_madprop; 3820 } 3821 else { 3822 ((LISTOP*)last)->op_first->op_madprop = first->op_madprop; 3823 } 3824 } 3825 first->op_madprop = last->op_madprop; 3826 last->op_madprop = 0; 3827 #endif 3828 3829 S_op_destroy(aTHX_ last); 3830 3831 return first; 3832 } 3833 3834 /* 3835 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last 3836 3837 Prepend an item to the list of ops contained directly within a list-type 3838 op, returning the lengthened list. I<first> is the op to prepend to the 3839 list, and I<last> is the list-type op. I<optype> specifies the intended 3840 opcode for the list. If I<last> is not already a list of the right type, 3841 it will be upgraded into one. If either I<first> or I<last> is null, 3842 the other is returned unchanged. 3843 3844 =cut 3845 */ 3846 3847 OP * 3848 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last) 3849 { 3850 if (!first) 3851 return last; 3852 3853 if (!last) 3854 return first; 3855 3856 if (last->op_type == (unsigned)type) { 3857 if (type == OP_LIST) { /* already a PUSHMARK there */ 3858 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling; 3859 ((LISTOP*)last)->op_first->op_sibling = first; 3860 if (!(first->op_flags & OPf_PARENS)) 3861 last->op_flags &= ~OPf_PARENS; 3862 } 3863 else { 3864 if (!(last->op_flags & OPf_KIDS)) { 3865 ((LISTOP*)last)->op_last = first; 3866 last->op_flags |= OPf_KIDS; 3867 } 3868 first->op_sibling = ((LISTOP*)last)->op_first; 3869 ((LISTOP*)last)->op_first = first; 3870 } 3871 last->op_flags |= OPf_KIDS; 3872 return last; 3873 } 3874 3875 return newLISTOP(type, 0, first, last); 3876 } 3877 3878 /* Constructors */ 3879 3880 #ifdef PERL_MAD 3881 3882 TOKEN * 3883 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop) 3884 { 3885 TOKEN *tk; 3886 Newxz(tk, 1, TOKEN); 3887 tk->tk_type = (OPCODE)optype; 3888 tk->tk_type = 12345; 3889 tk->tk_lval = lval; 3890 tk->tk_mad = madprop; 3891 return tk; 3892 } 3893 3894 void 3895 Perl_token_free(pTHX_ TOKEN* tk) 3896 { 3897 PERL_ARGS_ASSERT_TOKEN_FREE; 3898 3899 if (tk->tk_type != 12345) 3900 return; 3901 mad_free(tk->tk_mad); 3902 Safefree(tk); 3903 } 3904 3905 void 3906 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot) 3907 { 3908 MADPROP* mp; 3909 MADPROP* tm; 3910 3911 PERL_ARGS_ASSERT_TOKEN_GETMAD; 3912 3913 if (tk->tk_type != 12345) { 3914 Perl_warner(aTHX_ packWARN(WARN_MISC), 3915 "Invalid TOKEN object ignored"); 3916 return; 3917 } 3918 tm = tk->tk_mad; 3919 if (!tm) 3920 return; 3921 3922 /* faked up qw list? */ 3923 if (slot == '(' && 3924 tm->mad_type == MAD_SV && 3925 SvPVX((SV *)tm->mad_val)[0] == 'q') 3926 slot = 'x'; 3927 3928 if (o) { 3929 mp = o->op_madprop; 3930 if (mp) { 3931 for (;;) { 3932 /* pretend constant fold didn't happen? */ 3933 if (mp->mad_key == 'f' && 3934 (o->op_type == OP_CONST || 3935 o->op_type == OP_GV) ) 3936 { 3937 token_getmad(tk,(OP*)mp->mad_val,slot); 3938 return; 3939 } 3940 if (!mp->mad_next) 3941 break; 3942 mp = mp->mad_next; 3943 } 3944 mp->mad_next = tm; 3945 mp = mp->mad_next; 3946 } 3947 else { 3948 o->op_madprop = tm; 3949 mp = o->op_madprop; 3950 } 3951 if (mp->mad_key == 'X') 3952 mp->mad_key = slot; /* just change the first one */ 3953 3954 tk->tk_mad = 0; 3955 } 3956 else 3957 mad_free(tm); 3958 Safefree(tk); 3959 } 3960 3961 void 3962 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot) 3963 { 3964 MADPROP* mp; 3965 if (!from) 3966 return; 3967 if (o) { 3968 mp = o->op_madprop; 3969 if (mp) { 3970 for (;;) { 3971 /* pretend constant fold didn't happen? */ 3972 if (mp->mad_key == 'f' && 3973 (o->op_type == OP_CONST || 3974 o->op_type == OP_GV) ) 3975 { 3976 op_getmad(from,(OP*)mp->mad_val,slot); 3977 return; 3978 } 3979 if (!mp->mad_next) 3980 break; 3981 mp = mp->mad_next; 3982 } 3983 mp->mad_next = newMADPROP(slot,MAD_OP,from,0); 3984 } 3985 else { 3986 o->op_madprop = newMADPROP(slot,MAD_OP,from,0); 3987 } 3988 } 3989 } 3990 3991 void 3992 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot) 3993 { 3994 MADPROP* mp; 3995 if (!from) 3996 return; 3997 if (o) { 3998 mp = o->op_madprop; 3999 if (mp) { 4000 for (;;) { 4001 /* pretend constant fold didn't happen? */ 4002 if (mp->mad_key == 'f' && 4003 (o->op_type == OP_CONST || 4004 o->op_type == OP_GV) ) 4005 { 4006 op_getmad(from,(OP*)mp->mad_val,slot); 4007 return; 4008 } 4009 if (!mp->mad_next) 4010 break; 4011 mp = mp->mad_next; 4012 } 4013 mp->mad_next = newMADPROP(slot,MAD_OP,from,1); 4014 } 4015 else { 4016 o->op_madprop = newMADPROP(slot,MAD_OP,from,1); 4017 } 4018 } 4019 else { 4020 PerlIO_printf(PerlIO_stderr(), 4021 "DESTROYING op = %0"UVxf"\n", PTR2UV(from)); 4022 op_free(from); 4023 } 4024 } 4025 4026 void 4027 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot) 4028 { 4029 MADPROP* tm; 4030 if (!mp || !o) 4031 return; 4032 if (slot) 4033 mp->mad_key = slot; 4034 tm = o->op_madprop; 4035 o->op_madprop = mp; 4036 for (;;) { 4037 if (!mp->mad_next) 4038 break; 4039 mp = mp->mad_next; 4040 } 4041 mp->mad_next = tm; 4042 } 4043 4044 void 4045 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot) 4046 { 4047 if (!o) 4048 return; 4049 addmad(tm, &(o->op_madprop), slot); 4050 } 4051 4052 void 4053 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot) 4054 { 4055 MADPROP* mp; 4056 if (!tm || !root) 4057 return; 4058 if (slot) 4059 tm->mad_key = slot; 4060 mp = *root; 4061 if (!mp) { 4062 *root = tm; 4063 return; 4064 } 4065 for (;;) { 4066 if (!mp->mad_next) 4067 break; 4068 mp = mp->mad_next; 4069 } 4070 mp->mad_next = tm; 4071 } 4072 4073 MADPROP * 4074 Perl_newMADsv(pTHX_ char key, SV* sv) 4075 { 4076 PERL_ARGS_ASSERT_NEWMADSV; 4077 4078 return newMADPROP(key, MAD_SV, sv, 0); 4079 } 4080 4081 MADPROP * 4082 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen) 4083 { 4084 MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP)); 4085 mp->mad_next = 0; 4086 mp->mad_key = key; 4087 mp->mad_vlen = vlen; 4088 mp->mad_type = type; 4089 mp->mad_val = val; 4090 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */ 4091 return mp; 4092 } 4093 4094 void 4095 Perl_mad_free(pTHX_ MADPROP* mp) 4096 { 4097 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */ 4098 if (!mp) 4099 return; 4100 if (mp->mad_next) 4101 mad_free(mp->mad_next); 4102 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen) 4103 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */ 4104 switch (mp->mad_type) { 4105 case MAD_NULL: 4106 break; 4107 case MAD_PV: 4108 Safefree(mp->mad_val); 4109 break; 4110 case MAD_OP: 4111 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */ 4112 op_free((OP*)mp->mad_val); 4113 break; 4114 case MAD_SV: 4115 sv_free(MUTABLE_SV(mp->mad_val)); 4116 break; 4117 default: 4118 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n"); 4119 break; 4120 } 4121 PerlMemShared_free(mp); 4122 } 4123 4124 #endif 4125 4126 /* 4127 =head1 Optree construction 4128 4129 =for apidoc Am|OP *|newNULLLIST 4130 4131 Constructs, checks, and returns a new C<stub> op, which represents an 4132 empty list expression. 4133 4134 =cut 4135 */ 4136 4137 OP * 4138 Perl_newNULLLIST(pTHX) 4139 { 4140 return newOP(OP_STUB, 0); 4141 } 4142 4143 static OP * 4144 S_force_list(pTHX_ OP *o) 4145 { 4146 if (!o || o->op_type != OP_LIST) 4147 o = newLISTOP(OP_LIST, 0, o, NULL); 4148 op_null(o); 4149 return o; 4150 } 4151 4152 /* 4153 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last 4154 4155 Constructs, checks, and returns an op of any list type. I<type> is 4156 the opcode. I<flags> gives the eight bits of C<op_flags>, except that 4157 C<OPf_KIDS> will be set automatically if required. I<first> and I<last> 4158 supply up to two ops to be direct children of the list op; they are 4159 consumed by this function and become part of the constructed op tree. 4160 4161 =cut 4162 */ 4163 4164 OP * 4165 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) 4166 { 4167 dVAR; 4168 LISTOP *listop; 4169 4170 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP); 4171 4172 NewOp(1101, listop, 1, LISTOP); 4173 4174 listop->op_type = (OPCODE)type; 4175 listop->op_ppaddr = PL_ppaddr[type]; 4176 if (first || last) 4177 flags |= OPf_KIDS; 4178 listop->op_flags = (U8)flags; 4179 4180 if (!last && first) 4181 last = first; 4182 else if (!first && last) 4183 first = last; 4184 else if (first) 4185 first->op_sibling = last; 4186 listop->op_first = first; 4187 listop->op_last = last; 4188 if (type == OP_LIST) { 4189 OP* const pushop = newOP(OP_PUSHMARK, 0); 4190 pushop->op_sibling = first; 4191 listop->op_first = pushop; 4192 listop->op_flags |= OPf_KIDS; 4193 if (!last) 4194 listop->op_last = pushop; 4195 } 4196 4197 return CHECKOP(type, listop); 4198 } 4199 4200 /* 4201 =for apidoc Am|OP *|newOP|I32 type|I32 flags 4202 4203 Constructs, checks, and returns an op of any base type (any type that 4204 has no extra fields). I<type> is the opcode. I<flags> gives the 4205 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits 4206 of C<op_private>. 4207 4208 =cut 4209 */ 4210 4211 OP * 4212 Perl_newOP(pTHX_ I32 type, I32 flags) 4213 { 4214 dVAR; 4215 OP *o; 4216 4217 if (type == -OP_ENTEREVAL) { 4218 type = OP_ENTEREVAL; 4219 flags |= OPpEVAL_BYTES<<8; 4220 } 4221 4222 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP 4223 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP 4224 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP 4225 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP); 4226 4227 NewOp(1101, o, 1, OP); 4228 o->op_type = (OPCODE)type; 4229 o->op_ppaddr = PL_ppaddr[type]; 4230 o->op_flags = (U8)flags; 4231 4232 o->op_next = o; 4233 o->op_private = (U8)(0 | (flags >> 8)); 4234 if (PL_opargs[type] & OA_RETSCALAR) 4235 scalar(o); 4236 if (PL_opargs[type] & OA_TARGET) 4237 o->op_targ = pad_alloc(type, SVs_PADTMP); 4238 return CHECKOP(type, o); 4239 } 4240 4241 /* 4242 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first 4243 4244 Constructs, checks, and returns an op of any unary type. I<type> is 4245 the opcode. I<flags> gives the eight bits of C<op_flags>, except that 4246 C<OPf_KIDS> will be set automatically if required, and, shifted up eight 4247 bits, the eight bits of C<op_private>, except that the bit with value 1 4248 is automatically set. I<first> supplies an optional op to be the direct 4249 child of the unary op; it is consumed by this function and become part 4250 of the constructed op tree. 4251 4252 =cut 4253 */ 4254 4255 OP * 4256 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) 4257 { 4258 dVAR; 4259 UNOP *unop; 4260 4261 if (type == -OP_ENTEREVAL) { 4262 type = OP_ENTEREVAL; 4263 flags |= OPpEVAL_BYTES<<8; 4264 } 4265 4266 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP 4267 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP 4268 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP 4269 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP 4270 || type == OP_SASSIGN 4271 || type == OP_ENTERTRY 4272 || type == OP_NULL ); 4273 4274 if (!first) 4275 first = newOP(OP_STUB, 0); 4276 if (PL_opargs[type] & OA_MARK) 4277 first = force_list(first); 4278 4279 NewOp(1101, unop, 1, UNOP); 4280 unop->op_type = (OPCODE)type; 4281 unop->op_ppaddr = PL_ppaddr[type]; 4282 unop->op_first = first; 4283 unop->op_flags = (U8)(flags | OPf_KIDS); 4284 unop->op_private = (U8)(1 | (flags >> 8)); 4285 unop = (UNOP*) CHECKOP(type, unop); 4286 if (unop->op_next) 4287 return (OP*)unop; 4288 4289 return fold_constants(op_integerize(op_std_init((OP *) unop))); 4290 } 4291 4292 /* 4293 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last 4294 4295 Constructs, checks, and returns an op of any binary type. I<type> 4296 is the opcode. I<flags> gives the eight bits of C<op_flags>, except 4297 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits, 4298 the eight bits of C<op_private>, except that the bit with value 1 or 4299 2 is automatically set as required. I<first> and I<last> supply up to 4300 two ops to be the direct children of the binary op; they are consumed 4301 by this function and become part of the constructed op tree. 4302 4303 =cut 4304 */ 4305 4306 OP * 4307 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) 4308 { 4309 dVAR; 4310 BINOP *binop; 4311 4312 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP 4313 || type == OP_SASSIGN || type == OP_NULL ); 4314 4315 NewOp(1101, binop, 1, BINOP); 4316 4317 if (!first) 4318 first = newOP(OP_NULL, 0); 4319 4320 binop->op_type = (OPCODE)type; 4321 binop->op_ppaddr = PL_ppaddr[type]; 4322 binop->op_first = first; 4323 binop->op_flags = (U8)(flags | OPf_KIDS); 4324 if (!last) { 4325 last = first; 4326 binop->op_private = (U8)(1 | (flags >> 8)); 4327 } 4328 else { 4329 binop->op_private = (U8)(2 | (flags >> 8)); 4330 first->op_sibling = last; 4331 } 4332 4333 binop = (BINOP*)CHECKOP(type, binop); 4334 if (binop->op_next || binop->op_type != (OPCODE)type) 4335 return (OP*)binop; 4336 4337 binop->op_last = binop->op_first->op_sibling; 4338 4339 return fold_constants(op_integerize(op_std_init((OP *)binop))); 4340 } 4341 4342 static int uvcompare(const void *a, const void *b) 4343 __attribute__nonnull__(1) 4344 __attribute__nonnull__(2) 4345 __attribute__pure__; 4346 static int uvcompare(const void *a, const void *b) 4347 { 4348 if (*((const UV *)a) < (*(const UV *)b)) 4349 return -1; 4350 if (*((const UV *)a) > (*(const UV *)b)) 4351 return 1; 4352 if (*((const UV *)a+1) < (*(const UV *)b+1)) 4353 return -1; 4354 if (*((const UV *)a+1) > (*(const UV *)b+1)) 4355 return 1; 4356 return 0; 4357 } 4358 4359 static OP * 4360 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) 4361 { 4362 dVAR; 4363 SV * const tstr = ((SVOP*)expr)->op_sv; 4364 SV * const rstr = 4365 #ifdef PERL_MAD 4366 (repl->op_type == OP_NULL) 4367 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv : 4368 #endif 4369 ((SVOP*)repl)->op_sv; 4370 STRLEN tlen; 4371 STRLEN rlen; 4372 const U8 *t = (U8*)SvPV_const(tstr, tlen); 4373 const U8 *r = (U8*)SvPV_const(rstr, rlen); 4374 I32 i; 4375 I32 j; 4376 I32 grows = 0; 4377 short *tbl; 4378 4379 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT; 4380 const I32 squash = o->op_private & OPpTRANS_SQUASH; 4381 I32 del = o->op_private & OPpTRANS_DELETE; 4382 SV* swash; 4383 4384 PERL_ARGS_ASSERT_PMTRANS; 4385 4386 PL_hints |= HINT_BLOCK_SCOPE; 4387 4388 if (SvUTF8(tstr)) 4389 o->op_private |= OPpTRANS_FROM_UTF; 4390 4391 if (SvUTF8(rstr)) 4392 o->op_private |= OPpTRANS_TO_UTF; 4393 4394 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) { 4395 SV* const listsv = newSVpvs("# comment\n"); 4396 SV* transv = NULL; 4397 const U8* tend = t + tlen; 4398 const U8* rend = r + rlen; 4399 STRLEN ulen; 4400 UV tfirst = 1; 4401 UV tlast = 0; 4402 IV tdiff; 4403 UV rfirst = 1; 4404 UV rlast = 0; 4405 IV rdiff; 4406 IV diff; 4407 I32 none = 0; 4408 U32 max = 0; 4409 I32 bits; 4410 I32 havefinal = 0; 4411 U32 final = 0; 4412 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF; 4413 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF; 4414 U8* tsave = NULL; 4415 U8* rsave = NULL; 4416 const U32 flags = UTF8_ALLOW_DEFAULT; 4417 4418 if (!from_utf) { 4419 STRLEN len = tlen; 4420 t = tsave = bytes_to_utf8(t, &len); 4421 tend = t + len; 4422 } 4423 if (!to_utf && rlen) { 4424 STRLEN len = rlen; 4425 r = rsave = bytes_to_utf8(r, &len); 4426 rend = r + len; 4427 } 4428 4429 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has 4430 * encoded chars in native encoding which makes ranges in the EBCDIC 0..255 4431 * odd. */ 4432 4433 if (complement) { 4434 U8 tmpbuf[UTF8_MAXBYTES+1]; 4435 UV *cp; 4436 UV nextmin = 0; 4437 Newx(cp, 2*tlen, UV); 4438 i = 0; 4439 transv = newSVpvs(""); 4440 while (t < tend) { 4441 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags); 4442 t += ulen; 4443 if (t < tend && *t == ILLEGAL_UTF8_BYTE) { 4444 t++; 4445 cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags); 4446 t += ulen; 4447 } 4448 else { 4449 cp[2*i+1] = cp[2*i]; 4450 } 4451 i++; 4452 } 4453 qsort(cp, i, 2*sizeof(UV), uvcompare); 4454 for (j = 0; j < i; j++) { 4455 UV val = cp[2*j]; 4456 diff = val - nextmin; 4457 if (diff > 0) { 4458 t = uvchr_to_utf8(tmpbuf,nextmin); 4459 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); 4460 if (diff > 1) { 4461 U8 range_mark = ILLEGAL_UTF8_BYTE; 4462 t = uvchr_to_utf8(tmpbuf, val - 1); 4463 sv_catpvn(transv, (char *)&range_mark, 1); 4464 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); 4465 } 4466 } 4467 val = cp[2*j+1]; 4468 if (val >= nextmin) 4469 nextmin = val + 1; 4470 } 4471 t = uvchr_to_utf8(tmpbuf,nextmin); 4472 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); 4473 { 4474 U8 range_mark = ILLEGAL_UTF8_BYTE; 4475 sv_catpvn(transv, (char *)&range_mark, 1); 4476 } 4477 t = uvchr_to_utf8(tmpbuf, 0x7fffffff); 4478 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); 4479 t = (const U8*)SvPVX_const(transv); 4480 tlen = SvCUR(transv); 4481 tend = t + tlen; 4482 Safefree(cp); 4483 } 4484 else if (!rlen && !del) { 4485 r = t; rlen = tlen; rend = tend; 4486 } 4487 if (!squash) { 4488 if ((!rlen && !del) || t == r || 4489 (tlen == rlen && memEQ((char *)t, (char *)r, tlen))) 4490 { 4491 o->op_private |= OPpTRANS_IDENTICAL; 4492 } 4493 } 4494 4495 while (t < tend || tfirst <= tlast) { 4496 /* see if we need more "t" chars */ 4497 if (tfirst > tlast) { 4498 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags); 4499 t += ulen; 4500 if (t < tend && *t == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */ 4501 t++; 4502 tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags); 4503 t += ulen; 4504 } 4505 else 4506 tlast = tfirst; 4507 } 4508 4509 /* now see if we need more "r" chars */ 4510 if (rfirst > rlast) { 4511 if (r < rend) { 4512 rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags); 4513 r += ulen; 4514 if (r < rend && *r == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */ 4515 r++; 4516 rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags); 4517 r += ulen; 4518 } 4519 else 4520 rlast = rfirst; 4521 } 4522 else { 4523 if (!havefinal++) 4524 final = rlast; 4525 rfirst = rlast = 0xffffffff; 4526 } 4527 } 4528 4529 /* now see which range will peter our first, if either. */ 4530 tdiff = tlast - tfirst; 4531 rdiff = rlast - rfirst; 4532 4533 if (tdiff <= rdiff) 4534 diff = tdiff; 4535 else 4536 diff = rdiff; 4537 4538 if (rfirst == 0xffffffff) { 4539 diff = tdiff; /* oops, pretend rdiff is infinite */ 4540 if (diff > 0) 4541 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n", 4542 (long)tfirst, (long)tlast); 4543 else 4544 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst); 4545 } 4546 else { 4547 if (diff > 0) 4548 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n", 4549 (long)tfirst, (long)(tfirst + diff), 4550 (long)rfirst); 4551 else 4552 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n", 4553 (long)tfirst, (long)rfirst); 4554 4555 if (rfirst + diff > max) 4556 max = rfirst + diff; 4557 if (!grows) 4558 grows = (tfirst < rfirst && 4559 UNISKIP(tfirst) < UNISKIP(rfirst + diff)); 4560 rfirst += diff + 1; 4561 } 4562 tfirst += diff + 1; 4563 } 4564 4565 none = ++max; 4566 if (del) 4567 del = ++max; 4568 4569 if (max > 0xffff) 4570 bits = 32; 4571 else if (max > 0xff) 4572 bits = 16; 4573 else 4574 bits = 8; 4575 4576 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none)); 4577 #ifdef USE_ITHREADS 4578 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY); 4579 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix)); 4580 PAD_SETSV(cPADOPo->op_padix, swash); 4581 SvPADTMP_on(swash); 4582 SvREADONLY_on(swash); 4583 #else 4584 cSVOPo->op_sv = swash; 4585 #endif 4586 SvREFCNT_dec(listsv); 4587 SvREFCNT_dec(transv); 4588 4589 if (!del && havefinal && rlen) 4590 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5, 4591 newSVuv((UV)final), 0); 4592 4593 if (grows) 4594 o->op_private |= OPpTRANS_GROWS; 4595 4596 Safefree(tsave); 4597 Safefree(rsave); 4598 4599 #ifdef PERL_MAD 4600 op_getmad(expr,o,'e'); 4601 op_getmad(repl,o,'r'); 4602 #else 4603 op_free(expr); 4604 op_free(repl); 4605 #endif 4606 return o; 4607 } 4608 4609 tbl = (short*)PerlMemShared_calloc( 4610 (o->op_private & OPpTRANS_COMPLEMENT) && 4611 !(o->op_private & OPpTRANS_DELETE) ? 258 : 256, 4612 sizeof(short)); 4613 cPVOPo->op_pv = (char*)tbl; 4614 if (complement) { 4615 for (i = 0; i < (I32)tlen; i++) 4616 tbl[t[i]] = -1; 4617 for (i = 0, j = 0; i < 256; i++) { 4618 if (!tbl[i]) { 4619 if (j >= (I32)rlen) { 4620 if (del) 4621 tbl[i] = -2; 4622 else if (rlen) 4623 tbl[i] = r[j-1]; 4624 else 4625 tbl[i] = (short)i; 4626 } 4627 else { 4628 if (i < 128 && r[j] >= 128) 4629 grows = 1; 4630 tbl[i] = r[j++]; 4631 } 4632 } 4633 } 4634 if (!del) { 4635 if (!rlen) { 4636 j = rlen; 4637 if (!squash) 4638 o->op_private |= OPpTRANS_IDENTICAL; 4639 } 4640 else if (j >= (I32)rlen) 4641 j = rlen - 1; 4642 else { 4643 tbl = 4644 (short *) 4645 PerlMemShared_realloc(tbl, 4646 (0x101+rlen-j) * sizeof(short)); 4647 cPVOPo->op_pv = (char*)tbl; 4648 } 4649 tbl[0x100] = (short)(rlen - j); 4650 for (i=0; i < (I32)rlen - j; i++) 4651 tbl[0x101+i] = r[j+i]; 4652 } 4653 } 4654 else { 4655 if (!rlen && !del) { 4656 r = t; rlen = tlen; 4657 if (!squash) 4658 o->op_private |= OPpTRANS_IDENTICAL; 4659 } 4660 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) { 4661 o->op_private |= OPpTRANS_IDENTICAL; 4662 } 4663 for (i = 0; i < 256; i++) 4664 tbl[i] = -1; 4665 for (i = 0, j = 0; i < (I32)tlen; i++,j++) { 4666 if (j >= (I32)rlen) { 4667 if (del) { 4668 if (tbl[t[i]] == -1) 4669 tbl[t[i]] = -2; 4670 continue; 4671 } 4672 --j; 4673 } 4674 if (tbl[t[i]] == -1) { 4675 if (t[i] < 128 && r[j] >= 128) 4676 grows = 1; 4677 tbl[t[i]] = r[j]; 4678 } 4679 } 4680 } 4681 4682 if(del && rlen == tlen) { 4683 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator"); 4684 } else if(rlen > tlen && !complement) { 4685 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list"); 4686 } 4687 4688 if (grows) 4689 o->op_private |= OPpTRANS_GROWS; 4690 #ifdef PERL_MAD 4691 op_getmad(expr,o,'e'); 4692 op_getmad(repl,o,'r'); 4693 #else 4694 op_free(expr); 4695 op_free(repl); 4696 #endif 4697 4698 return o; 4699 } 4700 4701 /* 4702 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags 4703 4704 Constructs, checks, and returns an op of any pattern matching type. 4705 I<type> is the opcode. I<flags> gives the eight bits of C<op_flags> 4706 and, shifted up eight bits, the eight bits of C<op_private>. 4707 4708 =cut 4709 */ 4710 4711 OP * 4712 Perl_newPMOP(pTHX_ I32 type, I32 flags) 4713 { 4714 dVAR; 4715 PMOP *pmop; 4716 4717 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP); 4718 4719 NewOp(1101, pmop, 1, PMOP); 4720 pmop->op_type = (OPCODE)type; 4721 pmop->op_ppaddr = PL_ppaddr[type]; 4722 pmop->op_flags = (U8)flags; 4723 pmop->op_private = (U8)(0 | (flags >> 8)); 4724 4725 if (PL_hints & HINT_RE_TAINT) 4726 pmop->op_pmflags |= PMf_RETAINT; 4727 if (IN_LOCALE_COMPILETIME) { 4728 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET); 4729 } 4730 else if ((! (PL_hints & HINT_BYTES)) 4731 /* Both UNI_8_BIT and locale :not_characters imply Unicode */ 4732 && (PL_hints & (HINT_UNI_8_BIT|HINT_LOCALE_NOT_CHARS))) 4733 { 4734 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET); 4735 } 4736 if (PL_hints & HINT_RE_FLAGS) { 4737 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_ 4738 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0 4739 ); 4740 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags); 4741 reflags = Perl_refcounted_he_fetch_pvn(aTHX_ 4742 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0 4743 ); 4744 if (reflags && SvOK(reflags)) { 4745 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags)); 4746 } 4747 } 4748 4749 4750 #ifdef USE_ITHREADS 4751 assert(SvPOK(PL_regex_pad[0])); 4752 if (SvCUR(PL_regex_pad[0])) { 4753 /* Pop off the "packed" IV from the end. */ 4754 SV *const repointer_list = PL_regex_pad[0]; 4755 const char *p = SvEND(repointer_list) - sizeof(IV); 4756 const IV offset = *((IV*)p); 4757 4758 assert(SvCUR(repointer_list) % sizeof(IV) == 0); 4759 4760 SvEND_set(repointer_list, p); 4761 4762 pmop->op_pmoffset = offset; 4763 /* This slot should be free, so assert this: */ 4764 assert(PL_regex_pad[offset] == &PL_sv_undef); 4765 } else { 4766 SV * const repointer = &PL_sv_undef; 4767 av_push(PL_regex_padav, repointer); 4768 pmop->op_pmoffset = av_tindex(PL_regex_padav); 4769 PL_regex_pad = AvARRAY(PL_regex_padav); 4770 } 4771 #endif 4772 4773 return CHECKOP(type, pmop); 4774 } 4775 4776 /* Given some sort of match op o, and an expression expr containing a 4777 * pattern, either compile expr into a regex and attach it to o (if it's 4778 * constant), or convert expr into a runtime regcomp op sequence (if it's 4779 * not) 4780 * 4781 * isreg indicates that the pattern is part of a regex construct, eg 4782 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or 4783 * split "pattern", which aren't. In the former case, expr will be a list 4784 * if the pattern contains more than one term (eg /a$b/) or if it contains 4785 * a replacement, ie s/// or tr///. 4786 * 4787 * When the pattern has been compiled within a new anon CV (for 4788 * qr/(?{...})/ ), then floor indicates the savestack level just before 4789 * the new sub was created 4790 */ 4791 4792 OP * 4793 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) 4794 { 4795 dVAR; 4796 PMOP *pm; 4797 LOGOP *rcop; 4798 I32 repl_has_vars = 0; 4799 OP* repl = NULL; 4800 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR); 4801 bool is_compiletime; 4802 bool has_code; 4803 4804 PERL_ARGS_ASSERT_PMRUNTIME; 4805 4806 /* for s/// and tr///, last element in list is the replacement; pop it */ 4807 4808 /* If we have a syntax error causing tokens to be popped and the parser 4809 to see PMFUNC '(' expr ')' with no commas in it; e.g., s/${<>{})//, 4810 then expr will not be of type OP_LIST, there being no repl. */ 4811 if ((is_trans || o->op_type == OP_SUBST) && expr->op_type == OP_LIST) { 4812 OP* kid; 4813 repl = cLISTOPx(expr)->op_last; 4814 kid = cLISTOPx(expr)->op_first; 4815 while (kid->op_sibling != repl) 4816 kid = kid->op_sibling; 4817 kid->op_sibling = NULL; 4818 cLISTOPx(expr)->op_last = kid; 4819 } 4820 4821 /* for TRANS, convert LIST/PUSH/CONST into CONST, and pass to pmtrans() */ 4822 4823 if (is_trans) { 4824 OP* const oe = expr; 4825 assert(expr->op_type == OP_LIST); 4826 assert(cLISTOPx(expr)->op_first->op_type == OP_PUSHMARK); 4827 assert(cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last); 4828 expr = cLISTOPx(oe)->op_last; 4829 cLISTOPx(oe)->op_first->op_sibling = NULL; 4830 cLISTOPx(oe)->op_last = NULL; 4831 op_free(oe); 4832 4833 return pmtrans(o, expr, repl); 4834 } 4835 4836 /* find whether we have any runtime or code elements; 4837 * at the same time, temporarily set the op_next of each DO block; 4838 * then when we LINKLIST, this will cause the DO blocks to be excluded 4839 * from the op_next chain (and from having LINKLIST recursively 4840 * applied to them). We fix up the DOs specially later */ 4841 4842 is_compiletime = 1; 4843 has_code = 0; 4844 if (expr->op_type == OP_LIST) { 4845 OP *o; 4846 for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) { 4847 if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) { 4848 has_code = 1; 4849 assert(!o->op_next && o->op_sibling); 4850 o->op_next = o->op_sibling; 4851 } 4852 else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK) 4853 is_compiletime = 0; 4854 } 4855 } 4856 else if (expr->op_type != OP_CONST) 4857 is_compiletime = 0; 4858 4859 LINKLIST(expr); 4860 4861 /* fix up DO blocks; treat each one as a separate little sub; 4862 * also, mark any arrays as LIST/REF */ 4863 4864 if (expr->op_type == OP_LIST) { 4865 OP *o; 4866 for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) { 4867 4868 if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) { 4869 assert( !(o->op_flags & OPf_WANT)); 4870 /* push the array rather than its contents. The regex 4871 * engine will retrieve and join the elements later */ 4872 o->op_flags |= (OPf_WANT_LIST | OPf_REF); 4873 continue; 4874 } 4875 4876 if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL))) 4877 continue; 4878 o->op_next = NULL; /* undo temporary hack from above */ 4879 scalar(o); 4880 LINKLIST(o); 4881 if (cLISTOPo->op_first->op_type == OP_LEAVE) { 4882 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first); 4883 /* skip ENTER */ 4884 assert(leaveop->op_first->op_type == OP_ENTER); 4885 assert(leaveop->op_first->op_sibling); 4886 o->op_next = leaveop->op_first->op_sibling; 4887 /* skip leave */ 4888 assert(leaveop->op_flags & OPf_KIDS); 4889 assert(leaveop->op_last->op_next == (OP*)leaveop); 4890 leaveop->op_next = NULL; /* stop on last op */ 4891 op_null((OP*)leaveop); 4892 } 4893 else { 4894 /* skip SCOPE */ 4895 OP *scope = cLISTOPo->op_first; 4896 assert(scope->op_type == OP_SCOPE); 4897 assert(scope->op_flags & OPf_KIDS); 4898 scope->op_next = NULL; /* stop on last op */ 4899 op_null(scope); 4900 } 4901 /* have to peep the DOs individually as we've removed it from 4902 * the op_next chain */ 4903 CALL_PEEP(o); 4904 S_prune_chain_head(aTHX_ &(o->op_next)); 4905 if (is_compiletime) 4906 /* runtime finalizes as part of finalizing whole tree */ 4907 finalize_optree(o); 4908 } 4909 } 4910 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) { 4911 assert( !(expr->op_flags & OPf_WANT)); 4912 /* push the array rather than its contents. The regex 4913 * engine will retrieve and join the elements later */ 4914 expr->op_flags |= (OPf_WANT_LIST | OPf_REF); 4915 } 4916 4917 PL_hints |= HINT_BLOCK_SCOPE; 4918 pm = (PMOP*)o; 4919 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV)); 4920 4921 if (is_compiletime) { 4922 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME; 4923 regexp_engine const *eng = current_re_engine(); 4924 4925 if (o->op_flags & OPf_SPECIAL) 4926 rx_flags |= RXf_SPLIT; 4927 4928 if (!has_code || !eng->op_comp) { 4929 /* compile-time simple constant pattern */ 4930 4931 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) { 4932 /* whoops! we guessed that a qr// had a code block, but we 4933 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv 4934 * that isn't required now. Note that we have to be pretty 4935 * confident that nothing used that CV's pad while the 4936 * regex was parsed, except maybe op targets for \Q etc. 4937 * If there were any op targets, though, they should have 4938 * been stolen by constant folding. 4939 */ 4940 #ifdef DEBUGGING 4941 PADOFFSET i = 0; 4942 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0); 4943 while (++i <= AvFILLp(PL_comppad)) { 4944 assert(!PL_curpad[i]); 4945 } 4946 #endif 4947 /* But we know that one op is using this CV's slab. */ 4948 cv_forget_slab(PL_compcv); 4949 LEAVE_SCOPE(floor); 4950 pm->op_pmflags &= ~PMf_HAS_CV; 4951 } 4952 4953 PM_SETRE(pm, 4954 eng->op_comp 4955 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL, 4956 rx_flags, pm->op_pmflags) 4957 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL, 4958 rx_flags, pm->op_pmflags) 4959 ); 4960 #ifdef PERL_MAD 4961 op_getmad(expr,(OP*)pm,'e'); 4962 #else 4963 op_free(expr); 4964 #endif 4965 } 4966 else { 4967 /* compile-time pattern that includes literal code blocks */ 4968 REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL, 4969 rx_flags, 4970 (pm->op_pmflags | 4971 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0)) 4972 ); 4973 PM_SETRE(pm, re); 4974 if (pm->op_pmflags & PMf_HAS_CV) { 4975 CV *cv; 4976 /* this QR op (and the anon sub we embed it in) is never 4977 * actually executed. It's just a placeholder where we can 4978 * squirrel away expr in op_code_list without the peephole 4979 * optimiser etc processing it for a second time */ 4980 OP *qr = newPMOP(OP_QR, 0); 4981 ((PMOP*)qr)->op_code_list = expr; 4982 4983 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */ 4984 SvREFCNT_inc_simple_void(PL_compcv); 4985 cv = newATTRSUB(floor, 0, NULL, NULL, qr); 4986 ReANY(re)->qr_anoncv = cv; 4987 4988 /* attach the anon CV to the pad so that 4989 * pad_fixup_inner_anons() can find it */ 4990 (void)pad_add_anon(cv, o->op_type); 4991 SvREFCNT_inc_simple_void(cv); 4992 } 4993 else { 4994 pm->op_code_list = expr; 4995 } 4996 } 4997 } 4998 else { 4999 /* runtime pattern: build chain of regcomp etc ops */ 5000 bool reglist; 5001 PADOFFSET cv_targ = 0; 5002 5003 reglist = isreg && expr->op_type == OP_LIST; 5004 if (reglist) 5005 op_null(expr); 5006 5007 if (has_code) { 5008 pm->op_code_list = expr; 5009 /* don't free op_code_list; its ops are embedded elsewhere too */ 5010 pm->op_pmflags |= PMf_CODELIST_PRIVATE; 5011 } 5012 5013 if (o->op_flags & OPf_SPECIAL) 5014 pm->op_pmflags |= PMf_SPLIT; 5015 5016 /* the OP_REGCMAYBE is a placeholder in the non-threaded case 5017 * to allow its op_next to be pointed past the regcomp and 5018 * preceding stacking ops; 5019 * OP_REGCRESET is there to reset taint before executing the 5020 * stacking ops */ 5021 if (pm->op_pmflags & PMf_KEEP || TAINTING_get) 5022 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr); 5023 5024 if (pm->op_pmflags & PMf_HAS_CV) { 5025 /* we have a runtime qr with literal code. This means 5026 * that the qr// has been wrapped in a new CV, which 5027 * means that runtime consts, vars etc will have been compiled 5028 * against a new pad. So... we need to execute those ops 5029 * within the environment of the new CV. So wrap them in a call 5030 * to a new anon sub. i.e. for 5031 * 5032 * qr/a$b(?{...})/, 5033 * 5034 * we build an anon sub that looks like 5035 * 5036 * sub { "a", $b, '(?{...})' } 5037 * 5038 * and call it, passing the returned list to regcomp. 5039 * Or to put it another way, the list of ops that get executed 5040 * are: 5041 * 5042 * normal PMf_HAS_CV 5043 * ------ ------------------- 5044 * pushmark (for regcomp) 5045 * pushmark (for entersub) 5046 * pushmark (for refgen) 5047 * anoncode 5048 * refgen 5049 * entersub 5050 * regcreset regcreset 5051 * pushmark pushmark 5052 * const("a") const("a") 5053 * gvsv(b) gvsv(b) 5054 * const("(?{...})") const("(?{...})") 5055 * leavesub 5056 * regcomp regcomp 5057 */ 5058 5059 SvREFCNT_inc_simple_void(PL_compcv); 5060 CvLVALUE_on(PL_compcv); 5061 /* these lines are just an unrolled newANONATTRSUB */ 5062 expr = newSVOP(OP_ANONCODE, 0, 5063 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr))); 5064 cv_targ = expr->op_targ; 5065 expr = newUNOP(OP_REFGEN, 0, expr); 5066 5067 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)))); 5068 } 5069 5070 NewOp(1101, rcop, 1, LOGOP); 5071 rcop->op_type = OP_REGCOMP; 5072 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP]; 5073 rcop->op_first = scalar(expr); 5074 rcop->op_flags |= OPf_KIDS 5075 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0) 5076 | (reglist ? OPf_STACKED : 0); 5077 rcop->op_private = 0; 5078 rcop->op_other = o; 5079 rcop->op_targ = cv_targ; 5080 5081 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */ 5082 if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1; 5083 5084 /* establish postfix order */ 5085 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) { 5086 LINKLIST(expr); 5087 rcop->op_next = expr; 5088 ((UNOP*)expr)->op_first->op_next = (OP*)rcop; 5089 } 5090 else { 5091 rcop->op_next = LINKLIST(expr); 5092 expr->op_next = (OP*)rcop; 5093 } 5094 5095 op_prepend_elem(o->op_type, scalar((OP*)rcop), o); 5096 } 5097 5098 if (repl) { 5099 OP *curop = repl; 5100 bool konst; 5101 /* If we are looking at s//.../e with a single statement, get past 5102 the implicit do{}. */ 5103 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS 5104 && cUNOPx(curop)->op_first->op_type == OP_SCOPE 5105 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS) { 5106 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first; 5107 if (kid->op_type == OP_NULL && kid->op_sibling 5108 && !kid->op_sibling->op_sibling) 5109 curop = kid->op_sibling; 5110 } 5111 if (curop->op_type == OP_CONST) 5112 konst = TRUE; 5113 else if (( (curop->op_type == OP_RV2SV || 5114 curop->op_type == OP_RV2AV || 5115 curop->op_type == OP_RV2HV || 5116 curop->op_type == OP_RV2GV) 5117 && cUNOPx(curop)->op_first 5118 && cUNOPx(curop)->op_first->op_type == OP_GV ) 5119 || curop->op_type == OP_PADSV 5120 || curop->op_type == OP_PADAV 5121 || curop->op_type == OP_PADHV 5122 || curop->op_type == OP_PADANY) { 5123 repl_has_vars = 1; 5124 konst = TRUE; 5125 } 5126 else konst = FALSE; 5127 if (konst 5128 && !(repl_has_vars 5129 && (!PM_GETRE(pm) 5130 || !RX_PRELEN(PM_GETRE(pm)) 5131 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN))) 5132 { 5133 pm->op_pmflags |= PMf_CONST; /* const for long enough */ 5134 op_prepend_elem(o->op_type, scalar(repl), o); 5135 } 5136 else { 5137 NewOp(1101, rcop, 1, LOGOP); 5138 rcop->op_type = OP_SUBSTCONT; 5139 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT]; 5140 rcop->op_first = scalar(repl); 5141 rcop->op_flags |= OPf_KIDS; 5142 rcop->op_private = 1; 5143 rcop->op_other = o; 5144 5145 /* establish postfix order */ 5146 rcop->op_next = LINKLIST(repl); 5147 repl->op_next = (OP*)rcop; 5148 5149 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop); 5150 assert(!(pm->op_pmflags & PMf_ONCE)); 5151 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop); 5152 rcop->op_next = 0; 5153 } 5154 } 5155 5156 return (OP*)pm; 5157 } 5158 5159 /* 5160 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv 5161 5162 Constructs, checks, and returns an op of any type that involves an 5163 embedded SV. I<type> is the opcode. I<flags> gives the eight bits 5164 of C<op_flags>. I<sv> gives the SV to embed in the op; this function 5165 takes ownership of one reference to it. 5166 5167 =cut 5168 */ 5169 5170 OP * 5171 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv) 5172 { 5173 dVAR; 5174 SVOP *svop; 5175 5176 PERL_ARGS_ASSERT_NEWSVOP; 5177 5178 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP 5179 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP 5180 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP); 5181 5182 NewOp(1101, svop, 1, SVOP); 5183 svop->op_type = (OPCODE)type; 5184 svop->op_ppaddr = PL_ppaddr[type]; 5185 svop->op_sv = sv; 5186 svop->op_next = (OP*)svop; 5187 svop->op_flags = (U8)flags; 5188 svop->op_private = (U8)(0 | (flags >> 8)); 5189 if (PL_opargs[type] & OA_RETSCALAR) 5190 scalar((OP*)svop); 5191 if (PL_opargs[type] & OA_TARGET) 5192 svop->op_targ = pad_alloc(type, SVs_PADTMP); 5193 return CHECKOP(type, svop); 5194 } 5195 5196 #ifdef USE_ITHREADS 5197 5198 /* 5199 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv 5200 5201 Constructs, checks, and returns an op of any type that involves a 5202 reference to a pad element. I<type> is the opcode. I<flags> gives the 5203 eight bits of C<op_flags>. A pad slot is automatically allocated, and 5204 is populated with I<sv>; this function takes ownership of one reference 5205 to it. 5206 5207 This function only exists if Perl has been compiled to use ithreads. 5208 5209 =cut 5210 */ 5211 5212 OP * 5213 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) 5214 { 5215 dVAR; 5216 PADOP *padop; 5217 5218 PERL_ARGS_ASSERT_NEWPADOP; 5219 5220 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP 5221 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP 5222 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP); 5223 5224 NewOp(1101, padop, 1, PADOP); 5225 padop->op_type = (OPCODE)type; 5226 padop->op_ppaddr = PL_ppaddr[type]; 5227 padop->op_padix = pad_alloc(type, SVs_PADTMP); 5228 SvREFCNT_dec(PAD_SVl(padop->op_padix)); 5229 PAD_SETSV(padop->op_padix, sv); 5230 assert(sv); 5231 padop->op_next = (OP*)padop; 5232 padop->op_flags = (U8)flags; 5233 if (PL_opargs[type] & OA_RETSCALAR) 5234 scalar((OP*)padop); 5235 if (PL_opargs[type] & OA_TARGET) 5236 padop->op_targ = pad_alloc(type, SVs_PADTMP); 5237 return CHECKOP(type, padop); 5238 } 5239 5240 #endif /* USE_ITHREADS */ 5241 5242 /* 5243 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv 5244 5245 Constructs, checks, and returns an op of any type that involves an 5246 embedded reference to a GV. I<type> is the opcode. I<flags> gives the 5247 eight bits of C<op_flags>. I<gv> identifies the GV that the op should 5248 reference; calling this function does not transfer ownership of any 5249 reference to it. 5250 5251 =cut 5252 */ 5253 5254 OP * 5255 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv) 5256 { 5257 dVAR; 5258 5259 PERL_ARGS_ASSERT_NEWGVOP; 5260 5261 #ifdef USE_ITHREADS 5262 GvIN_PAD_on(gv); 5263 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv)); 5264 #else 5265 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv)); 5266 #endif 5267 } 5268 5269 /* 5270 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv 5271 5272 Constructs, checks, and returns an op of any type that involves an 5273 embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives 5274 the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which 5275 must have been allocated using C<PerlMemShared_malloc>; the memory will 5276 be freed when the op is destroyed. 5277 5278 =cut 5279 */ 5280 5281 OP * 5282 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv) 5283 { 5284 dVAR; 5285 const bool utf8 = cBOOL(flags & SVf_UTF8); 5286 PVOP *pvop; 5287 5288 flags &= ~SVf_UTF8; 5289 5290 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP 5291 || type == OP_RUNCV 5292 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP); 5293 5294 NewOp(1101, pvop, 1, PVOP); 5295 pvop->op_type = (OPCODE)type; 5296 pvop->op_ppaddr = PL_ppaddr[type]; 5297 pvop->op_pv = pv; 5298 pvop->op_next = (OP*)pvop; 5299 pvop->op_flags = (U8)flags; 5300 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0; 5301 if (PL_opargs[type] & OA_RETSCALAR) 5302 scalar((OP*)pvop); 5303 if (PL_opargs[type] & OA_TARGET) 5304 pvop->op_targ = pad_alloc(type, SVs_PADTMP); 5305 return CHECKOP(type, pvop); 5306 } 5307 5308 #ifdef PERL_MAD 5309 OP* 5310 #else 5311 void 5312 #endif 5313 Perl_package(pTHX_ OP *o) 5314 { 5315 dVAR; 5316 SV *const sv = cSVOPo->op_sv; 5317 #ifdef PERL_MAD 5318 OP *pegop; 5319 #endif 5320 5321 PERL_ARGS_ASSERT_PACKAGE; 5322 5323 SAVEGENERICSV(PL_curstash); 5324 save_item(PL_curstname); 5325 5326 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD)); 5327 5328 sv_setsv(PL_curstname, sv); 5329 5330 PL_hints |= HINT_BLOCK_SCOPE; 5331 PL_parser->copline = NOLINE; 5332 PL_parser->expect = XSTATE; 5333 5334 #ifndef PERL_MAD 5335 op_free(o); 5336 #else 5337 if (!PL_madskills) { 5338 op_free(o); 5339 return NULL; 5340 } 5341 5342 pegop = newOP(OP_NULL,0); 5343 op_getmad(o,pegop,'P'); 5344 return pegop; 5345 #endif 5346 } 5347 5348 void 5349 Perl_package_version( pTHX_ OP *v ) 5350 { 5351 dVAR; 5352 U32 savehints = PL_hints; 5353 PERL_ARGS_ASSERT_PACKAGE_VERSION; 5354 PL_hints &= ~HINT_STRICT_VARS; 5355 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv ); 5356 PL_hints = savehints; 5357 op_free(v); 5358 } 5359 5360 #ifdef PERL_MAD 5361 OP* 5362 #else 5363 void 5364 #endif 5365 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) 5366 { 5367 dVAR; 5368 OP *pack; 5369 OP *imop; 5370 OP *veop; 5371 #ifdef PERL_MAD 5372 OP *pegop = PL_madskills ? newOP(OP_NULL,0) : NULL; 5373 #endif 5374 SV *use_version = NULL; 5375 5376 PERL_ARGS_ASSERT_UTILIZE; 5377 5378 if (idop->op_type != OP_CONST) 5379 Perl_croak(aTHX_ "Module name must be constant"); 5380 5381 if (PL_madskills) 5382 op_getmad(idop,pegop,'U'); 5383 5384 veop = NULL; 5385 5386 if (version) { 5387 SV * const vesv = ((SVOP*)version)->op_sv; 5388 5389 if (PL_madskills) 5390 op_getmad(version,pegop,'V'); 5391 if (!arg && !SvNIOKp(vesv)) { 5392 arg = version; 5393 } 5394 else { 5395 OP *pack; 5396 SV *meth; 5397 5398 if (version->op_type != OP_CONST || !SvNIOKp(vesv)) 5399 Perl_croak(aTHX_ "Version number must be a constant number"); 5400 5401 /* Make copy of idop so we don't free it twice */ 5402 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv)); 5403 5404 /* Fake up a method call to VERSION */ 5405 meth = newSVpvs_share("VERSION"); 5406 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, 5407 op_append_elem(OP_LIST, 5408 op_prepend_elem(OP_LIST, pack, list(version)), 5409 newSVOP(OP_METHOD_NAMED, 0, meth))); 5410 } 5411 } 5412 5413 /* Fake up an import/unimport */ 5414 if (arg && arg->op_type == OP_STUB) { 5415 if (PL_madskills) 5416 op_getmad(arg,pegop,'S'); 5417 imop = arg; /* no import on explicit () */ 5418 } 5419 else if (SvNIOKp(((SVOP*)idop)->op_sv)) { 5420 imop = NULL; /* use 5.0; */ 5421 if (aver) 5422 use_version = ((SVOP*)idop)->op_sv; 5423 else 5424 idop->op_private |= OPpCONST_NOVER; 5425 } 5426 else { 5427 SV *meth; 5428 5429 if (PL_madskills) 5430 op_getmad(arg,pegop,'A'); 5431 5432 /* Make copy of idop so we don't free it twice */ 5433 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv)); 5434 5435 /* Fake up a method call to import/unimport */ 5436 meth = aver 5437 ? newSVpvs_share("import") : newSVpvs_share("unimport"); 5438 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, 5439 op_append_elem(OP_LIST, 5440 op_prepend_elem(OP_LIST, pack, list(arg)), 5441 newSVOP(OP_METHOD_NAMED, 0, meth))); 5442 } 5443 5444 /* Fake up the BEGIN {}, which does its thing immediately. */ 5445 newATTRSUB(floor, 5446 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")), 5447 NULL, 5448 NULL, 5449 op_append_elem(OP_LINESEQ, 5450 op_append_elem(OP_LINESEQ, 5451 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)), 5452 newSTATEOP(0, NULL, veop)), 5453 newSTATEOP(0, NULL, imop) )); 5454 5455 if (use_version) { 5456 /* Enable the 5457 * feature bundle that corresponds to the required version. */ 5458 use_version = sv_2mortal(new_version(use_version)); 5459 S_enable_feature_bundle(aTHX_ use_version); 5460 5461 /* If a version >= 5.11.0 is requested, strictures are on by default! */ 5462 if (vcmp(use_version, 5463 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) { 5464 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS)) 5465 PL_hints |= HINT_STRICT_REFS; 5466 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS)) 5467 PL_hints |= HINT_STRICT_SUBS; 5468 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS)) 5469 PL_hints |= HINT_STRICT_VARS; 5470 } 5471 /* otherwise they are off */ 5472 else { 5473 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS)) 5474 PL_hints &= ~HINT_STRICT_REFS; 5475 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS)) 5476 PL_hints &= ~HINT_STRICT_SUBS; 5477 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS)) 5478 PL_hints &= ~HINT_STRICT_VARS; 5479 } 5480 } 5481 5482 /* The "did you use incorrect case?" warning used to be here. 5483 * The problem is that on case-insensitive filesystems one 5484 * might get false positives for "use" (and "require"): 5485 * "use Strict" or "require CARP" will work. This causes 5486 * portability problems for the script: in case-strict 5487 * filesystems the script will stop working. 5488 * 5489 * The "incorrect case" warning checked whether "use Foo" 5490 * imported "Foo" to your namespace, but that is wrong, too: 5491 * there is no requirement nor promise in the language that 5492 * a Foo.pm should or would contain anything in package "Foo". 5493 * 5494 * There is very little Configure-wise that can be done, either: 5495 * the case-sensitivity of the build filesystem of Perl does not 5496 * help in guessing the case-sensitivity of the runtime environment. 5497 */ 5498 5499 PL_hints |= HINT_BLOCK_SCOPE; 5500 PL_parser->copline = NOLINE; 5501 PL_parser->expect = XSTATE; 5502 PL_cop_seqmax++; /* Purely for B::*'s benefit */ 5503 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */ 5504 PL_cop_seqmax++; 5505 5506 #ifdef PERL_MAD 5507 return pegop; 5508 #endif 5509 } 5510 5511 /* 5512 =head1 Embedding Functions 5513 5514 =for apidoc load_module 5515 5516 Loads the module whose name is pointed to by the string part of name. 5517 Note that the actual module name, not its filename, should be given. 5518 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of 5519 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS 5520 (or 0 for no flags). ver, if specified 5521 and not NULL, provides version semantics 5522 similar to C<use Foo::Bar VERSION>. The optional trailing SV* 5523 arguments can be used to specify arguments to the module's import() 5524 method, similar to C<use Foo::Bar VERSION LIST>. They must be 5525 terminated with a final NULL pointer. Note that this list can only 5526 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used. 5527 Otherwise at least a single NULL pointer to designate the default 5528 import list is required. 5529 5530 The reference count for each specified C<SV*> parameter is decremented. 5531 5532 =cut */ 5533 5534 void 5535 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...) 5536 { 5537 va_list args; 5538 5539 PERL_ARGS_ASSERT_LOAD_MODULE; 5540 5541 va_start(args, ver); 5542 vload_module(flags, name, ver, &args); 5543 va_end(args); 5544 } 5545 5546 #ifdef PERL_IMPLICIT_CONTEXT 5547 void 5548 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...) 5549 { 5550 dTHX; 5551 va_list args; 5552 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT; 5553 va_start(args, ver); 5554 vload_module(flags, name, ver, &args); 5555 va_end(args); 5556 } 5557 #endif 5558 5559 void 5560 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args) 5561 { 5562 dVAR; 5563 OP *veop, *imop; 5564 OP * const modname = newSVOP(OP_CONST, 0, name); 5565 5566 PERL_ARGS_ASSERT_VLOAD_MODULE; 5567 5568 modname->op_private |= OPpCONST_BARE; 5569 if (ver) { 5570 veop = newSVOP(OP_CONST, 0, ver); 5571 } 5572 else 5573 veop = NULL; 5574 if (flags & PERL_LOADMOD_NOIMPORT) { 5575 imop = sawparens(newNULLLIST()); 5576 } 5577 else if (flags & PERL_LOADMOD_IMPORT_OPS) { 5578 imop = va_arg(*args, OP*); 5579 } 5580 else { 5581 SV *sv; 5582 imop = NULL; 5583 sv = va_arg(*args, SV*); 5584 while (sv) { 5585 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv)); 5586 sv = va_arg(*args, SV*); 5587 } 5588 } 5589 5590 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure 5591 * that it has a PL_parser to play with while doing that, and also 5592 * that it doesn't mess with any existing parser, by creating a tmp 5593 * new parser with lex_start(). This won't actually be used for much, 5594 * since pp_require() will create another parser for the real work. 5595 * The ENTER/LEAVE pair protect callers from any side effects of use. */ 5596 5597 ENTER; 5598 SAVEVPTR(PL_curcop); 5599 lex_start(NULL, NULL, LEX_START_SAME_FILTER); 5600 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), 5601 veop, modname, imop); 5602 LEAVE; 5603 } 5604 5605 PERL_STATIC_INLINE OP * 5606 S_new_entersubop(pTHX_ GV *gv, OP *arg) 5607 { 5608 return newUNOP(OP_ENTERSUB, OPf_STACKED, 5609 newLISTOP(OP_LIST, 0, arg, 5610 newUNOP(OP_RV2CV, 0, 5611 newGVOP(OP_GV, 0, gv)))); 5612 } 5613 5614 OP * 5615 Perl_dofile(pTHX_ OP *term, I32 force_builtin) 5616 { 5617 dVAR; 5618 OP *doop; 5619 GV *gv; 5620 5621 PERL_ARGS_ASSERT_DOFILE; 5622 5623 if (!force_builtin && (gv = gv_override("do", 2))) { 5624 doop = S_new_entersubop(aTHX_ gv, term); 5625 } 5626 else { 5627 doop = newUNOP(OP_DOFILE, 0, scalar(term)); 5628 } 5629 return doop; 5630 } 5631 5632 /* 5633 =head1 Optree construction 5634 5635 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval 5636 5637 Constructs, checks, and returns an C<lslice> (list slice) op. I<flags> 5638 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will 5639 be set automatically, and, shifted up eight bits, the eight bits of 5640 C<op_private>, except that the bit with value 1 or 2 is automatically 5641 set as required. I<listval> and I<subscript> supply the parameters of 5642 the slice; they are consumed by this function and become part of the 5643 constructed op tree. 5644 5645 =cut 5646 */ 5647 5648 OP * 5649 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval) 5650 { 5651 return newBINOP(OP_LSLICE, flags, 5652 list(force_list(subscript)), 5653 list(force_list(listval)) ); 5654 } 5655 5656 STATIC I32 5657 S_is_list_assignment(pTHX_ const OP *o) 5658 { 5659 unsigned type; 5660 U8 flags; 5661 5662 if (!o) 5663 return TRUE; 5664 5665 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS)) 5666 o = cUNOPo->op_first; 5667 5668 flags = o->op_flags; 5669 type = o->op_type; 5670 if (type == OP_COND_EXPR) { 5671 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling); 5672 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling); 5673 5674 if (t && f) 5675 return TRUE; 5676 if (t || f) 5677 yyerror("Assignment to both a list and a scalar"); 5678 return FALSE; 5679 } 5680 5681 if (type == OP_LIST && 5682 (flags & OPf_WANT) == OPf_WANT_SCALAR && 5683 o->op_private & OPpLVAL_INTRO) 5684 return FALSE; 5685 5686 if (type == OP_LIST || flags & OPf_PARENS || 5687 type == OP_RV2AV || type == OP_RV2HV || 5688 type == OP_ASLICE || type == OP_HSLICE || 5689 type == OP_KVASLICE || type == OP_KVHSLICE) 5690 return TRUE; 5691 5692 if (type == OP_PADAV || type == OP_PADHV) 5693 return TRUE; 5694 5695 if (type == OP_RV2SV) 5696 return FALSE; 5697 5698 return FALSE; 5699 } 5700 5701 /* 5702 Helper function for newASSIGNOP to detection commonality between the 5703 lhs and the rhs. Marks all variables with PL_generation. If it 5704 returns TRUE the assignment must be able to handle common variables. 5705 */ 5706 PERL_STATIC_INLINE bool 5707 S_aassign_common_vars(pTHX_ OP* o) 5708 { 5709 OP *curop; 5710 for (curop = cUNOPo->op_first; curop; curop=curop->op_sibling) { 5711 if (PL_opargs[curop->op_type] & OA_DANGEROUS) { 5712 if (curop->op_type == OP_GV) { 5713 GV *gv = cGVOPx_gv(curop); 5714 if (gv == PL_defgv 5715 || (int)GvASSIGN_GENERATION(gv) == PL_generation) 5716 return TRUE; 5717 GvASSIGN_GENERATION_set(gv, PL_generation); 5718 } 5719 else if (curop->op_type == OP_PADSV || 5720 curop->op_type == OP_PADAV || 5721 curop->op_type == OP_PADHV || 5722 curop->op_type == OP_PADANY) 5723 { 5724 if (PAD_COMPNAME_GEN(curop->op_targ) 5725 == (STRLEN)PL_generation) 5726 return TRUE; 5727 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation); 5728 5729 } 5730 else if (curop->op_type == OP_RV2CV) 5731 return TRUE; 5732 else if (curop->op_type == OP_RV2SV || 5733 curop->op_type == OP_RV2AV || 5734 curop->op_type == OP_RV2HV || 5735 curop->op_type == OP_RV2GV) { 5736 if (cUNOPx(curop)->op_first->op_type != OP_GV) /* funny deref? */ 5737 return TRUE; 5738 } 5739 else if (curop->op_type == OP_PUSHRE) { 5740 GV *const gv = 5741 #ifdef USE_ITHREADS 5742 ((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff 5743 ? MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff)) 5744 : NULL; 5745 #else 5746 ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv; 5747 #endif 5748 if (gv) { 5749 if (gv == PL_defgv 5750 || (int)GvASSIGN_GENERATION(gv) == PL_generation) 5751 return TRUE; 5752 GvASSIGN_GENERATION_set(gv, PL_generation); 5753 } 5754 } 5755 else 5756 return TRUE; 5757 } 5758 5759 if (curop->op_flags & OPf_KIDS) { 5760 if (aassign_common_vars(curop)) 5761 return TRUE; 5762 } 5763 } 5764 return FALSE; 5765 } 5766 5767 /* 5768 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right 5769 5770 Constructs, checks, and returns an assignment op. I<left> and I<right> 5771 supply the parameters of the assignment; they are consumed by this 5772 function and become part of the constructed op tree. 5773 5774 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then 5775 a suitable conditional optree is constructed. If I<optype> is the opcode 5776 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that 5777 performs the binary operation and assigns the result to the left argument. 5778 Either way, if I<optype> is non-zero then I<flags> has no effect. 5779 5780 If I<optype> is zero, then a plain scalar or list assignment is 5781 constructed. Which type of assignment it is is automatically determined. 5782 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS> 5783 will be set automatically, and, shifted up eight bits, the eight bits 5784 of C<op_private>, except that the bit with value 1 or 2 is automatically 5785 set as required. 5786 5787 =cut 5788 */ 5789 5790 OP * 5791 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) 5792 { 5793 dVAR; 5794 OP *o; 5795 5796 if (optype) { 5797 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) { 5798 return newLOGOP(optype, 0, 5799 op_lvalue(scalar(left), optype), 5800 newUNOP(OP_SASSIGN, 0, scalar(right))); 5801 } 5802 else { 5803 return newBINOP(optype, OPf_STACKED, 5804 op_lvalue(scalar(left), optype), scalar(right)); 5805 } 5806 } 5807 5808 if (is_list_assignment(left)) { 5809 static const char no_list_state[] = "Initialization of state variables" 5810 " in list context currently forbidden"; 5811 OP *curop; 5812 bool maybe_common_vars = TRUE; 5813 5814 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE) 5815 left->op_private &= ~ OPpSLICEWARNING; 5816 5817 PL_modcount = 0; 5818 left = op_lvalue(left, OP_AASSIGN); 5819 curop = list(force_list(left)); 5820 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop); 5821 o->op_private = (U8)(0 | (flags >> 8)); 5822 5823 if (OP_TYPE_IS_OR_WAS(left, OP_LIST)) 5824 { 5825 OP* lop = ((LISTOP*)left)->op_first; 5826 maybe_common_vars = FALSE; 5827 while (lop) { 5828 if (lop->op_type == OP_PADSV || 5829 lop->op_type == OP_PADAV || 5830 lop->op_type == OP_PADHV || 5831 lop->op_type == OP_PADANY) { 5832 if (!(lop->op_private & OPpLVAL_INTRO)) 5833 maybe_common_vars = TRUE; 5834 5835 if (lop->op_private & OPpPAD_STATE) { 5836 if (left->op_private & OPpLVAL_INTRO) { 5837 /* Each variable in state($a, $b, $c) = ... */ 5838 } 5839 else { 5840 /* Each state variable in 5841 (state $a, my $b, our $c, $d, undef) = ... */ 5842 } 5843 yyerror(no_list_state); 5844 } else { 5845 /* Each my variable in 5846 (state $a, my $b, our $c, $d, undef) = ... */ 5847 } 5848 } else if (lop->op_type == OP_UNDEF || 5849 OP_TYPE_IS_OR_WAS(lop, OP_PUSHMARK)) { 5850 /* undef may be interesting in 5851 (state $a, undef, state $c) */ 5852 } else { 5853 /* Other ops in the list. */ 5854 maybe_common_vars = TRUE; 5855 } 5856 lop = lop->op_sibling; 5857 } 5858 } 5859 else if ((left->op_private & OPpLVAL_INTRO) 5860 && ( left->op_type == OP_PADSV 5861 || left->op_type == OP_PADAV 5862 || left->op_type == OP_PADHV 5863 || left->op_type == OP_PADANY)) 5864 { 5865 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE; 5866 if (left->op_private & OPpPAD_STATE) { 5867 /* All single variable list context state assignments, hence 5868 state ($a) = ... 5869 (state $a) = ... 5870 state @a = ... 5871 state (@a) = ... 5872 (state @a) = ... 5873 state %a = ... 5874 state (%a) = ... 5875 (state %a) = ... 5876 */ 5877 yyerror(no_list_state); 5878 } 5879 } 5880 5881 /* PL_generation sorcery: 5882 * an assignment like ($a,$b) = ($c,$d) is easier than 5883 * ($a,$b) = ($c,$a), since there is no need for temporary vars. 5884 * To detect whether there are common vars, the global var 5885 * PL_generation is incremented for each assign op we compile. 5886 * Then, while compiling the assign op, we run through all the 5887 * variables on both sides of the assignment, setting a spare slot 5888 * in each of them to PL_generation. If any of them already have 5889 * that value, we know we've got commonality. We could use a 5890 * single bit marker, but then we'd have to make 2 passes, first 5891 * to clear the flag, then to test and set it. To find somewhere 5892 * to store these values, evil chicanery is done with SvUVX(). 5893 */ 5894 5895 if (maybe_common_vars) { 5896 PL_generation++; 5897 if (aassign_common_vars(o)) 5898 o->op_private |= OPpASSIGN_COMMON; 5899 LINKLIST(o); 5900 } 5901 5902 if (right && right->op_type == OP_SPLIT && !PL_madskills) { 5903 OP* tmpop = ((LISTOP*)right)->op_first; 5904 if (tmpop && (tmpop->op_type == OP_PUSHRE)) { 5905 PMOP * const pm = (PMOP*)tmpop; 5906 if (left->op_type == OP_RV2AV && 5907 !(left->op_private & OPpLVAL_INTRO) && 5908 !(o->op_private & OPpASSIGN_COMMON) ) 5909 { 5910 tmpop = ((UNOP*)left)->op_first; 5911 if (tmpop->op_type == OP_GV 5912 #ifdef USE_ITHREADS 5913 && !pm->op_pmreplrootu.op_pmtargetoff 5914 #else 5915 && !pm->op_pmreplrootu.op_pmtargetgv 5916 #endif 5917 ) { 5918 #ifdef USE_ITHREADS 5919 pm->op_pmreplrootu.op_pmtargetoff 5920 = cPADOPx(tmpop)->op_padix; 5921 cPADOPx(tmpop)->op_padix = 0; /* steal it */ 5922 #else 5923 pm->op_pmreplrootu.op_pmtargetgv 5924 = MUTABLE_GV(cSVOPx(tmpop)->op_sv); 5925 cSVOPx(tmpop)->op_sv = NULL; /* steal it */ 5926 #endif 5927 tmpop = cUNOPo->op_first; /* to list (nulled) */ 5928 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */ 5929 tmpop->op_sibling = NULL; /* don't free split */ 5930 right->op_next = tmpop->op_next; /* fix starting loc */ 5931 op_free(o); /* blow off assign */ 5932 right->op_flags &= ~OPf_WANT; 5933 /* "I don't know and I don't care." */ 5934 return right; 5935 } 5936 } 5937 else { 5938 if (PL_modcount < RETURN_UNLIMITED_NUMBER && 5939 ((LISTOP*)right)->op_last->op_type == OP_CONST) 5940 { 5941 SV ** const svp = 5942 &((SVOP*)((LISTOP*)right)->op_last)->op_sv; 5943 SV * const sv = *svp; 5944 if (SvIOK(sv) && SvIVX(sv) == 0) 5945 { 5946 if (right->op_private & OPpSPLIT_IMPLIM) { 5947 /* our own SV, created in ck_split */ 5948 SvREADONLY_off(sv); 5949 sv_setiv(sv, PL_modcount+1); 5950 } 5951 else { 5952 /* SV may belong to someone else */ 5953 SvREFCNT_dec(sv); 5954 *svp = newSViv(PL_modcount+1); 5955 } 5956 } 5957 } 5958 } 5959 } 5960 } 5961 return o; 5962 } 5963 if (!right) 5964 right = newOP(OP_UNDEF, 0); 5965 if (right->op_type == OP_READLINE) { 5966 right->op_flags |= OPf_STACKED; 5967 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN), 5968 scalar(right)); 5969 } 5970 else { 5971 o = newBINOP(OP_SASSIGN, flags, 5972 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) ); 5973 } 5974 return o; 5975 } 5976 5977 /* 5978 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o 5979 5980 Constructs a state op (COP). The state op is normally a C<nextstate> op, 5981 but will be a C<dbstate> op if debugging is enabled for currently-compiled 5982 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>). 5983 If I<label> is non-null, it supplies the name of a label to attach to 5984 the state op; this function takes ownership of the memory pointed at by 5985 I<label>, and will free it. I<flags> gives the eight bits of C<op_flags> 5986 for the state op. 5987 5988 If I<o> is null, the state op is returned. Otherwise the state op is 5989 combined with I<o> into a C<lineseq> list op, which is returned. I<o> 5990 is consumed by this function and becomes part of the returned op tree. 5991 5992 =cut 5993 */ 5994 5995 OP * 5996 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) 5997 { 5998 dVAR; 5999 const U32 seq = intro_my(); 6000 const U32 utf8 = flags & SVf_UTF8; 6001 COP *cop; 6002 6003 flags &= ~SVf_UTF8; 6004 6005 NewOp(1101, cop, 1, COP); 6006 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) { 6007 cop->op_type = OP_DBSTATE; 6008 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ]; 6009 } 6010 else { 6011 cop->op_type = OP_NEXTSTATE; 6012 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ]; 6013 } 6014 cop->op_flags = (U8)flags; 6015 CopHINTS_set(cop, PL_hints); 6016 #ifdef NATIVE_HINTS 6017 cop->op_private |= NATIVE_HINTS; 6018 #endif 6019 #ifdef VMS 6020 if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH; 6021 #endif 6022 cop->op_next = (OP*)cop; 6023 6024 cop->cop_seq = seq; 6025 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings); 6026 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop))); 6027 if (label) { 6028 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8); 6029 6030 PL_hints |= HINT_BLOCK_SCOPE; 6031 /* It seems that we need to defer freeing this pointer, as other parts 6032 of the grammar end up wanting to copy it after this op has been 6033 created. */ 6034 SAVEFREEPV(label); 6035 } 6036 6037 if (PL_parser->preambling != NOLINE) { 6038 CopLINE_set(cop, PL_parser->preambling); 6039 PL_parser->copline = NOLINE; 6040 } 6041 else if (PL_parser->copline == NOLINE) 6042 CopLINE_set(cop, CopLINE(PL_curcop)); 6043 else { 6044 CopLINE_set(cop, PL_parser->copline); 6045 PL_parser->copline = NOLINE; 6046 } 6047 #ifdef USE_ITHREADS 6048 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */ 6049 #else 6050 CopFILEGV_set(cop, CopFILEGV(PL_curcop)); 6051 #endif 6052 CopSTASH_set(cop, PL_curstash); 6053 6054 if (cop->op_type == OP_DBSTATE) { 6055 /* this line can have a breakpoint - store the cop in IV */ 6056 AV *av = CopFILEAVx(PL_curcop); 6057 if (av) { 6058 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE); 6059 if (svp && *svp != &PL_sv_undef ) { 6060 (void)SvIOK_on(*svp); 6061 SvIV_set(*svp, PTR2IV(cop)); 6062 } 6063 } 6064 } 6065 6066 if (flags & OPf_SPECIAL) 6067 op_null((OP*)cop); 6068 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o); 6069 } 6070 6071 /* 6072 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other 6073 6074 Constructs, checks, and returns a logical (flow control) op. I<type> 6075 is the opcode. I<flags> gives the eight bits of C<op_flags>, except 6076 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits, 6077 the eight bits of C<op_private>, except that the bit with value 1 is 6078 automatically set. I<first> supplies the expression controlling the 6079 flow, and I<other> supplies the side (alternate) chain of ops; they are 6080 consumed by this function and become part of the constructed op tree. 6081 6082 =cut 6083 */ 6084 6085 OP * 6086 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other) 6087 { 6088 dVAR; 6089 6090 PERL_ARGS_ASSERT_NEWLOGOP; 6091 6092 return new_logop(type, flags, &first, &other); 6093 } 6094 6095 STATIC OP * 6096 S_search_const(pTHX_ OP *o) 6097 { 6098 PERL_ARGS_ASSERT_SEARCH_CONST; 6099 6100 switch (o->op_type) { 6101 case OP_CONST: 6102 return o; 6103 case OP_NULL: 6104 if (o->op_flags & OPf_KIDS) 6105 return search_const(cUNOPo->op_first); 6106 break; 6107 case OP_LEAVE: 6108 case OP_SCOPE: 6109 case OP_LINESEQ: 6110 { 6111 OP *kid; 6112 if (!(o->op_flags & OPf_KIDS)) 6113 return NULL; 6114 kid = cLISTOPo->op_first; 6115 do { 6116 switch (kid->op_type) { 6117 case OP_ENTER: 6118 case OP_NULL: 6119 case OP_NEXTSTATE: 6120 kid = kid->op_sibling; 6121 break; 6122 default: 6123 if (kid != cLISTOPo->op_last) 6124 return NULL; 6125 goto last; 6126 } 6127 } while (kid); 6128 if (!kid) 6129 kid = cLISTOPo->op_last; 6130 last: 6131 return search_const(kid); 6132 } 6133 } 6134 6135 return NULL; 6136 } 6137 6138 STATIC OP * 6139 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) 6140 { 6141 dVAR; 6142 LOGOP *logop; 6143 OP *o; 6144 OP *first; 6145 OP *other; 6146 OP *cstop = NULL; 6147 int prepend_not = 0; 6148 6149 PERL_ARGS_ASSERT_NEW_LOGOP; 6150 6151 first = *firstp; 6152 other = *otherp; 6153 6154 /* [perl #59802]: Warn about things like "return $a or $b", which 6155 is parsed as "(return $a) or $b" rather than "return ($a or 6156 $b)". NB: This also applies to xor, which is why we do it 6157 here. 6158 */ 6159 switch (first->op_type) { 6160 case OP_NEXT: 6161 case OP_LAST: 6162 case OP_REDO: 6163 /* XXX: Perhaps we should emit a stronger warning for these. 6164 Even with the high-precedence operator they don't seem to do 6165 anything sensible. 6166 6167 But until we do, fall through here. 6168 */ 6169 case OP_RETURN: 6170 case OP_EXIT: 6171 case OP_DIE: 6172 case OP_GOTO: 6173 /* XXX: Currently we allow people to "shoot themselves in the 6174 foot" by explicitly writing "(return $a) or $b". 6175 6176 Warn unless we are looking at the result from folding or if 6177 the programmer explicitly grouped the operators like this. 6178 The former can occur with e.g. 6179 6180 use constant FEATURE => ( $] >= ... ); 6181 sub { not FEATURE and return or do_stuff(); } 6182 */ 6183 if (!first->op_folded && !(first->op_flags & OPf_PARENS)) 6184 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), 6185 "Possible precedence issue with control flow operator"); 6186 /* XXX: Should we optimze this to "return $a;" (i.e. remove 6187 the "or $b" part)? 6188 */ 6189 break; 6190 } 6191 6192 if (type == OP_XOR) /* Not short circuit, but here by precedence. */ 6193 return newBINOP(type, flags, scalar(first), scalar(other)); 6194 6195 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP); 6196 6197 scalarboolean(first); 6198 /* optimize AND and OR ops that have NOTs as children */ 6199 if (first->op_type == OP_NOT 6200 && (first->op_flags & OPf_KIDS) 6201 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */ 6202 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */ 6203 && !PL_madskills) { 6204 if (type == OP_AND || type == OP_OR) { 6205 if (type == OP_AND) 6206 type = OP_OR; 6207 else 6208 type = OP_AND; 6209 op_null(first); 6210 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */ 6211 op_null(other); 6212 prepend_not = 1; /* prepend a NOT op later */ 6213 } 6214 } 6215 } 6216 /* search for a constant op that could let us fold the test */ 6217 if ((cstop = search_const(first))) { 6218 if (cstop->op_private & OPpCONST_STRICT) 6219 no_bareword_allowed(cstop); 6220 else if ((cstop->op_private & OPpCONST_BARE)) 6221 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional"); 6222 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) || 6223 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) || 6224 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) { 6225 *firstp = NULL; 6226 if (other->op_type == OP_CONST) 6227 other->op_private |= OPpCONST_SHORTCIRCUIT; 6228 if (PL_madskills) { 6229 OP *newop = newUNOP(OP_NULL, 0, other); 6230 op_getmad(first, newop, '1'); 6231 newop->op_targ = type; /* set "was" field */ 6232 return newop; 6233 } 6234 op_free(first); 6235 if (other->op_type == OP_LEAVE) 6236 other = newUNOP(OP_NULL, OPf_SPECIAL, other); 6237 else if (other->op_type == OP_MATCH 6238 || other->op_type == OP_SUBST 6239 || other->op_type == OP_TRANSR 6240 || other->op_type == OP_TRANS) 6241 /* Mark the op as being unbindable with =~ */ 6242 other->op_flags |= OPf_SPECIAL; 6243 6244 other->op_folded = 1; 6245 return other; 6246 } 6247 else { 6248 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */ 6249 const OP *o2 = other; 6250 if ( ! (o2->op_type == OP_LIST 6251 && (( o2 = cUNOPx(o2)->op_first)) 6252 && o2->op_type == OP_PUSHMARK 6253 && (( o2 = o2->op_sibling)) ) 6254 ) 6255 o2 = other; 6256 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV 6257 || o2->op_type == OP_PADHV) 6258 && o2->op_private & OPpLVAL_INTRO 6259 && !(o2->op_private & OPpPAD_STATE)) 6260 { 6261 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), 6262 "Deprecated use of my() in false conditional"); 6263 } 6264 6265 *otherp = NULL; 6266 if (cstop->op_type == OP_CONST) 6267 cstop->op_private |= OPpCONST_SHORTCIRCUIT; 6268 if (PL_madskills) { 6269 first = newUNOP(OP_NULL, 0, first); 6270 op_getmad(other, first, '2'); 6271 first->op_targ = type; /* set "was" field */ 6272 } 6273 else 6274 op_free(other); 6275 return first; 6276 } 6277 } 6278 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR 6279 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */ 6280 { 6281 const OP * const k1 = ((UNOP*)first)->op_first; 6282 const OP * const k2 = k1->op_sibling; 6283 OPCODE warnop = 0; 6284 switch (first->op_type) 6285 { 6286 case OP_NULL: 6287 if (k2 && k2->op_type == OP_READLINE 6288 && (k2->op_flags & OPf_STACKED) 6289 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) 6290 { 6291 warnop = k2->op_type; 6292 } 6293 break; 6294 6295 case OP_SASSIGN: 6296 if (k1->op_type == OP_READDIR 6297 || k1->op_type == OP_GLOB 6298 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB) 6299 || k1->op_type == OP_EACH 6300 || k1->op_type == OP_AEACH) 6301 { 6302 warnop = ((k1->op_type == OP_NULL) 6303 ? (OPCODE)k1->op_targ : k1->op_type); 6304 } 6305 break; 6306 } 6307 if (warnop) { 6308 const line_t oldline = CopLINE(PL_curcop); 6309 /* This ensures that warnings are reported at the first line 6310 of the construction, not the last. */ 6311 CopLINE_set(PL_curcop, PL_parser->copline); 6312 Perl_warner(aTHX_ packWARN(WARN_MISC), 6313 "Value of %s%s can be \"0\"; test with defined()", 6314 PL_op_desc[warnop], 6315 ((warnop == OP_READLINE || warnop == OP_GLOB) 6316 ? " construct" : "() operator")); 6317 CopLINE_set(PL_curcop, oldline); 6318 } 6319 } 6320 6321 if (!other) 6322 return first; 6323 6324 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN) 6325 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */ 6326 6327 NewOp(1101, logop, 1, LOGOP); 6328 6329 logop->op_type = (OPCODE)type; 6330 logop->op_ppaddr = PL_ppaddr[type]; 6331 logop->op_first = first; 6332 logop->op_flags = (U8)(flags | OPf_KIDS); 6333 logop->op_other = LINKLIST(other); 6334 logop->op_private = (U8)(1 | (flags >> 8)); 6335 6336 /* establish postfix order */ 6337 logop->op_next = LINKLIST(first); 6338 first->op_next = (OP*)logop; 6339 first->op_sibling = other; 6340 6341 CHECKOP(type,logop); 6342 6343 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop); 6344 other->op_next = o; 6345 6346 return o; 6347 } 6348 6349 /* 6350 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop 6351 6352 Constructs, checks, and returns a conditional-expression (C<cond_expr>) 6353 op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS> 6354 will be set automatically, and, shifted up eight bits, the eight bits of 6355 C<op_private>, except that the bit with value 1 is automatically set. 6356 I<first> supplies the expression selecting between the two branches, 6357 and I<trueop> and I<falseop> supply the branches; they are consumed by 6358 this function and become part of the constructed op tree. 6359 6360 =cut 6361 */ 6362 6363 OP * 6364 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) 6365 { 6366 dVAR; 6367 LOGOP *logop; 6368 OP *start; 6369 OP *o; 6370 OP *cstop; 6371 6372 PERL_ARGS_ASSERT_NEWCONDOP; 6373 6374 if (!falseop) 6375 return newLOGOP(OP_AND, 0, first, trueop); 6376 if (!trueop) 6377 return newLOGOP(OP_OR, 0, first, falseop); 6378 6379 scalarboolean(first); 6380 if ((cstop = search_const(first))) { 6381 /* Left or right arm of the conditional? */ 6382 const bool left = SvTRUE(((SVOP*)cstop)->op_sv); 6383 OP *live = left ? trueop : falseop; 6384 OP *const dead = left ? falseop : trueop; 6385 if (cstop->op_private & OPpCONST_BARE && 6386 cstop->op_private & OPpCONST_STRICT) { 6387 no_bareword_allowed(cstop); 6388 } 6389 if (PL_madskills) { 6390 /* This is all dead code when PERL_MAD is not defined. */ 6391 live = newUNOP(OP_NULL, 0, live); 6392 op_getmad(first, live, 'C'); 6393 op_getmad(dead, live, left ? 'e' : 't'); 6394 } else { 6395 op_free(first); 6396 op_free(dead); 6397 } 6398 if (live->op_type == OP_LEAVE) 6399 live = newUNOP(OP_NULL, OPf_SPECIAL, live); 6400 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST 6401 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR) 6402 /* Mark the op as being unbindable with =~ */ 6403 live->op_flags |= OPf_SPECIAL; 6404 live->op_folded = 1; 6405 return live; 6406 } 6407 NewOp(1101, logop, 1, LOGOP); 6408 logop->op_type = OP_COND_EXPR; 6409 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR]; 6410 logop->op_first = first; 6411 logop->op_flags = (U8)(flags | OPf_KIDS); 6412 logop->op_private = (U8)(1 | (flags >> 8)); 6413 logop->op_other = LINKLIST(trueop); 6414 logop->op_next = LINKLIST(falseop); 6415 6416 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */ 6417 logop); 6418 6419 /* establish postfix order */ 6420 start = LINKLIST(first); 6421 first->op_next = (OP*)logop; 6422 6423 first->op_sibling = trueop; 6424 trueop->op_sibling = falseop; 6425 o = newUNOP(OP_NULL, 0, (OP*)logop); 6426 6427 trueop->op_next = falseop->op_next = o; 6428 6429 o->op_next = start; 6430 return o; 6431 } 6432 6433 /* 6434 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right 6435 6436 Constructs and returns a C<range> op, with subordinate C<flip> and 6437 C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the 6438 C<flip> op and, shifted up eight bits, the eight bits of C<op_private> 6439 for both the C<flip> and C<range> ops, except that the bit with value 6440 1 is automatically set. I<left> and I<right> supply the expressions 6441 controlling the endpoints of the range; they are consumed by this function 6442 and become part of the constructed op tree. 6443 6444 =cut 6445 */ 6446 6447 OP * 6448 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right) 6449 { 6450 dVAR; 6451 LOGOP *range; 6452 OP *flip; 6453 OP *flop; 6454 OP *leftstart; 6455 OP *o; 6456 6457 PERL_ARGS_ASSERT_NEWRANGE; 6458 6459 NewOp(1101, range, 1, LOGOP); 6460 6461 range->op_type = OP_RANGE; 6462 range->op_ppaddr = PL_ppaddr[OP_RANGE]; 6463 range->op_first = left; 6464 range->op_flags = OPf_KIDS; 6465 leftstart = LINKLIST(left); 6466 range->op_other = LINKLIST(right); 6467 range->op_private = (U8)(1 | (flags >> 8)); 6468 6469 left->op_sibling = right; 6470 6471 range->op_next = (OP*)range; 6472 flip = newUNOP(OP_FLIP, flags, (OP*)range); 6473 flop = newUNOP(OP_FLOP, 0, flip); 6474 o = newUNOP(OP_NULL, 0, flop); 6475 LINKLIST(flop); 6476 range->op_next = leftstart; 6477 6478 left->op_next = flip; 6479 right->op_next = flop; 6480 6481 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY); 6482 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV); 6483 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY); 6484 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV); 6485 6486 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0; 6487 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0; 6488 6489 /* check barewords before they might be optimized aways */ 6490 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT) 6491 no_bareword_allowed(left); 6492 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT) 6493 no_bareword_allowed(right); 6494 6495 flip->op_next = o; 6496 if (!flip->op_private || !flop->op_private) 6497 LINKLIST(o); /* blow off optimizer unless constant */ 6498 6499 return o; 6500 } 6501 6502 /* 6503 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block 6504 6505 Constructs, checks, and returns an op tree expressing a loop. This is 6506 only a loop in the control flow through the op tree; it does not have 6507 the heavyweight loop structure that allows exiting the loop by C<last> 6508 and suchlike. I<flags> gives the eight bits of C<op_flags> for the 6509 top-level op, except that some bits will be set automatically as required. 6510 I<expr> supplies the expression controlling loop iteration, and I<block> 6511 supplies the body of the loop; they are consumed by this function and 6512 become part of the constructed op tree. I<debuggable> is currently 6513 unused and should always be 1. 6514 6515 =cut 6516 */ 6517 6518 OP * 6519 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) 6520 { 6521 dVAR; 6522 OP* listop; 6523 OP* o; 6524 const bool once = block && block->op_flags & OPf_SPECIAL && 6525 block->op_type == OP_NULL; 6526 6527 PERL_UNUSED_ARG(debuggable); 6528 6529 if (expr) { 6530 if (once && ( 6531 (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv)) 6532 || ( expr->op_type == OP_NOT 6533 && cUNOPx(expr)->op_first->op_type == OP_CONST 6534 && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first)) 6535 ) 6536 )) 6537 /* Return the block now, so that S_new_logop does not try to 6538 fold it away. */ 6539 return block; /* do {} while 0 does once */ 6540 if (expr->op_type == OP_READLINE 6541 || expr->op_type == OP_READDIR 6542 || expr->op_type == OP_GLOB 6543 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH 6544 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) { 6545 expr = newUNOP(OP_DEFINED, 0, 6546 newASSIGNOP(0, newDEFSVOP(), 0, expr) ); 6547 } else if (expr->op_flags & OPf_KIDS) { 6548 const OP * const k1 = ((UNOP*)expr)->op_first; 6549 const OP * const k2 = k1 ? k1->op_sibling : NULL; 6550 switch (expr->op_type) { 6551 case OP_NULL: 6552 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR) 6553 && (k2->op_flags & OPf_STACKED) 6554 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) 6555 expr = newUNOP(OP_DEFINED, 0, expr); 6556 break; 6557 6558 case OP_SASSIGN: 6559 if (k1 && (k1->op_type == OP_READDIR 6560 || k1->op_type == OP_GLOB 6561 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB) 6562 || k1->op_type == OP_EACH 6563 || k1->op_type == OP_AEACH)) 6564 expr = newUNOP(OP_DEFINED, 0, expr); 6565 break; 6566 } 6567 } 6568 } 6569 6570 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar 6571 * op, in listop. This is wrong. [perl #27024] */ 6572 if (!block) 6573 block = newOP(OP_NULL, 0); 6574 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0)); 6575 o = new_logop(OP_AND, 0, &expr, &listop); 6576 6577 if (once) { 6578 ASSUME(listop); 6579 } 6580 6581 if (listop) 6582 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o); 6583 6584 if (once && o != listop) 6585 { 6586 assert(cUNOPo->op_first->op_type == OP_AND 6587 || cUNOPo->op_first->op_type == OP_OR); 6588 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other; 6589 } 6590 6591 if (o == listop) 6592 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */ 6593 6594 o->op_flags |= flags; 6595 o = op_scope(o); 6596 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/ 6597 return o; 6598 } 6599 6600 /* 6601 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my 6602 6603 Constructs, checks, and returns an op tree expressing a C<while> loop. 6604 This is a heavyweight loop, with structure that allows exiting the loop 6605 by C<last> and suchlike. 6606 6607 I<loop> is an optional preconstructed C<enterloop> op to use in the 6608 loop; if it is null then a suitable op will be constructed automatically. 6609 I<expr> supplies the loop's controlling expression. I<block> supplies the 6610 main body of the loop, and I<cont> optionally supplies a C<continue> block 6611 that operates as a second half of the body. All of these optree inputs 6612 are consumed by this function and become part of the constructed op tree. 6613 6614 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop> 6615 op and, shifted up eight bits, the eight bits of C<op_private> for 6616 the C<leaveloop> op, except that (in both cases) some bits will be set 6617 automatically. I<debuggable> is currently unused and should always be 1. 6618 I<has_my> can be supplied as true to force the 6619 loop body to be enclosed in its own scope. 6620 6621 =cut 6622 */ 6623 6624 OP * 6625 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, 6626 OP *expr, OP *block, OP *cont, I32 has_my) 6627 { 6628 dVAR; 6629 OP *redo; 6630 OP *next = NULL; 6631 OP *listop; 6632 OP *o; 6633 U8 loopflags = 0; 6634 6635 PERL_UNUSED_ARG(debuggable); 6636 6637 if (expr) { 6638 if (expr->op_type == OP_READLINE 6639 || expr->op_type == OP_READDIR 6640 || expr->op_type == OP_GLOB 6641 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH 6642 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) { 6643 expr = newUNOP(OP_DEFINED, 0, 6644 newASSIGNOP(0, newDEFSVOP(), 0, expr) ); 6645 } else if (expr->op_flags & OPf_KIDS) { 6646 const OP * const k1 = ((UNOP*)expr)->op_first; 6647 const OP * const k2 = (k1) ? k1->op_sibling : NULL; 6648 switch (expr->op_type) { 6649 case OP_NULL: 6650 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR) 6651 && (k2->op_flags & OPf_STACKED) 6652 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) 6653 expr = newUNOP(OP_DEFINED, 0, expr); 6654 break; 6655 6656 case OP_SASSIGN: 6657 if (k1 && (k1->op_type == OP_READDIR 6658 || k1->op_type == OP_GLOB 6659 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB) 6660 || k1->op_type == OP_EACH 6661 || k1->op_type == OP_AEACH)) 6662 expr = newUNOP(OP_DEFINED, 0, expr); 6663 break; 6664 } 6665 } 6666 } 6667 6668 if (!block) 6669 block = newOP(OP_NULL, 0); 6670 else if (cont || has_my) { 6671 block = op_scope(block); 6672 } 6673 6674 if (cont) { 6675 next = LINKLIST(cont); 6676 } 6677 if (expr) { 6678 OP * const unstack = newOP(OP_UNSTACK, 0); 6679 if (!next) 6680 next = unstack; 6681 cont = op_append_elem(OP_LINESEQ, cont, unstack); 6682 } 6683 6684 assert(block); 6685 listop = op_append_list(OP_LINESEQ, block, cont); 6686 assert(listop); 6687 redo = LINKLIST(listop); 6688 6689 if (expr) { 6690 scalar(listop); 6691 o = new_logop(OP_AND, 0, &expr, &listop); 6692 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) { 6693 op_free((OP*)loop); 6694 return expr; /* listop already freed by new_logop */ 6695 } 6696 if (listop) 6697 ((LISTOP*)listop)->op_last->op_next = 6698 (o == listop ? redo : LINKLIST(o)); 6699 } 6700 else 6701 o = listop; 6702 6703 if (!loop) { 6704 NewOp(1101,loop,1,LOOP); 6705 loop->op_type = OP_ENTERLOOP; 6706 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP]; 6707 loop->op_private = 0; 6708 loop->op_next = (OP*)loop; 6709 } 6710 6711 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o); 6712 6713 loop->op_redoop = redo; 6714 loop->op_lastop = o; 6715 o->op_private |= loopflags; 6716 6717 if (next) 6718 loop->op_nextop = next; 6719 else 6720 loop->op_nextop = o; 6721 6722 o->op_flags |= flags; 6723 o->op_private |= (flags >> 8); 6724 return o; 6725 } 6726 6727 /* 6728 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont 6729 6730 Constructs, checks, and returns an op tree expressing a C<foreach> 6731 loop (iteration through a list of values). This is a heavyweight loop, 6732 with structure that allows exiting the loop by C<last> and suchlike. 6733 6734 I<sv> optionally supplies the variable that will be aliased to each 6735 item in turn; if null, it defaults to C<$_> (either lexical or global). 6736 I<expr> supplies the list of values to iterate over. I<block> supplies 6737 the main body of the loop, and I<cont> optionally supplies a C<continue> 6738 block that operates as a second half of the body. All of these optree 6739 inputs are consumed by this function and become part of the constructed 6740 op tree. 6741 6742 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop> 6743 op and, shifted up eight bits, the eight bits of C<op_private> for 6744 the C<leaveloop> op, except that (in both cases) some bits will be set 6745 automatically. 6746 6747 =cut 6748 */ 6749 6750 OP * 6751 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) 6752 { 6753 dVAR; 6754 LOOP *loop; 6755 OP *wop; 6756 PADOFFSET padoff = 0; 6757 I32 iterflags = 0; 6758 I32 iterpflags = 0; 6759 OP *madsv = NULL; 6760 6761 PERL_ARGS_ASSERT_NEWFOROP; 6762 6763 if (sv) { 6764 if (sv->op_type == OP_RV2SV) { /* symbol table variable */ 6765 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */ 6766 sv->op_type = OP_RV2GV; 6767 sv->op_ppaddr = PL_ppaddr[OP_RV2GV]; 6768 6769 /* The op_type check is needed to prevent a possible segfault 6770 * if the loop variable is undeclared and 'strict vars' is in 6771 * effect. This is illegal but is nonetheless parsed, so we 6772 * may reach this point with an OP_CONST where we're expecting 6773 * an OP_GV. 6774 */ 6775 if (cUNOPx(sv)->op_first->op_type == OP_GV 6776 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv) 6777 iterpflags |= OPpITER_DEF; 6778 } 6779 else if (sv->op_type == OP_PADSV) { /* private variable */ 6780 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */ 6781 padoff = sv->op_targ; 6782 if (PL_madskills) 6783 madsv = sv; 6784 else { 6785 sv->op_targ = 0; 6786 op_free(sv); 6787 } 6788 sv = NULL; 6789 } 6790 else 6791 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]); 6792 if (padoff) { 6793 SV *const namesv = PAD_COMPNAME_SV(padoff); 6794 STRLEN len; 6795 const char *const name = SvPV_const(namesv, len); 6796 6797 if (len == 2 && name[0] == '$' && name[1] == '_') 6798 iterpflags |= OPpITER_DEF; 6799 } 6800 } 6801 else { 6802 const PADOFFSET offset = pad_findmy_pvs("$_", 0); 6803 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) { 6804 sv = newGVOP(OP_GV, 0, PL_defgv); 6805 } 6806 else { 6807 padoff = offset; 6808 } 6809 iterpflags |= OPpITER_DEF; 6810 } 6811 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) { 6812 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART); 6813 iterflags |= OPf_STACKED; 6814 } 6815 else if (expr->op_type == OP_NULL && 6816 (expr->op_flags & OPf_KIDS) && 6817 ((BINOP*)expr)->op_first->op_type == OP_FLOP) 6818 { 6819 /* Basically turn for($x..$y) into the same as for($x,$y), but we 6820 * set the STACKED flag to indicate that these values are to be 6821 * treated as min/max values by 'pp_enteriter'. 6822 */ 6823 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first; 6824 LOGOP* const range = (LOGOP*) flip->op_first; 6825 OP* const left = range->op_first; 6826 OP* const right = left->op_sibling; 6827 LISTOP* listop; 6828 6829 range->op_flags &= ~OPf_KIDS; 6830 range->op_first = NULL; 6831 6832 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right); 6833 listop->op_first->op_next = range->op_next; 6834 left->op_next = range->op_other; 6835 right->op_next = (OP*)listop; 6836 listop->op_next = listop->op_first; 6837 6838 #ifdef PERL_MAD 6839 op_getmad(expr,(OP*)listop,'O'); 6840 #else 6841 op_free(expr); 6842 #endif 6843 expr = (OP*)(listop); 6844 op_null(expr); 6845 iterflags |= OPf_STACKED; 6846 } 6847 else { 6848 expr = op_lvalue(force_list(expr), OP_GREPSTART); 6849 } 6850 6851 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags, 6852 op_append_elem(OP_LIST, expr, scalar(sv)))); 6853 assert(!loop->op_next); 6854 /* for my $x () sets OPpLVAL_INTRO; 6855 * for our $x () sets OPpOUR_INTRO */ 6856 loop->op_private = (U8)iterpflags; 6857 if (loop->op_slabbed 6858 && DIFF(loop, OpSLOT(loop)->opslot_next) 6859 < SIZE_TO_PSIZE(sizeof(LOOP))) 6860 { 6861 LOOP *tmp; 6862 NewOp(1234,tmp,1,LOOP); 6863 Copy(loop,tmp,1,LISTOP); 6864 S_op_destroy(aTHX_ (OP*)loop); 6865 loop = tmp; 6866 } 6867 else if (!loop->op_slabbed) 6868 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP)); 6869 loop->op_targ = padoff; 6870 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0); 6871 if (madsv) 6872 op_getmad(madsv, (OP*)loop, 'v'); 6873 return wop; 6874 } 6875 6876 /* 6877 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label 6878 6879 Constructs, checks, and returns a loop-exiting op (such as C<goto> 6880 or C<last>). I<type> is the opcode. I<label> supplies the parameter 6881 determining the target of the op; it is consumed by this function and 6882 becomes part of the constructed op tree. 6883 6884 =cut 6885 */ 6886 6887 OP* 6888 Perl_newLOOPEX(pTHX_ I32 type, OP *label) 6889 { 6890 dVAR; 6891 OP *o = NULL; 6892 6893 PERL_ARGS_ASSERT_NEWLOOPEX; 6894 6895 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP); 6896 6897 if (type != OP_GOTO) { 6898 /* "last()" means "last" */ 6899 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) { 6900 o = newOP(type, OPf_SPECIAL); 6901 } 6902 } 6903 else { 6904 /* Check whether it's going to be a goto &function */ 6905 if (label->op_type == OP_ENTERSUB 6906 && !(label->op_flags & OPf_STACKED)) 6907 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN)); 6908 } 6909 6910 /* Check for a constant argument */ 6911 if (label->op_type == OP_CONST) { 6912 SV * const sv = ((SVOP *)label)->op_sv; 6913 STRLEN l; 6914 const char *s = SvPV_const(sv,l); 6915 if (l == strlen(s)) { 6916 o = newPVOP(type, 6917 SvUTF8(((SVOP*)label)->op_sv), 6918 savesharedpv( 6919 SvPV_nolen_const(((SVOP*)label)->op_sv))); 6920 } 6921 } 6922 6923 /* If we have already created an op, we do not need the label. */ 6924 if (o) 6925 #ifdef PERL_MAD 6926 op_getmad(label,o,'L'); 6927 #else 6928 op_free(label); 6929 #endif 6930 else o = newUNOP(type, OPf_STACKED, label); 6931 6932 PL_hints |= HINT_BLOCK_SCOPE; 6933 return o; 6934 } 6935 6936 /* if the condition is a literal array or hash 6937 (or @{ ... } etc), make a reference to it. 6938 */ 6939 STATIC OP * 6940 S_ref_array_or_hash(pTHX_ OP *cond) 6941 { 6942 if (cond 6943 && (cond->op_type == OP_RV2AV 6944 || cond->op_type == OP_PADAV 6945 || cond->op_type == OP_RV2HV 6946 || cond->op_type == OP_PADHV)) 6947 6948 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN)); 6949 6950 else if(cond 6951 && (cond->op_type == OP_ASLICE 6952 || cond->op_type == OP_KVASLICE 6953 || cond->op_type == OP_HSLICE 6954 || cond->op_type == OP_KVHSLICE)) { 6955 6956 /* anonlist now needs a list from this op, was previously used in 6957 * scalar context */ 6958 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF); 6959 cond->op_flags |= OPf_WANT_LIST; 6960 6961 return newANONLIST(op_lvalue(cond, OP_ANONLIST)); 6962 } 6963 6964 else 6965 return cond; 6966 } 6967 6968 /* These construct the optree fragments representing given() 6969 and when() blocks. 6970 6971 entergiven and enterwhen are LOGOPs; the op_other pointer 6972 points up to the associated leave op. We need this so we 6973 can put it in the context and make break/continue work. 6974 (Also, of course, pp_enterwhen will jump straight to 6975 op_other if the match fails.) 6976 */ 6977 6978 STATIC OP * 6979 S_newGIVWHENOP(pTHX_ OP *cond, OP *block, 6980 I32 enter_opcode, I32 leave_opcode, 6981 PADOFFSET entertarg) 6982 { 6983 dVAR; 6984 LOGOP *enterop; 6985 OP *o; 6986 6987 PERL_ARGS_ASSERT_NEWGIVWHENOP; 6988 6989 NewOp(1101, enterop, 1, LOGOP); 6990 enterop->op_type = (Optype)enter_opcode; 6991 enterop->op_ppaddr = PL_ppaddr[enter_opcode]; 6992 enterop->op_flags = (U8) OPf_KIDS; 6993 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg); 6994 enterop->op_private = 0; 6995 6996 o = newUNOP(leave_opcode, 0, (OP *) enterop); 6997 6998 if (cond) { 6999 enterop->op_first = scalar(cond); 7000 cond->op_sibling = block; 7001 7002 o->op_next = LINKLIST(cond); 7003 cond->op_next = (OP *) enterop; 7004 } 7005 else { 7006 /* This is a default {} block */ 7007 enterop->op_first = block; 7008 enterop->op_flags |= OPf_SPECIAL; 7009 o ->op_flags |= OPf_SPECIAL; 7010 7011 o->op_next = (OP *) enterop; 7012 } 7013 7014 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since 7015 entergiven and enterwhen both 7016 use ck_null() */ 7017 7018 enterop->op_next = LINKLIST(block); 7019 block->op_next = enterop->op_other = o; 7020 7021 return o; 7022 } 7023 7024 /* Does this look like a boolean operation? For these purposes 7025 a boolean operation is: 7026 - a subroutine call [*] 7027 - a logical connective 7028 - a comparison operator 7029 - a filetest operator, with the exception of -s -M -A -C 7030 - defined(), exists() or eof() 7031 - /$re/ or $foo =~ /$re/ 7032 7033 [*] possibly surprising 7034 */ 7035 STATIC bool 7036 S_looks_like_bool(pTHX_ const OP *o) 7037 { 7038 dVAR; 7039 7040 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL; 7041 7042 switch(o->op_type) { 7043 case OP_OR: 7044 case OP_DOR: 7045 return looks_like_bool(cLOGOPo->op_first); 7046 7047 case OP_AND: 7048 return ( 7049 looks_like_bool(cLOGOPo->op_first) 7050 && looks_like_bool(cLOGOPo->op_first->op_sibling)); 7051 7052 case OP_NULL: 7053 case OP_SCALAR: 7054 return ( 7055 o->op_flags & OPf_KIDS 7056 && looks_like_bool(cUNOPo->op_first)); 7057 7058 case OP_ENTERSUB: 7059 7060 case OP_NOT: case OP_XOR: 7061 7062 case OP_EQ: case OP_NE: case OP_LT: 7063 case OP_GT: case OP_LE: case OP_GE: 7064 7065 case OP_I_EQ: case OP_I_NE: case OP_I_LT: 7066 case OP_I_GT: case OP_I_LE: case OP_I_GE: 7067 7068 case OP_SEQ: case OP_SNE: case OP_SLT: 7069 case OP_SGT: case OP_SLE: case OP_SGE: 7070 7071 case OP_SMARTMATCH: 7072 7073 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC: 7074 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC: 7075 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED: 7076 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR: 7077 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR: 7078 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID: 7079 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY: 7080 case OP_FTTEXT: case OP_FTBINARY: 7081 7082 case OP_DEFINED: case OP_EXISTS: 7083 case OP_MATCH: case OP_EOF: 7084 7085 case OP_FLOP: 7086 7087 return TRUE; 7088 7089 case OP_CONST: 7090 /* Detect comparisons that have been optimized away */ 7091 if (cSVOPo->op_sv == &PL_sv_yes 7092 || cSVOPo->op_sv == &PL_sv_no) 7093 7094 return TRUE; 7095 else 7096 return FALSE; 7097 7098 /* FALL THROUGH */ 7099 default: 7100 return FALSE; 7101 } 7102 } 7103 7104 /* 7105 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off 7106 7107 Constructs, checks, and returns an op tree expressing a C<given> block. 7108 I<cond> supplies the expression that will be locally assigned to a lexical 7109 variable, and I<block> supplies the body of the C<given> construct; they 7110 are consumed by this function and become part of the constructed op tree. 7111 I<defsv_off> is the pad offset of the scalar lexical variable that will 7112 be affected. If it is 0, the global $_ will be used. 7113 7114 =cut 7115 */ 7116 7117 OP * 7118 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off) 7119 { 7120 dVAR; 7121 PERL_ARGS_ASSERT_NEWGIVENOP; 7122 return newGIVWHENOP( 7123 ref_array_or_hash(cond), 7124 block, 7125 OP_ENTERGIVEN, OP_LEAVEGIVEN, 7126 defsv_off); 7127 } 7128 7129 /* 7130 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block 7131 7132 Constructs, checks, and returns an op tree expressing a C<when> block. 7133 I<cond> supplies the test expression, and I<block> supplies the block 7134 that will be executed if the test evaluates to true; they are consumed 7135 by this function and become part of the constructed op tree. I<cond> 7136 will be interpreted DWIMically, often as a comparison against C<$_>, 7137 and may be null to generate a C<default> block. 7138 7139 =cut 7140 */ 7141 7142 OP * 7143 Perl_newWHENOP(pTHX_ OP *cond, OP *block) 7144 { 7145 const bool cond_llb = (!cond || looks_like_bool(cond)); 7146 OP *cond_op; 7147 7148 PERL_ARGS_ASSERT_NEWWHENOP; 7149 7150 if (cond_llb) 7151 cond_op = cond; 7152 else { 7153 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL, 7154 newDEFSVOP(), 7155 scalar(ref_array_or_hash(cond))); 7156 } 7157 7158 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0); 7159 } 7160 7161 void 7162 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p, 7163 const STRLEN len, const U32 flags) 7164 { 7165 SV *name = NULL, *msg; 7166 const char * cvp = SvROK(cv) ? "" : CvPROTO(cv); 7167 STRLEN clen = CvPROTOLEN(cv), plen = len; 7168 7169 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS; 7170 7171 if (p == NULL && cvp == NULL) 7172 return; 7173 7174 if (!ckWARN_d(WARN_PROTOTYPE)) 7175 return; 7176 7177 if (p && cvp) { 7178 p = S_strip_spaces(aTHX_ p, &plen); 7179 cvp = S_strip_spaces(aTHX_ cvp, &clen); 7180 if ((flags & SVf_UTF8) == SvUTF8(cv)) { 7181 if (plen == clen && memEQ(cvp, p, plen)) 7182 return; 7183 } else { 7184 if (flags & SVf_UTF8) { 7185 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0) 7186 return; 7187 } 7188 else { 7189 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0) 7190 return; 7191 } 7192 } 7193 } 7194 7195 msg = sv_newmortal(); 7196 7197 if (gv) 7198 { 7199 if (isGV(gv)) 7200 gv_efullname3(name = sv_newmortal(), gv, NULL); 7201 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&') 7202 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP); 7203 else name = (SV *)gv; 7204 } 7205 sv_setpvs(msg, "Prototype mismatch:"); 7206 if (name) 7207 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name)); 7208 if (cvp) 7209 Perl_sv_catpvf(aTHX_ msg, " (%"UTF8f")", 7210 UTF8fARG(SvUTF8(cv),clen,cvp) 7211 ); 7212 else 7213 sv_catpvs(msg, ": none"); 7214 sv_catpvs(msg, " vs "); 7215 if (p) 7216 Perl_sv_catpvf(aTHX_ msg, "(%"UTF8f")", UTF8fARG(flags & SVf_UTF8,len,p)); 7217 else 7218 sv_catpvs(msg, "none"); 7219 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg)); 7220 } 7221 7222 static void const_sv_xsub(pTHX_ CV* cv); 7223 static void const_av_xsub(pTHX_ CV* cv); 7224 7225 /* 7226 7227 =head1 Optree Manipulation Functions 7228 7229 =for apidoc cv_const_sv 7230 7231 If C<cv> is a constant sub eligible for inlining, returns the constant 7232 value returned by the sub. Otherwise, returns NULL. 7233 7234 Constant subs can be created with C<newCONSTSUB> or as described in 7235 L<perlsub/"Constant Functions">. 7236 7237 =cut 7238 */ 7239 SV * 7240 Perl_cv_const_sv(pTHX_ const CV *const cv) 7241 { 7242 SV *sv; 7243 PERL_UNUSED_CONTEXT; 7244 if (!cv) 7245 return NULL; 7246 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM)) 7247 return NULL; 7248 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL; 7249 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL; 7250 return sv; 7251 } 7252 7253 SV * 7254 Perl_cv_const_sv_or_av(pTHX_ const CV * const cv) 7255 { 7256 PERL_UNUSED_CONTEXT; 7257 if (!cv) 7258 return NULL; 7259 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM); 7260 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL; 7261 } 7262 7263 /* op_const_sv: examine an optree to determine whether it's in-lineable. 7264 * Can be called in 3 ways: 7265 * 7266 * !cv 7267 * look for a single OP_CONST with attached value: return the value 7268 * 7269 * cv && CvCLONE(cv) && !CvCONST(cv) 7270 * 7271 * examine the clone prototype, and if contains only a single 7272 * OP_CONST referencing a pad const, or a single PADSV referencing 7273 * an outer lexical, return a non-zero value to indicate the CV is 7274 * a candidate for "constizing" at clone time 7275 * 7276 * cv && CvCONST(cv) 7277 * 7278 * We have just cloned an anon prototype that was marked as a const 7279 * candidate. Try to grab the current value, and in the case of 7280 * PADSV, ignore it if it has multiple references. In this case we 7281 * return a newly created *copy* of the value. 7282 */ 7283 7284 SV * 7285 Perl_op_const_sv(pTHX_ const OP *o, CV *cv) 7286 { 7287 dVAR; 7288 SV *sv = NULL; 7289 7290 if (PL_madskills) 7291 return NULL; 7292 7293 if (!o) 7294 return NULL; 7295 7296 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first) 7297 o = cLISTOPo->op_first->op_sibling; 7298 7299 for (; o; o = o->op_next) { 7300 const OPCODE type = o->op_type; 7301 7302 if (sv && o->op_next == o) 7303 return sv; 7304 if (o->op_next != o) { 7305 if (type == OP_NEXTSTATE 7306 || (type == OP_NULL && !(o->op_flags & OPf_KIDS)) 7307 || type == OP_PUSHMARK) 7308 continue; 7309 if (type == OP_DBSTATE) 7310 continue; 7311 } 7312 if (type == OP_LEAVESUB || type == OP_RETURN) 7313 break; 7314 if (sv) 7315 return NULL; 7316 if (type == OP_CONST && cSVOPo->op_sv) 7317 sv = cSVOPo->op_sv; 7318 else if (cv && type == OP_CONST) { 7319 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ); 7320 if (!sv) 7321 return NULL; 7322 } 7323 else if (cv && type == OP_PADSV) { 7324 if (CvCONST(cv)) { /* newly cloned anon */ 7325 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ); 7326 /* the candidate should have 1 ref from this pad and 1 ref 7327 * from the parent */ 7328 if (!sv || SvREFCNT(sv) != 2) 7329 return NULL; 7330 sv = newSVsv(sv); 7331 SvREADONLY_on(sv); 7332 return sv; 7333 } 7334 else { 7335 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE) 7336 sv = &PL_sv_undef; /* an arbitrary non-null value */ 7337 } 7338 } 7339 else { 7340 return NULL; 7341 } 7342 } 7343 return sv; 7344 } 7345 7346 static bool 7347 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o, 7348 PADNAME * const name, SV ** const const_svp) 7349 { 7350 assert (cv); 7351 assert (o || name); 7352 assert (const_svp); 7353 if ((!block 7354 #ifdef PERL_MAD 7355 || block->op_type == OP_NULL 7356 #endif 7357 )) { 7358 if (CvFLAGS(PL_compcv)) { 7359 /* might have had built-in attrs applied */ 7360 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv); 7361 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl 7362 && ckWARN(WARN_MISC)) 7363 { 7364 /* protect against fatal warnings leaking compcv */ 7365 SAVEFREESV(PL_compcv); 7366 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined"); 7367 SvREFCNT_inc_simple_void_NN(PL_compcv); 7368 } 7369 CvFLAGS(cv) |= 7370 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS 7371 & ~(CVf_LVALUE * pureperl)); 7372 } 7373 return FALSE; 7374 } 7375 7376 /* redundant check for speed: */ 7377 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) { 7378 const line_t oldline = CopLINE(PL_curcop); 7379 SV *namesv = o 7380 ? cSVOPo->op_sv 7381 : sv_2mortal(newSVpvn_utf8( 7382 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name) 7383 )); 7384 if (PL_parser && PL_parser->copline != NOLINE) 7385 /* This ensures that warnings are reported at the first 7386 line of a redefinition, not the last. */ 7387 CopLINE_set(PL_curcop, PL_parser->copline); 7388 /* protect against fatal warnings leaking compcv */ 7389 SAVEFREESV(PL_compcv); 7390 report_redefined_cv(namesv, cv, const_svp); 7391 SvREFCNT_inc_simple_void_NN(PL_compcv); 7392 CopLINE_set(PL_curcop, oldline); 7393 } 7394 #ifdef PERL_MAD 7395 if (!PL_minus_c) /* keep old one around for madskills */ 7396 #endif 7397 { 7398 /* (PL_madskills unset in used file.) */ 7399 SAVEFREESV(cv); 7400 } 7401 return TRUE; 7402 } 7403 7404 CV * 7405 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) 7406 { 7407 dVAR; 7408 CV **spot; 7409 SV **svspot; 7410 const char *ps; 7411 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */ 7412 U32 ps_utf8 = 0; 7413 CV *cv = NULL; 7414 CV *compcv = PL_compcv; 7415 SV *const_sv; 7416 PADNAME *name; 7417 PADOFFSET pax = o->op_targ; 7418 CV *outcv = CvOUTSIDE(PL_compcv); 7419 CV *clonee = NULL; 7420 HEK *hek = NULL; 7421 bool reusable = FALSE; 7422 7423 PERL_ARGS_ASSERT_NEWMYSUB; 7424 7425 /* Find the pad slot for storing the new sub. 7426 We cannot use PL_comppad, as it is the pad owned by the new sub. We 7427 need to look in CvOUTSIDE and find the pad belonging to the enclos- 7428 ing sub. And then we need to dig deeper if this is a lexical from 7429 outside, as in: 7430 my sub foo; sub { sub foo { } } 7431 */ 7432 redo: 7433 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax]; 7434 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) { 7435 pax = PARENT_PAD_INDEX(name); 7436 outcv = CvOUTSIDE(outcv); 7437 assert(outcv); 7438 goto redo; 7439 } 7440 svspot = 7441 &PadARRAY(PadlistARRAY(CvPADLIST(outcv)) 7442 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax]; 7443 spot = (CV **)svspot; 7444 7445 if (!(PL_parser && PL_parser->error_count)) 7446 move_proto_attr(&proto, &attrs, (GV *)name); 7447 7448 if (proto) { 7449 assert(proto->op_type == OP_CONST); 7450 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len); 7451 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv); 7452 } 7453 else 7454 ps = NULL; 7455 7456 if (!PL_madskills) { 7457 if (proto) 7458 SAVEFREEOP(proto); 7459 if (attrs) 7460 SAVEFREEOP(attrs); 7461 } 7462 7463 if (PL_parser && PL_parser->error_count) { 7464 op_free(block); 7465 SvREFCNT_dec(PL_compcv); 7466 PL_compcv = 0; 7467 goto done; 7468 } 7469 7470 if (CvDEPTH(outcv) && CvCLONE(compcv)) { 7471 cv = *spot; 7472 svspot = (SV **)(spot = &clonee); 7473 } 7474 else if (PadnameIsSTATE(name) || CvDEPTH(outcv)) 7475 cv = *spot; 7476 else { 7477 MAGIC *mg; 7478 SvUPGRADE(name, SVt_PVMG); 7479 mg = mg_find(name, PERL_MAGIC_proto); 7480 assert (SvTYPE(*spot) == SVt_PVCV); 7481 if (CvNAMED(*spot)) 7482 hek = CvNAME_HEK(*spot); 7483 else { 7484 CvNAME_HEK_set(*spot, hek = 7485 share_hek( 7486 PadnamePV(name)+1, 7487 PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), 0 7488 ) 7489 ); 7490 } 7491 if (mg) { 7492 assert(mg->mg_obj); 7493 cv = (CV *)mg->mg_obj; 7494 } 7495 else { 7496 sv_magic(name, &PL_sv_undef, PERL_MAGIC_proto, NULL, 0); 7497 mg = mg_find(name, PERL_MAGIC_proto); 7498 } 7499 spot = (CV **)(svspot = &mg->mg_obj); 7500 } 7501 7502 if (!block || !ps || *ps || attrs 7503 || (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS) 7504 #ifdef PERL_MAD 7505 || block->op_type == OP_NULL 7506 #endif 7507 ) 7508 const_sv = NULL; 7509 else 7510 const_sv = op_const_sv(block, NULL); 7511 7512 if (cv) { 7513 const bool exists = CvROOT(cv) || CvXSUB(cv); 7514 7515 /* if the subroutine doesn't exist and wasn't pre-declared 7516 * with a prototype, assume it will be AUTOLOADed, 7517 * skipping the prototype check 7518 */ 7519 if (exists || SvPOK(cv)) 7520 cv_ckproto_len_flags(cv, (GV *)name, ps, ps_len, ps_utf8); 7521 /* already defined? */ 7522 if (exists) { 7523 if (S_already_defined(aTHX_ cv,block,NULL,name,&const_sv)) 7524 cv = NULL; 7525 else { 7526 if (attrs) goto attrs; 7527 /* just a "sub foo;" when &foo is already defined */ 7528 SAVEFREESV(compcv); 7529 goto done; 7530 } 7531 } 7532 else if (CvDEPTH(outcv) && CvCLONE(compcv)) { 7533 cv = NULL; 7534 reusable = TRUE; 7535 } 7536 } 7537 if (const_sv) { 7538 SvREFCNT_inc_simple_void_NN(const_sv); 7539 SvFLAGS(const_sv) = (SvFLAGS(const_sv) & ~SVs_PADMY) | SVs_PADTMP; 7540 if (cv) { 7541 assert(!CvROOT(cv) && !CvCONST(cv)); 7542 cv_forget_slab(cv); 7543 } 7544 else { 7545 cv = MUTABLE_CV(newSV_type(SVt_PVCV)); 7546 CvFILE_set_from_cop(cv, PL_curcop); 7547 CvSTASH_set(cv, PL_curstash); 7548 *spot = cv; 7549 } 7550 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */ 7551 CvXSUBANY(cv).any_ptr = const_sv; 7552 CvXSUB(cv) = const_sv_xsub; 7553 CvCONST_on(cv); 7554 CvISXSUB_on(cv); 7555 if (PL_madskills) 7556 goto install_block; 7557 op_free(block); 7558 SvREFCNT_dec(compcv); 7559 PL_compcv = NULL; 7560 goto setname; 7561 } 7562 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to 7563 determine whether this sub definition is in the same scope as its 7564 declaration. If this sub definition is inside an inner named pack- 7565 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to 7566 the package sub. So check PadnameOUTER(name) too. 7567 */ 7568 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) { 7569 assert(!CvWEAKOUTSIDE(compcv)); 7570 SvREFCNT_dec(CvOUTSIDE(compcv)); 7571 CvWEAKOUTSIDE_on(compcv); 7572 } 7573 /* XXX else do we have a circular reference? */ 7574 if (cv) { /* must reuse cv in case stub is referenced elsewhere */ 7575 /* transfer PL_compcv to cv */ 7576 if (block 7577 #ifdef PERL_MAD 7578 && block->op_type != OP_NULL 7579 #endif 7580 ) { 7581 cv_flags_t preserved_flags = 7582 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED); 7583 PADLIST *const temp_padl = CvPADLIST(cv); 7584 CV *const temp_cv = CvOUTSIDE(cv); 7585 const cv_flags_t other_flags = 7586 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE); 7587 OP * const cvstart = CvSTART(cv); 7588 7589 SvPOK_off(cv); 7590 CvFLAGS(cv) = 7591 CvFLAGS(compcv) | preserved_flags; 7592 CvOUTSIDE(cv) = CvOUTSIDE(compcv); 7593 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv); 7594 CvPADLIST(cv) = CvPADLIST(compcv); 7595 CvOUTSIDE(compcv) = temp_cv; 7596 CvPADLIST(compcv) = temp_padl; 7597 CvSTART(cv) = CvSTART(compcv); 7598 CvSTART(compcv) = cvstart; 7599 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE); 7600 CvFLAGS(compcv) |= other_flags; 7601 7602 if (CvFILE(cv) && CvDYNFILE(cv)) { 7603 Safefree(CvFILE(cv)); 7604 } 7605 7606 /* inner references to compcv must be fixed up ... */ 7607 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv); 7608 if (PERLDB_INTER)/* Advice debugger on the new sub. */ 7609 ++PL_sub_generation; 7610 } 7611 else { 7612 /* Might have had built-in attributes applied -- propagate them. */ 7613 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS); 7614 } 7615 /* ... before we throw it away */ 7616 SvREFCNT_dec(compcv); 7617 PL_compcv = compcv = cv; 7618 } 7619 else { 7620 cv = compcv; 7621 *spot = cv; 7622 } 7623 setname: 7624 if (!CvNAME_HEK(cv)) { 7625 CvNAME_HEK_set(cv, 7626 hek 7627 ? share_hek_hek(hek) 7628 : share_hek(PadnamePV(name)+1, 7629 PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), 7630 0) 7631 ); 7632 } 7633 if (const_sv) goto clone; 7634 7635 CvFILE_set_from_cop(cv, PL_curcop); 7636 CvSTASH_set(cv, PL_curstash); 7637 7638 if (ps) { 7639 sv_setpvn(MUTABLE_SV(cv), ps, ps_len); 7640 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv)); 7641 } 7642 7643 install_block: 7644 if (!block) 7645 goto attrs; 7646 7647 /* If we assign an optree to a PVCV, then we've defined a subroutine that 7648 the debugger could be able to set a breakpoint in, so signal to 7649 pp_entereval that it should not throw away any saved lines at scope 7650 exit. */ 7651 7652 PL_breakable_sub_gen++; 7653 /* This makes sub {}; work as expected. */ 7654 if (block->op_type == OP_STUB) { 7655 OP* const newblock = newSTATEOP(0, NULL, 0); 7656 #ifdef PERL_MAD 7657 op_getmad(block,newblock,'B'); 7658 #else 7659 op_free(block); 7660 #endif 7661 block = newblock; 7662 } 7663 CvROOT(cv) = CvLVALUE(cv) 7664 ? newUNOP(OP_LEAVESUBLV, 0, 7665 op_lvalue(scalarseq(block), OP_LEAVESUBLV)) 7666 : newUNOP(OP_LEAVESUB, 0, scalarseq(block)); 7667 CvROOT(cv)->op_private |= OPpREFCOUNTED; 7668 OpREFCNT_set(CvROOT(cv), 1); 7669 /* The cv no longer needs to hold a refcount on the slab, as CvROOT 7670 itself has a refcount. */ 7671 CvSLABBED_off(cv); 7672 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv)); 7673 CvSTART(cv) = LINKLIST(CvROOT(cv)); 7674 CvROOT(cv)->op_next = 0; 7675 CALL_PEEP(CvSTART(cv)); 7676 finalize_optree(CvROOT(cv)); 7677 S_prune_chain_head(aTHX_ &CvSTART(cv)); 7678 7679 /* now that optimizer has done its work, adjust pad values */ 7680 7681 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB); 7682 7683 if (CvCLONE(cv)) { 7684 assert(!CvCONST(cv)); 7685 if (ps && !*ps && op_const_sv(block, cv)) 7686 CvCONST_on(cv); 7687 } 7688 7689 attrs: 7690 if (attrs) { 7691 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */ 7692 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs); 7693 } 7694 7695 if (block) { 7696 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) { 7697 SV * const tmpstr = sv_newmortal(); 7698 GV * const db_postponed = gv_fetchpvs("DB::postponed", 7699 GV_ADDMULTI, SVt_PVHV); 7700 HV *hv; 7701 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld", 7702 CopFILE(PL_curcop), 7703 (long)PL_subline, 7704 (long)CopLINE(PL_curcop)); 7705 if (HvNAME_HEK(PL_curstash)) { 7706 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash)); 7707 sv_catpvs(tmpstr, "::"); 7708 } 7709 else sv_setpvs(tmpstr, "__ANON__::"); 7710 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1, 7711 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES); 7712 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), 7713 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0); 7714 hv = GvHVn(db_postponed); 7715 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) { 7716 CV * const pcv = GvCV(db_postponed); 7717 if (pcv) { 7718 dSP; 7719 PUSHMARK(SP); 7720 XPUSHs(tmpstr); 7721 PUTBACK; 7722 call_sv(MUTABLE_SV(pcv), G_DISCARD); 7723 } 7724 } 7725 } 7726 } 7727 7728 clone: 7729 if (clonee) { 7730 assert(CvDEPTH(outcv)); 7731 spot = (CV **) 7732 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax]; 7733 if (reusable) cv_clone_into(clonee, *spot); 7734 else *spot = cv_clone(clonee); 7735 SvREFCNT_dec_NN(clonee); 7736 cv = *spot; 7737 SvPADMY_on(cv); 7738 } 7739 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) { 7740 PADOFFSET depth = CvDEPTH(outcv); 7741 while (--depth) { 7742 SV *oldcv; 7743 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax]; 7744 oldcv = *svspot; 7745 *svspot = SvREFCNT_inc_simple_NN(cv); 7746 SvREFCNT_dec(oldcv); 7747 } 7748 } 7749 7750 done: 7751 if (PL_parser) 7752 PL_parser->copline = NOLINE; 7753 LEAVE_SCOPE(floor); 7754 if (o) op_free(o); 7755 return cv; 7756 } 7757 7758 /* _x = extended */ 7759 CV * 7760 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, 7761 OP *block, bool o_is_gv) 7762 { 7763 dVAR; 7764 GV *gv; 7765 const char *ps; 7766 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */ 7767 U32 ps_utf8 = 0; 7768 CV *cv = NULL; 7769 SV *const_sv; 7770 const bool ec = PL_parser && PL_parser->error_count; 7771 /* If the subroutine has no body, no attributes, and no builtin attributes 7772 then it's just a sub declaration, and we may be able to get away with 7773 storing with a placeholder scalar in the symbol table, rather than a 7774 full GV and CV. If anything is present then it will take a full CV to 7775 store it. */ 7776 const I32 gv_fetch_flags 7777 = ec ? GV_NOADD_NOINIT : 7778 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS) 7779 || PL_madskills) 7780 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT; 7781 STRLEN namlen = 0; 7782 const char * const name = 7783 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL; 7784 bool has_name; 7785 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv); 7786 #ifdef PERL_DEBUG_READONLY_OPS 7787 OPSLAB *slab = NULL; 7788 #endif 7789 7790 if (o_is_gv) { 7791 gv = (GV*)o; 7792 o = NULL; 7793 has_name = TRUE; 7794 } else if (name) { 7795 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV); 7796 has_name = TRUE; 7797 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) { 7798 SV * const sv = sv_newmortal(); 7799 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]", 7800 PL_curstash ? "__ANON__" : "__ANON__::__ANON__", 7801 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); 7802 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV); 7803 has_name = TRUE; 7804 } else if (PL_curstash) { 7805 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV); 7806 has_name = FALSE; 7807 } else { 7808 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV); 7809 has_name = FALSE; 7810 } 7811 7812 if (!ec) 7813 move_proto_attr(&proto, &attrs, gv); 7814 7815 if (proto) { 7816 assert(proto->op_type == OP_CONST); 7817 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len); 7818 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv); 7819 } 7820 else 7821 ps = NULL; 7822 7823 if (!PL_madskills) { 7824 if (o) 7825 SAVEFREEOP(o); 7826 if (proto) 7827 SAVEFREEOP(proto); 7828 if (attrs) 7829 SAVEFREEOP(attrs); 7830 } 7831 7832 if (ec) { 7833 op_free(block); 7834 if (name) SvREFCNT_dec(PL_compcv); 7835 else cv = PL_compcv; 7836 PL_compcv = 0; 7837 if (name && block) { 7838 const char *s = strrchr(name, ':'); 7839 s = s ? s+1 : name; 7840 if (strEQ(s, "BEGIN")) { 7841 if (PL_in_eval & EVAL_KEEPERR) 7842 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted"); 7843 else { 7844 SV * const errsv = ERRSV; 7845 /* force display of errors found but not reported */ 7846 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted"); 7847 Perl_croak_nocontext("%"SVf, SVfARG(errsv)); 7848 } 7849 } 7850 } 7851 goto done; 7852 } 7853 7854 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at 7855 maximum a prototype before. */ 7856 if (SvTYPE(gv) > SVt_NULL) { 7857 cv_ckproto_len_flags((const CV *)gv, 7858 o ? (const GV *)cSVOPo->op_sv : NULL, ps, 7859 ps_len, ps_utf8); 7860 } 7861 if (ps) { 7862 sv_setpvn(MUTABLE_SV(gv), ps, ps_len); 7863 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv)); 7864 } 7865 else 7866 sv_setiv(MUTABLE_SV(gv), -1); 7867 7868 SvREFCNT_dec(PL_compcv); 7869 cv = PL_compcv = NULL; 7870 goto done; 7871 } 7872 7873 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv); 7874 7875 if (!block || !ps || *ps || attrs 7876 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS) 7877 #ifdef PERL_MAD 7878 || block->op_type == OP_NULL 7879 #endif 7880 ) 7881 const_sv = NULL; 7882 else 7883 const_sv = op_const_sv(block, NULL); 7884 7885 if (cv) { 7886 const bool exists = CvROOT(cv) || CvXSUB(cv); 7887 7888 /* if the subroutine doesn't exist and wasn't pre-declared 7889 * with a prototype, assume it will be AUTOLOADed, 7890 * skipping the prototype check 7891 */ 7892 if (exists || SvPOK(cv)) 7893 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8); 7894 /* already defined (or promised)? */ 7895 if (exists || GvASSUMECV(gv)) { 7896 if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv)) 7897 cv = NULL; 7898 else { 7899 if (attrs) goto attrs; 7900 /* just a "sub foo;" when &foo is already defined */ 7901 SAVEFREESV(PL_compcv); 7902 goto done; 7903 } 7904 } 7905 } 7906 if (const_sv) { 7907 SvREFCNT_inc_simple_void_NN(const_sv); 7908 SvFLAGS(const_sv) = (SvFLAGS(const_sv) & ~SVs_PADMY) | SVs_PADTMP; 7909 if (cv) { 7910 assert(!CvROOT(cv) && !CvCONST(cv)); 7911 cv_forget_slab(cv); 7912 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */ 7913 CvXSUBANY(cv).any_ptr = const_sv; 7914 CvXSUB(cv) = const_sv_xsub; 7915 CvCONST_on(cv); 7916 CvISXSUB_on(cv); 7917 } 7918 else { 7919 GvCV_set(gv, NULL); 7920 cv = newCONSTSUB_flags( 7921 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0, 7922 const_sv 7923 ); 7924 } 7925 if (PL_madskills) 7926 goto install_block; 7927 op_free(block); 7928 SvREFCNT_dec(PL_compcv); 7929 PL_compcv = NULL; 7930 goto done; 7931 } 7932 if (cv) { /* must reuse cv if autoloaded */ 7933 /* transfer PL_compcv to cv */ 7934 if (block 7935 #ifdef PERL_MAD 7936 && block->op_type != OP_NULL 7937 #endif 7938 ) { 7939 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS; 7940 PADLIST *const temp_av = CvPADLIST(cv); 7941 CV *const temp_cv = CvOUTSIDE(cv); 7942 const cv_flags_t other_flags = 7943 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE); 7944 OP * const cvstart = CvSTART(cv); 7945 7946 CvGV_set(cv,gv); 7947 assert(!CvCVGV_RC(cv)); 7948 assert(CvGV(cv) == gv); 7949 7950 SvPOK_off(cv); 7951 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs; 7952 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv); 7953 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv); 7954 CvPADLIST(cv) = CvPADLIST(PL_compcv); 7955 CvOUTSIDE(PL_compcv) = temp_cv; 7956 CvPADLIST(PL_compcv) = temp_av; 7957 CvSTART(cv) = CvSTART(PL_compcv); 7958 CvSTART(PL_compcv) = cvstart; 7959 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE); 7960 CvFLAGS(PL_compcv) |= other_flags; 7961 7962 if (CvFILE(cv) && CvDYNFILE(cv)) { 7963 Safefree(CvFILE(cv)); 7964 } 7965 CvFILE_set_from_cop(cv, PL_curcop); 7966 CvSTASH_set(cv, PL_curstash); 7967 7968 /* inner references to PL_compcv must be fixed up ... */ 7969 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv); 7970 if (PERLDB_INTER)/* Advice debugger on the new sub. */ 7971 ++PL_sub_generation; 7972 } 7973 else { 7974 /* Might have had built-in attributes applied -- propagate them. */ 7975 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS); 7976 } 7977 /* ... before we throw it away */ 7978 SvREFCNT_dec(PL_compcv); 7979 PL_compcv = cv; 7980 } 7981 else { 7982 cv = PL_compcv; 7983 if (name) { 7984 GvCV_set(gv, cv); 7985 GvCVGEN(gv) = 0; 7986 if (HvENAME_HEK(GvSTASH(gv))) 7987 /* sub Foo::bar { (shift)+1 } */ 7988 gv_method_changed(gv); 7989 } 7990 } 7991 if (!CvGV(cv)) { 7992 CvGV_set(cv, gv); 7993 CvFILE_set_from_cop(cv, PL_curcop); 7994 CvSTASH_set(cv, PL_curstash); 7995 } 7996 7997 if (ps) { 7998 sv_setpvn(MUTABLE_SV(cv), ps, ps_len); 7999 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv)); 8000 } 8001 8002 install_block: 8003 if (!block) 8004 goto attrs; 8005 8006 /* If we assign an optree to a PVCV, then we've defined a subroutine that 8007 the debugger could be able to set a breakpoint in, so signal to 8008 pp_entereval that it should not throw away any saved lines at scope 8009 exit. */ 8010 8011 PL_breakable_sub_gen++; 8012 /* This makes sub {}; work as expected. */ 8013 if (block->op_type == OP_STUB) { 8014 OP* const newblock = newSTATEOP(0, NULL, 0); 8015 #ifdef PERL_MAD 8016 op_getmad(block,newblock,'B'); 8017 #else 8018 op_free(block); 8019 #endif 8020 block = newblock; 8021 } 8022 CvROOT(cv) = CvLVALUE(cv) 8023 ? newUNOP(OP_LEAVESUBLV, 0, 8024 op_lvalue(scalarseq(block), OP_LEAVESUBLV)) 8025 : newUNOP(OP_LEAVESUB, 0, scalarseq(block)); 8026 CvROOT(cv)->op_private |= OPpREFCOUNTED; 8027 OpREFCNT_set(CvROOT(cv), 1); 8028 /* The cv no longer needs to hold a refcount on the slab, as CvROOT 8029 itself has a refcount. */ 8030 CvSLABBED_off(cv); 8031 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv)); 8032 #ifdef PERL_DEBUG_READONLY_OPS 8033 slab = (OPSLAB *)CvSTART(cv); 8034 #endif 8035 CvSTART(cv) = LINKLIST(CvROOT(cv)); 8036 CvROOT(cv)->op_next = 0; 8037 CALL_PEEP(CvSTART(cv)); 8038 finalize_optree(CvROOT(cv)); 8039 S_prune_chain_head(aTHX_ &CvSTART(cv)); 8040 8041 /* now that optimizer has done its work, adjust pad values */ 8042 8043 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB); 8044 8045 if (CvCLONE(cv)) { 8046 assert(!CvCONST(cv)); 8047 if (ps && !*ps && op_const_sv(block, cv)) 8048 CvCONST_on(cv); 8049 } 8050 8051 attrs: 8052 if (attrs) { 8053 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */ 8054 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash; 8055 if (!name) SAVEFREESV(cv); 8056 apply_attrs(stash, MUTABLE_SV(cv), attrs); 8057 if (!name) SvREFCNT_inc_simple_void_NN(cv); 8058 } 8059 8060 if (block && has_name) { 8061 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) { 8062 SV * const tmpstr = sv_newmortal(); 8063 GV * const db_postponed = gv_fetchpvs("DB::postponed", 8064 GV_ADDMULTI, SVt_PVHV); 8065 HV *hv; 8066 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld", 8067 CopFILE(PL_curcop), 8068 (long)PL_subline, 8069 (long)CopLINE(PL_curcop)); 8070 gv_efullname3(tmpstr, gv, NULL); 8071 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), 8072 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0); 8073 hv = GvHVn(db_postponed); 8074 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) { 8075 CV * const pcv = GvCV(db_postponed); 8076 if (pcv) { 8077 dSP; 8078 PUSHMARK(SP); 8079 XPUSHs(tmpstr); 8080 PUTBACK; 8081 call_sv(MUTABLE_SV(pcv), G_DISCARD); 8082 } 8083 } 8084 } 8085 8086 if (name && ! (PL_parser && PL_parser->error_count)) 8087 process_special_blocks(floor, name, gv, cv); 8088 } 8089 8090 done: 8091 if (PL_parser) 8092 PL_parser->copline = NOLINE; 8093 LEAVE_SCOPE(floor); 8094 #ifdef PERL_DEBUG_READONLY_OPS 8095 /* Watch out for BEGIN blocks */ 8096 if (slab && gv && isGV(gv) && GvCV(gv)) Slab_to_ro(slab); 8097 #endif 8098 return cv; 8099 } 8100 8101 STATIC void 8102 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, 8103 GV *const gv, 8104 CV *const cv) 8105 { 8106 const char *const colon = strrchr(fullname,':'); 8107 const char *const name = colon ? colon + 1 : fullname; 8108 8109 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS; 8110 8111 if (*name == 'B') { 8112 if (strEQ(name, "BEGIN")) { 8113 const I32 oldscope = PL_scopestack_ix; 8114 dSP; 8115 if (floor) LEAVE_SCOPE(floor); 8116 ENTER; 8117 PUSHSTACKi(PERLSI_REQUIRE); 8118 SAVECOPFILE(&PL_compiling); 8119 SAVECOPLINE(&PL_compiling); 8120 SAVEVPTR(PL_curcop); 8121 8122 DEBUG_x( dump_sub(gv) ); 8123 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv)); 8124 GvCV_set(gv,0); /* cv has been hijacked */ 8125 call_list(oldscope, PL_beginav); 8126 8127 POPSTACK; 8128 LEAVE; 8129 } 8130 else 8131 return; 8132 } else { 8133 if (*name == 'E') { 8134 if strEQ(name, "END") { 8135 DEBUG_x( dump_sub(gv) ); 8136 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv)); 8137 } else 8138 return; 8139 } else if (*name == 'U') { 8140 if (strEQ(name, "UNITCHECK")) { 8141 /* It's never too late to run a unitcheck block */ 8142 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv)); 8143 } 8144 else 8145 return; 8146 } else if (*name == 'C') { 8147 if (strEQ(name, "CHECK")) { 8148 if (PL_main_start) 8149 /* diag_listed_as: Too late to run %s block */ 8150 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), 8151 "Too late to run CHECK block"); 8152 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv)); 8153 } 8154 else 8155 return; 8156 } else if (*name == 'I') { 8157 if (strEQ(name, "INIT")) { 8158 if (PL_main_start) 8159 /* diag_listed_as: Too late to run %s block */ 8160 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), 8161 "Too late to run INIT block"); 8162 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv)); 8163 } 8164 else 8165 return; 8166 } else 8167 return; 8168 DEBUG_x( dump_sub(gv) ); 8169 GvCV_set(gv,0); /* cv has been hijacked */ 8170 } 8171 } 8172 8173 /* 8174 =for apidoc newCONSTSUB 8175 8176 See L</newCONSTSUB_flags>. 8177 8178 =cut 8179 */ 8180 8181 CV * 8182 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv) 8183 { 8184 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv); 8185 } 8186 8187 /* 8188 =for apidoc newCONSTSUB_flags 8189 8190 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is 8191 eligible for inlining at compile-time. 8192 8193 Currently, the only useful value for C<flags> is SVf_UTF8. 8194 8195 The newly created subroutine takes ownership of a reference to the passed in 8196 SV. 8197 8198 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>, 8199 which won't be called if used as a destructor, but will suppress the overhead 8200 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at 8201 compile time.) 8202 8203 =cut 8204 */ 8205 8206 CV * 8207 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len, 8208 U32 flags, SV *sv) 8209 { 8210 dVAR; 8211 CV* cv; 8212 const char *const file = CopFILE(PL_curcop); 8213 8214 ENTER; 8215 8216 if (IN_PERL_RUNTIME) { 8217 /* at runtime, it's not safe to manipulate PL_curcop: it may be 8218 * an op shared between threads. Use a non-shared COP for our 8219 * dirty work */ 8220 SAVEVPTR(PL_curcop); 8221 SAVECOMPILEWARNINGS(); 8222 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings); 8223 PL_curcop = &PL_compiling; 8224 } 8225 SAVECOPLINE(PL_curcop); 8226 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE); 8227 8228 SAVEHINTS(); 8229 PL_hints &= ~HINT_BLOCK_SCOPE; 8230 8231 if (stash) { 8232 SAVEGENERICSV(PL_curstash); 8233 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash); 8234 } 8235 8236 /* Protect sv against leakage caused by fatal warnings. */ 8237 if (sv) SAVEFREESV(sv); 8238 8239 /* file becomes the CvFILE. For an XS, it's usually static storage, 8240 and so doesn't get free()d. (It's expected to be from the C pre- 8241 processor __FILE__ directive). But we need a dynamically allocated one, 8242 and we need it to get freed. */ 8243 cv = newXS_len_flags(name, len, 8244 sv && SvTYPE(sv) == SVt_PVAV 8245 ? const_av_xsub 8246 : const_sv_xsub, 8247 file ? file : "", "", 8248 &sv, XS_DYNAMIC_FILENAME | flags); 8249 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv); 8250 CvCONST_on(cv); 8251 8252 LEAVE; 8253 8254 return cv; 8255 } 8256 8257 CV * 8258 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr, 8259 const char *const filename, const char *const proto, 8260 U32 flags) 8261 { 8262 PERL_ARGS_ASSERT_NEWXS_FLAGS; 8263 return newXS_len_flags( 8264 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags 8265 ); 8266 } 8267 8268 CV * 8269 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len, 8270 XSUBADDR_t subaddr, const char *const filename, 8271 const char *const proto, SV **const_svp, 8272 U32 flags) 8273 { 8274 CV *cv; 8275 bool interleave = FALSE; 8276 8277 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS; 8278 8279 { 8280 GV * const gv = gv_fetchpvn( 8281 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__", 8282 name ? len : PL_curstash ? sizeof("__ANON__") - 1: 8283 sizeof("__ANON__::__ANON__") - 1, 8284 GV_ADDMULTI | flags, SVt_PVCV); 8285 8286 if (!subaddr) 8287 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename); 8288 8289 if ((cv = (name ? GvCV(gv) : NULL))) { 8290 if (GvCVGEN(gv)) { 8291 /* just a cached method */ 8292 SvREFCNT_dec(cv); 8293 cv = NULL; 8294 } 8295 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) { 8296 /* already defined (or promised) */ 8297 /* Redundant check that allows us to avoid creating an SV 8298 most of the time: */ 8299 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) { 8300 report_redefined_cv(newSVpvn_flags( 8301 name,len,(flags&SVf_UTF8)|SVs_TEMP 8302 ), 8303 cv, const_svp); 8304 } 8305 interleave = TRUE; 8306 ENTER; 8307 SAVEFREESV(cv); 8308 cv = NULL; 8309 } 8310 } 8311 8312 if (cv) /* must reuse cv if autoloaded */ 8313 cv_undef(cv); 8314 else { 8315 cv = MUTABLE_CV(newSV_type(SVt_PVCV)); 8316 if (name) { 8317 GvCV_set(gv,cv); 8318 GvCVGEN(gv) = 0; 8319 if (HvENAME_HEK(GvSTASH(gv))) 8320 gv_method_changed(gv); /* newXS */ 8321 } 8322 } 8323 if (!name) 8324 CvANON_on(cv); 8325 CvGV_set(cv, gv); 8326 (void)gv_fetchfile(filename); 8327 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be 8328 an external constant string */ 8329 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */ 8330 CvISXSUB_on(cv); 8331 CvXSUB(cv) = subaddr; 8332 8333 if (name) 8334 process_special_blocks(0, name, gv, cv); 8335 } 8336 8337 if (flags & XS_DYNAMIC_FILENAME) { 8338 CvFILE(cv) = savepv(filename); 8339 CvDYNFILE_on(cv); 8340 } 8341 sv_setpv(MUTABLE_SV(cv), proto); 8342 if (interleave) LEAVE; 8343 return cv; 8344 } 8345 8346 CV * 8347 Perl_newSTUB(pTHX_ GV *gv, bool fake) 8348 { 8349 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV)); 8350 GV *cvgv; 8351 PERL_ARGS_ASSERT_NEWSTUB; 8352 assert(!GvCVu(gv)); 8353 GvCV_set(gv, cv); 8354 GvCVGEN(gv) = 0; 8355 if (!fake && HvENAME_HEK(GvSTASH(gv))) 8356 gv_method_changed(gv); 8357 if (SvFAKE(gv)) { 8358 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV); 8359 SvFAKE_off(cvgv); 8360 } 8361 else cvgv = gv; 8362 CvGV_set(cv, cvgv); 8363 CvFILE_set_from_cop(cv, PL_curcop); 8364 CvSTASH_set(cv, PL_curstash); 8365 GvMULTI_on(gv); 8366 return cv; 8367 } 8368 8369 /* 8370 =for apidoc U||newXS 8371 8372 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be 8373 static storage, as it is used directly as CvFILE(), without a copy being made. 8374 8375 =cut 8376 */ 8377 8378 CV * 8379 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename) 8380 { 8381 PERL_ARGS_ASSERT_NEWXS; 8382 return newXS_len_flags( 8383 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0 8384 ); 8385 } 8386 8387 #ifdef PERL_MAD 8388 OP * 8389 #else 8390 void 8391 #endif 8392 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) 8393 { 8394 dVAR; 8395 CV *cv; 8396 #ifdef PERL_MAD 8397 OP* pegop = newOP(OP_NULL, 0); 8398 #endif 8399 8400 GV *gv; 8401 8402 if (PL_parser && PL_parser->error_count) { 8403 op_free(block); 8404 goto finish; 8405 } 8406 8407 gv = o 8408 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM) 8409 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM); 8410 8411 GvMULTI_on(gv); 8412 if ((cv = GvFORM(gv))) { 8413 if (ckWARN(WARN_REDEFINE)) { 8414 const line_t oldline = CopLINE(PL_curcop); 8415 if (PL_parser && PL_parser->copline != NOLINE) 8416 CopLINE_set(PL_curcop, PL_parser->copline); 8417 if (o) { 8418 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), 8419 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv)); 8420 } else { 8421 /* diag_listed_as: Format %s redefined */ 8422 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), 8423 "Format STDOUT redefined"); 8424 } 8425 CopLINE_set(PL_curcop, oldline); 8426 } 8427 SvREFCNT_dec(cv); 8428 } 8429 cv = PL_compcv; 8430 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv); 8431 CvGV_set(cv, gv); 8432 CvFILE_set_from_cop(cv, PL_curcop); 8433 8434 8435 pad_tidy(padtidy_FORMAT); 8436 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block)); 8437 CvROOT(cv)->op_private |= OPpREFCOUNTED; 8438 OpREFCNT_set(CvROOT(cv), 1); 8439 CvSTART(cv) = LINKLIST(CvROOT(cv)); 8440 CvROOT(cv)->op_next = 0; 8441 CALL_PEEP(CvSTART(cv)); 8442 finalize_optree(CvROOT(cv)); 8443 S_prune_chain_head(aTHX_ &CvSTART(cv)); 8444 cv_forget_slab(cv); 8445 8446 finish: 8447 #ifdef PERL_MAD 8448 op_getmad(o,pegop,'n'); 8449 op_getmad_weak(block, pegop, 'b'); 8450 #else 8451 op_free(o); 8452 #endif 8453 if (PL_parser) 8454 PL_parser->copline = NOLINE; 8455 LEAVE_SCOPE(floor); 8456 #ifdef PERL_MAD 8457 return pegop; 8458 #endif 8459 } 8460 8461 OP * 8462 Perl_newANONLIST(pTHX_ OP *o) 8463 { 8464 return convert(OP_ANONLIST, OPf_SPECIAL, o); 8465 } 8466 8467 OP * 8468 Perl_newANONHASH(pTHX_ OP *o) 8469 { 8470 return convert(OP_ANONHASH, OPf_SPECIAL, o); 8471 } 8472 8473 OP * 8474 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block) 8475 { 8476 return newANONATTRSUB(floor, proto, NULL, block); 8477 } 8478 8479 OP * 8480 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block) 8481 { 8482 return newUNOP(OP_REFGEN, 0, 8483 newSVOP(OP_ANONCODE, 0, 8484 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block)))); 8485 } 8486 8487 OP * 8488 Perl_oopsAV(pTHX_ OP *o) 8489 { 8490 dVAR; 8491 8492 PERL_ARGS_ASSERT_OOPSAV; 8493 8494 switch (o->op_type) { 8495 case OP_PADSV: 8496 case OP_PADHV: 8497 o->op_type = OP_PADAV; 8498 o->op_ppaddr = PL_ppaddr[OP_PADAV]; 8499 return ref(o, OP_RV2AV); 8500 8501 case OP_RV2SV: 8502 case OP_RV2HV: 8503 o->op_type = OP_RV2AV; 8504 o->op_ppaddr = PL_ppaddr[OP_RV2AV]; 8505 ref(o, OP_RV2AV); 8506 break; 8507 8508 default: 8509 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV"); 8510 break; 8511 } 8512 return o; 8513 } 8514 8515 OP * 8516 Perl_oopsHV(pTHX_ OP *o) 8517 { 8518 dVAR; 8519 8520 PERL_ARGS_ASSERT_OOPSHV; 8521 8522 switch (o->op_type) { 8523 case OP_PADSV: 8524 case OP_PADAV: 8525 o->op_type = OP_PADHV; 8526 o->op_ppaddr = PL_ppaddr[OP_PADHV]; 8527 return ref(o, OP_RV2HV); 8528 8529 case OP_RV2SV: 8530 case OP_RV2AV: 8531 o->op_type = OP_RV2HV; 8532 o->op_ppaddr = PL_ppaddr[OP_RV2HV]; 8533 ref(o, OP_RV2HV); 8534 break; 8535 8536 default: 8537 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV"); 8538 break; 8539 } 8540 return o; 8541 } 8542 8543 OP * 8544 Perl_newAVREF(pTHX_ OP *o) 8545 { 8546 dVAR; 8547 8548 PERL_ARGS_ASSERT_NEWAVREF; 8549 8550 if (o->op_type == OP_PADANY) { 8551 o->op_type = OP_PADAV; 8552 o->op_ppaddr = PL_ppaddr[OP_PADAV]; 8553 return o; 8554 } 8555 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) { 8556 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), 8557 "Using an array as a reference is deprecated"); 8558 } 8559 return newUNOP(OP_RV2AV, 0, scalar(o)); 8560 } 8561 8562 OP * 8563 Perl_newGVREF(pTHX_ I32 type, OP *o) 8564 { 8565 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT) 8566 return newUNOP(OP_NULL, 0, o); 8567 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type); 8568 } 8569 8570 OP * 8571 Perl_newHVREF(pTHX_ OP *o) 8572 { 8573 dVAR; 8574 8575 PERL_ARGS_ASSERT_NEWHVREF; 8576 8577 if (o->op_type == OP_PADANY) { 8578 o->op_type = OP_PADHV; 8579 o->op_ppaddr = PL_ppaddr[OP_PADHV]; 8580 return o; 8581 } 8582 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) { 8583 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), 8584 "Using a hash as a reference is deprecated"); 8585 } 8586 return newUNOP(OP_RV2HV, 0, scalar(o)); 8587 } 8588 8589 OP * 8590 Perl_newCVREF(pTHX_ I32 flags, OP *o) 8591 { 8592 if (o->op_type == OP_PADANY) { 8593 dVAR; 8594 o->op_type = OP_PADCV; 8595 o->op_ppaddr = PL_ppaddr[OP_PADCV]; 8596 } 8597 return newUNOP(OP_RV2CV, flags, scalar(o)); 8598 } 8599 8600 OP * 8601 Perl_newSVREF(pTHX_ OP *o) 8602 { 8603 dVAR; 8604 8605 PERL_ARGS_ASSERT_NEWSVREF; 8606 8607 if (o->op_type == OP_PADANY) { 8608 o->op_type = OP_PADSV; 8609 o->op_ppaddr = PL_ppaddr[OP_PADSV]; 8610 return o; 8611 } 8612 return newUNOP(OP_RV2SV, 0, scalar(o)); 8613 } 8614 8615 /* Check routines. See the comments at the top of this file for details 8616 * on when these are called */ 8617 8618 OP * 8619 Perl_ck_anoncode(pTHX_ OP *o) 8620 { 8621 PERL_ARGS_ASSERT_CK_ANONCODE; 8622 8623 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type); 8624 if (!PL_madskills) 8625 cSVOPo->op_sv = NULL; 8626 return o; 8627 } 8628 8629 static void 8630 S_io_hints(pTHX_ OP *o) 8631 { 8632 HV * const table = 8633 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;; 8634 if (table) { 8635 SV **svp = hv_fetchs(table, "open_IN", FALSE); 8636 if (svp && *svp) { 8637 STRLEN len = 0; 8638 const char *d = SvPV_const(*svp, len); 8639 const I32 mode = mode_from_discipline(d, len); 8640 if (mode & O_BINARY) 8641 o->op_private |= OPpOPEN_IN_RAW; 8642 else if (mode & O_TEXT) 8643 o->op_private |= OPpOPEN_IN_CRLF; 8644 } 8645 8646 svp = hv_fetchs(table, "open_OUT", FALSE); 8647 if (svp && *svp) { 8648 STRLEN len = 0; 8649 const char *d = SvPV_const(*svp, len); 8650 const I32 mode = mode_from_discipline(d, len); 8651 if (mode & O_BINARY) 8652 o->op_private |= OPpOPEN_OUT_RAW; 8653 else if (mode & O_TEXT) 8654 o->op_private |= OPpOPEN_OUT_CRLF; 8655 } 8656 } 8657 } 8658 8659 OP * 8660 Perl_ck_backtick(pTHX_ OP *o) 8661 { 8662 GV *gv; 8663 OP *newop = NULL; 8664 PERL_ARGS_ASSERT_CK_BACKTICK; 8665 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */ 8666 if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_sibling 8667 && (gv = gv_override("readpipe",8))) { 8668 newop = S_new_entersubop(aTHX_ gv, cUNOPo->op_first->op_sibling); 8669 cUNOPo->op_first->op_sibling = NULL; 8670 } 8671 else if (!(o->op_flags & OPf_KIDS)) 8672 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP()); 8673 if (newop) { 8674 #ifdef PERL_MAD 8675 op_getmad(o,newop,'O'); 8676 #else 8677 op_free(o); 8678 #endif 8679 return newop; 8680 } 8681 S_io_hints(aTHX_ o); 8682 return o; 8683 } 8684 8685 OP * 8686 Perl_ck_bitop(pTHX_ OP *o) 8687 { 8688 dVAR; 8689 8690 PERL_ARGS_ASSERT_CK_BITOP; 8691 8692 o->op_private = (U8)(PL_hints & HINT_INTEGER); 8693 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */ 8694 && (o->op_type == OP_BIT_OR 8695 || o->op_type == OP_BIT_AND 8696 || o->op_type == OP_BIT_XOR)) 8697 { 8698 const OP * const left = cBINOPo->op_first; 8699 const OP * const right = left->op_sibling; 8700 if ((OP_IS_NUMCOMPARE(left->op_type) && 8701 (left->op_flags & OPf_PARENS) == 0) || 8702 (OP_IS_NUMCOMPARE(right->op_type) && 8703 (right->op_flags & OPf_PARENS) == 0)) 8704 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE), 8705 "Possible precedence problem on bitwise %c operator", 8706 o->op_type == OP_BIT_OR ? '|' 8707 : o->op_type == OP_BIT_AND ? '&' : '^' 8708 ); 8709 } 8710 return o; 8711 } 8712 8713 PERL_STATIC_INLINE bool 8714 is_dollar_bracket(pTHX_ const OP * const o) 8715 { 8716 const OP *kid; 8717 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS 8718 && (kid = cUNOPx(o)->op_first) 8719 && kid->op_type == OP_GV 8720 && strEQ(GvNAME(cGVOPx_gv(kid)), "["); 8721 } 8722 8723 OP * 8724 Perl_ck_cmp(pTHX_ OP *o) 8725 { 8726 PERL_ARGS_ASSERT_CK_CMP; 8727 if (ckWARN(WARN_SYNTAX)) { 8728 const OP *kid = cUNOPo->op_first; 8729 if (kid && ( 8730 ( 8731 is_dollar_bracket(aTHX_ kid) 8732 && kid->op_sibling && kid->op_sibling->op_type == OP_CONST 8733 ) 8734 || ( kid->op_type == OP_CONST 8735 && (kid = kid->op_sibling) && is_dollar_bracket(aTHX_ kid)) 8736 )) 8737 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 8738 "$[ used in %s (did you mean $] ?)", OP_DESC(o)); 8739 } 8740 return o; 8741 } 8742 8743 OP * 8744 Perl_ck_concat(pTHX_ OP *o) 8745 { 8746 const OP * const kid = cUNOPo->op_first; 8747 8748 PERL_ARGS_ASSERT_CK_CONCAT; 8749 PERL_UNUSED_CONTEXT; 8750 8751 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) && 8752 !(kUNOP->op_first->op_flags & OPf_MOD)) 8753 o->op_flags |= OPf_STACKED; 8754 return o; 8755 } 8756 8757 OP * 8758 Perl_ck_spair(pTHX_ OP *o) 8759 { 8760 dVAR; 8761 8762 PERL_ARGS_ASSERT_CK_SPAIR; 8763 8764 if (o->op_flags & OPf_KIDS) { 8765 OP* newop; 8766 OP* kid; 8767 const OPCODE type = o->op_type; 8768 o = modkids(ck_fun(o), type); 8769 kid = cUNOPo->op_first; 8770 newop = kUNOP->op_first->op_sibling; 8771 if (newop) { 8772 const OPCODE type = newop->op_type; 8773 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) || 8774 type == OP_PADAV || type == OP_PADHV || 8775 type == OP_RV2AV || type == OP_RV2HV) 8776 return o; 8777 } 8778 #ifdef PERL_MAD 8779 op_getmad(kUNOP->op_first,newop,'K'); 8780 #else 8781 op_free(kUNOP->op_first); 8782 #endif 8783 kUNOP->op_first = newop; 8784 } 8785 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP, 8786 * and OP_CHOMP into OP_SCHOMP */ 8787 o->op_ppaddr = PL_ppaddr[++o->op_type]; 8788 return ck_fun(o); 8789 } 8790 8791 OP * 8792 Perl_ck_delete(pTHX_ OP *o) 8793 { 8794 PERL_ARGS_ASSERT_CK_DELETE; 8795 8796 o = ck_fun(o); 8797 o->op_private = 0; 8798 if (o->op_flags & OPf_KIDS) { 8799 OP * const kid = cUNOPo->op_first; 8800 switch (kid->op_type) { 8801 case OP_ASLICE: 8802 o->op_flags |= OPf_SPECIAL; 8803 /* FALL THROUGH */ 8804 case OP_HSLICE: 8805 o->op_private |= OPpSLICE; 8806 break; 8807 case OP_AELEM: 8808 o->op_flags |= OPf_SPECIAL; 8809 /* FALL THROUGH */ 8810 case OP_HELEM: 8811 break; 8812 case OP_KVASLICE: 8813 Perl_croak(aTHX_ "delete argument is index/value array slice," 8814 " use array slice"); 8815 case OP_KVHSLICE: 8816 Perl_croak(aTHX_ "delete argument is key/value hash slice, use" 8817 " hash slice"); 8818 default: 8819 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY " 8820 "element or slice"); 8821 } 8822 if (kid->op_private & OPpLVAL_INTRO) 8823 o->op_private |= OPpLVAL_INTRO; 8824 op_null(kid); 8825 } 8826 return o; 8827 } 8828 8829 OP * 8830 Perl_ck_eof(pTHX_ OP *o) 8831 { 8832 dVAR; 8833 8834 PERL_ARGS_ASSERT_CK_EOF; 8835 8836 if (o->op_flags & OPf_KIDS) { 8837 OP *kid; 8838 if (cLISTOPo->op_first->op_type == OP_STUB) { 8839 OP * const newop 8840 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv)); 8841 #ifdef PERL_MAD 8842 op_getmad(o,newop,'O'); 8843 #else 8844 op_free(o); 8845 #endif 8846 o = newop; 8847 } 8848 o = ck_fun(o); 8849 kid = cLISTOPo->op_first; 8850 if (kid->op_type == OP_RV2GV) 8851 kid->op_private |= OPpALLOW_FAKE; 8852 } 8853 return o; 8854 } 8855 8856 OP * 8857 Perl_ck_eval(pTHX_ OP *o) 8858 { 8859 dVAR; 8860 8861 PERL_ARGS_ASSERT_CK_EVAL; 8862 8863 PL_hints |= HINT_BLOCK_SCOPE; 8864 if (o->op_flags & OPf_KIDS) { 8865 SVOP * const kid = (SVOP*)cUNOPo->op_first; 8866 assert(kid); 8867 8868 if (o->op_type == OP_ENTERTRY) { 8869 LOGOP *enter; 8870 #ifdef PERL_MAD 8871 OP* const oldo = o; 8872 #endif 8873 8874 cUNOPo->op_first = 0; 8875 #ifndef PERL_MAD 8876 op_free(o); 8877 #endif 8878 8879 NewOp(1101, enter, 1, LOGOP); 8880 enter->op_type = OP_ENTERTRY; 8881 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY]; 8882 enter->op_private = 0; 8883 8884 /* establish postfix order */ 8885 enter->op_next = (OP*)enter; 8886 8887 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid); 8888 o->op_type = OP_LEAVETRY; 8889 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY]; 8890 enter->op_other = o; 8891 op_getmad(oldo,o,'O'); 8892 return o; 8893 } 8894 else { 8895 scalar((OP*)kid); 8896 PL_cv_has_eval = 1; 8897 } 8898 } 8899 else { 8900 const U8 priv = o->op_private; 8901 #ifdef PERL_MAD 8902 OP* const oldo = o; 8903 #else 8904 op_free(o); 8905 #endif 8906 o = newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP()); 8907 op_getmad(oldo,o,'O'); 8908 } 8909 o->op_targ = (PADOFFSET)PL_hints; 8910 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8; 8911 if ((PL_hints & HINT_LOCALIZE_HH) != 0 8912 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) { 8913 /* Store a copy of %^H that pp_entereval can pick up. */ 8914 OP *hhop = newSVOP(OP_HINTSEVAL, 0, 8915 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv)))); 8916 cUNOPo->op_first->op_sibling = hhop; 8917 o->op_private |= OPpEVAL_HAS_HH; 8918 } 8919 if (!(o->op_private & OPpEVAL_BYTES) 8920 && FEATURE_UNIEVAL_IS_ENABLED) 8921 o->op_private |= OPpEVAL_UNICODE; 8922 return o; 8923 } 8924 8925 OP * 8926 Perl_ck_exec(pTHX_ OP *o) 8927 { 8928 PERL_ARGS_ASSERT_CK_EXEC; 8929 8930 if (o->op_flags & OPf_STACKED) { 8931 OP *kid; 8932 o = ck_fun(o); 8933 kid = cUNOPo->op_first->op_sibling; 8934 if (kid->op_type == OP_RV2GV) 8935 op_null(kid); 8936 } 8937 else 8938 o = listkids(o); 8939 return o; 8940 } 8941 8942 OP * 8943 Perl_ck_exists(pTHX_ OP *o) 8944 { 8945 dVAR; 8946 8947 PERL_ARGS_ASSERT_CK_EXISTS; 8948 8949 o = ck_fun(o); 8950 if (o->op_flags & OPf_KIDS) { 8951 OP * const kid = cUNOPo->op_first; 8952 if (kid->op_type == OP_ENTERSUB) { 8953 (void) ref(kid, o->op_type); 8954 if (kid->op_type != OP_RV2CV 8955 && !(PL_parser && PL_parser->error_count)) 8956 Perl_croak(aTHX_ 8957 "exists argument is not a subroutine name"); 8958 o->op_private |= OPpEXISTS_SUB; 8959 } 8960 else if (kid->op_type == OP_AELEM) 8961 o->op_flags |= OPf_SPECIAL; 8962 else if (kid->op_type != OP_HELEM) 8963 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY " 8964 "element or a subroutine"); 8965 op_null(kid); 8966 } 8967 return o; 8968 } 8969 8970 OP * 8971 Perl_ck_rvconst(pTHX_ OP *o) 8972 { 8973 dVAR; 8974 SVOP * const kid = (SVOP*)cUNOPo->op_first; 8975 8976 PERL_ARGS_ASSERT_CK_RVCONST; 8977 8978 o->op_private |= (PL_hints & HINT_STRICT_REFS); 8979 if (o->op_type == OP_RV2CV) 8980 o->op_private &= ~1; 8981 8982 if (kid->op_type == OP_CONST) { 8983 int iscv; 8984 GV *gv; 8985 SV * const kidsv = kid->op_sv; 8986 8987 /* Is it a constant from cv_const_sv()? */ 8988 if (SvROK(kidsv) && SvREADONLY(kidsv)) { 8989 SV * const rsv = SvRV(kidsv); 8990 const svtype type = SvTYPE(rsv); 8991 const char *badtype = NULL; 8992 8993 switch (o->op_type) { 8994 case OP_RV2SV: 8995 if (type > SVt_PVMG) 8996 badtype = "a SCALAR"; 8997 break; 8998 case OP_RV2AV: 8999 if (type != SVt_PVAV) 9000 badtype = "an ARRAY"; 9001 break; 9002 case OP_RV2HV: 9003 if (type != SVt_PVHV) 9004 badtype = "a HASH"; 9005 break; 9006 case OP_RV2CV: 9007 if (type != SVt_PVCV) 9008 badtype = "a CODE"; 9009 break; 9010 } 9011 if (badtype) 9012 Perl_croak(aTHX_ "Constant is not %s reference", badtype); 9013 return o; 9014 } 9015 if (SvTYPE(kidsv) == SVt_PVAV) return o; 9016 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) { 9017 const char *badthing; 9018 switch (o->op_type) { 9019 case OP_RV2SV: 9020 badthing = "a SCALAR"; 9021 break; 9022 case OP_RV2AV: 9023 badthing = "an ARRAY"; 9024 break; 9025 case OP_RV2HV: 9026 badthing = "a HASH"; 9027 break; 9028 default: 9029 badthing = NULL; 9030 break; 9031 } 9032 if (badthing) 9033 Perl_croak(aTHX_ 9034 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use", 9035 SVfARG(kidsv), badthing); 9036 } 9037 /* 9038 * This is a little tricky. We only want to add the symbol if we 9039 * didn't add it in the lexer. Otherwise we get duplicate strict 9040 * warnings. But if we didn't add it in the lexer, we must at 9041 * least pretend like we wanted to add it even if it existed before, 9042 * or we get possible typo warnings. OPpCONST_ENTERED says 9043 * whether the lexer already added THIS instance of this symbol. 9044 */ 9045 iscv = (o->op_type == OP_RV2CV) * 2; 9046 do { 9047 gv = gv_fetchsv(kidsv, 9048 iscv | !(kid->op_private & OPpCONST_ENTERED), 9049 iscv 9050 ? SVt_PVCV 9051 : o->op_type == OP_RV2SV 9052 ? SVt_PV 9053 : o->op_type == OP_RV2AV 9054 ? SVt_PVAV 9055 : o->op_type == OP_RV2HV 9056 ? SVt_PVHV 9057 : SVt_PVGV); 9058 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++); 9059 if (gv) { 9060 kid->op_type = OP_GV; 9061 SvREFCNT_dec(kid->op_sv); 9062 #ifdef USE_ITHREADS 9063 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */ 9064 assert (sizeof(PADOP) <= sizeof(SVOP)); 9065 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP); 9066 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix)); 9067 GvIN_PAD_on(gv); 9068 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv))); 9069 #else 9070 kid->op_sv = SvREFCNT_inc_simple_NN(gv); 9071 #endif 9072 kid->op_private = 0; 9073 kid->op_ppaddr = PL_ppaddr[OP_GV]; 9074 /* FAKE globs in the symbol table cause weird bugs (#77810) */ 9075 SvFAKE_off(gv); 9076 } 9077 } 9078 return o; 9079 } 9080 9081 OP * 9082 Perl_ck_ftst(pTHX_ OP *o) 9083 { 9084 dVAR; 9085 const I32 type = o->op_type; 9086 9087 PERL_ARGS_ASSERT_CK_FTST; 9088 9089 if (o->op_flags & OPf_REF) { 9090 NOOP; 9091 } 9092 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) { 9093 SVOP * const kid = (SVOP*)cUNOPo->op_first; 9094 const OPCODE kidtype = kid->op_type; 9095 9096 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE) 9097 && !kid->op_folded) { 9098 OP * const newop = newGVOP(type, OPf_REF, 9099 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO)); 9100 #ifdef PERL_MAD 9101 op_getmad(o,newop,'O'); 9102 #else 9103 op_free(o); 9104 #endif 9105 return newop; 9106 } 9107 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type)) 9108 o->op_private |= OPpFT_ACCESS; 9109 if (PL_check[kidtype] == Perl_ck_ftst 9110 && kidtype != OP_STAT && kidtype != OP_LSTAT) { 9111 o->op_private |= OPpFT_STACKED; 9112 kid->op_private |= OPpFT_STACKING; 9113 if (kidtype == OP_FTTTY && ( 9114 !(kid->op_private & OPpFT_STACKED) 9115 || kid->op_private & OPpFT_AFTER_t 9116 )) 9117 o->op_private |= OPpFT_AFTER_t; 9118 } 9119 } 9120 else { 9121 #ifdef PERL_MAD 9122 OP* const oldo = o; 9123 #else 9124 op_free(o); 9125 #endif 9126 if (type == OP_FTTTY) 9127 o = newGVOP(type, OPf_REF, PL_stdingv); 9128 else 9129 o = newUNOP(type, 0, newDEFSVOP()); 9130 op_getmad(oldo,o,'O'); 9131 } 9132 return o; 9133 } 9134 9135 OP * 9136 Perl_ck_fun(pTHX_ OP *o) 9137 { 9138 dVAR; 9139 const int type = o->op_type; 9140 I32 oa = PL_opargs[type] >> OASHIFT; 9141 9142 PERL_ARGS_ASSERT_CK_FUN; 9143 9144 if (o->op_flags & OPf_STACKED) { 9145 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL)) 9146 oa &= ~OA_OPTIONAL; 9147 else 9148 return no_fh_allowed(o); 9149 } 9150 9151 if (o->op_flags & OPf_KIDS) { 9152 OP **tokid = &cLISTOPo->op_first; 9153 OP *kid = cLISTOPo->op_first; 9154 OP *sibl; 9155 I32 numargs = 0; 9156 bool seen_optional = FALSE; 9157 9158 if (kid->op_type == OP_PUSHMARK || 9159 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK)) 9160 { 9161 tokid = &kid->op_sibling; 9162 kid = kid->op_sibling; 9163 } 9164 if (kid && kid->op_type == OP_COREARGS) { 9165 bool optional = FALSE; 9166 while (oa) { 9167 numargs++; 9168 if (oa & OA_OPTIONAL) optional = TRUE; 9169 oa = oa >> 4; 9170 } 9171 if (optional) o->op_private |= numargs; 9172 return o; 9173 } 9174 9175 while (oa) { 9176 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) { 9177 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) 9178 *tokid = kid = newDEFSVOP(); 9179 seen_optional = TRUE; 9180 } 9181 if (!kid) break; 9182 9183 numargs++; 9184 sibl = kid->op_sibling; 9185 #ifdef PERL_MAD 9186 if (!sibl && kid->op_type == OP_STUB) { 9187 numargs--; 9188 break; 9189 } 9190 #endif 9191 switch (oa & 7) { 9192 case OA_SCALAR: 9193 /* list seen where single (scalar) arg expected? */ 9194 if (numargs == 1 && !(oa >> 4) 9195 && kid->op_type == OP_LIST && type != OP_SCALAR) 9196 { 9197 return too_many_arguments_pv(o,PL_op_desc[type], 0); 9198 } 9199 if (type != OP_DELETE) scalar(kid); 9200 break; 9201 case OA_LIST: 9202 if (oa < 16) { 9203 kid = 0; 9204 continue; 9205 } 9206 else 9207 list(kid); 9208 break; 9209 case OA_AVREF: 9210 if ((type == OP_PUSH || type == OP_UNSHIFT) 9211 && !kid->op_sibling) 9212 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), 9213 "Useless use of %s with no values", 9214 PL_op_desc[type]); 9215 9216 if (kid->op_type == OP_CONST && 9217 (kid->op_private & OPpCONST_BARE)) 9218 { 9219 OP * const newop = newAVREF(newGVOP(OP_GV, 0, 9220 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) )); 9221 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), 9222 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()", 9223 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]); 9224 #ifdef PERL_MAD 9225 op_getmad(kid,newop,'K'); 9226 #else 9227 op_free(kid); 9228 #endif 9229 kid = newop; 9230 kid->op_sibling = sibl; 9231 *tokid = kid; 9232 } 9233 else if (kid->op_type == OP_CONST 9234 && ( !SvROK(cSVOPx_sv(kid)) 9235 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV ) 9236 ) 9237 bad_type_pv(numargs, "array", PL_op_desc[type], 0, kid); 9238 /* Defer checks to run-time if we have a scalar arg */ 9239 if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV) 9240 op_lvalue(kid, type); 9241 else { 9242 scalar(kid); 9243 /* diag_listed_as: push on reference is experimental */ 9244 Perl_ck_warner_d(aTHX_ 9245 packWARN(WARN_EXPERIMENTAL__AUTODEREF), 9246 "%s on reference is experimental", 9247 PL_op_desc[type]); 9248 } 9249 break; 9250 case OA_HVREF: 9251 if (kid->op_type == OP_CONST && 9252 (kid->op_private & OPpCONST_BARE)) 9253 { 9254 OP * const newop = newHVREF(newGVOP(OP_GV, 0, 9255 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) )); 9256 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), 9257 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()", 9258 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]); 9259 #ifdef PERL_MAD 9260 op_getmad(kid,newop,'K'); 9261 #else 9262 op_free(kid); 9263 #endif 9264 kid = newop; 9265 kid->op_sibling = sibl; 9266 *tokid = kid; 9267 } 9268 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV) 9269 bad_type_pv(numargs, "hash", PL_op_desc[type], 0, kid); 9270 op_lvalue(kid, type); 9271 break; 9272 case OA_CVREF: 9273 { 9274 OP * const newop = newUNOP(OP_NULL, 0, kid); 9275 kid->op_sibling = 0; 9276 newop->op_next = newop; 9277 kid = newop; 9278 kid->op_sibling = sibl; 9279 *tokid = kid; 9280 } 9281 break; 9282 case OA_FILEREF: 9283 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) { 9284 if (kid->op_type == OP_CONST && 9285 (kid->op_private & OPpCONST_BARE)) 9286 { 9287 OP * const newop = newGVOP(OP_GV, 0, 9288 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO)); 9289 if (!(o->op_private & 1) && /* if not unop */ 9290 kid == cLISTOPo->op_last) 9291 cLISTOPo->op_last = newop; 9292 #ifdef PERL_MAD 9293 op_getmad(kid,newop,'K'); 9294 #else 9295 op_free(kid); 9296 #endif 9297 kid = newop; 9298 } 9299 else if (kid->op_type == OP_READLINE) { 9300 /* neophyte patrol: open(<FH>), close(<FH>) etc. */ 9301 bad_type_pv(numargs, "HANDLE", OP_DESC(o), 0, kid); 9302 } 9303 else { 9304 I32 flags = OPf_SPECIAL; 9305 I32 priv = 0; 9306 PADOFFSET targ = 0; 9307 9308 /* is this op a FH constructor? */ 9309 if (is_handle_constructor(o,numargs)) { 9310 const char *name = NULL; 9311 STRLEN len = 0; 9312 U32 name_utf8 = 0; 9313 bool want_dollar = TRUE; 9314 9315 flags = 0; 9316 /* Set a flag to tell rv2gv to vivify 9317 * need to "prove" flag does not mean something 9318 * else already - NI-S 1999/05/07 9319 */ 9320 priv = OPpDEREF; 9321 if (kid->op_type == OP_PADSV) { 9322 SV *const namesv 9323 = PAD_COMPNAME_SV(kid->op_targ); 9324 name = SvPV_const(namesv, len); 9325 name_utf8 = SvUTF8(namesv); 9326 } 9327 else if (kid->op_type == OP_RV2SV 9328 && kUNOP->op_first->op_type == OP_GV) 9329 { 9330 GV * const gv = cGVOPx_gv(kUNOP->op_first); 9331 name = GvNAME(gv); 9332 len = GvNAMELEN(gv); 9333 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0; 9334 } 9335 else if (kid->op_type == OP_AELEM 9336 || kid->op_type == OP_HELEM) 9337 { 9338 OP *firstop; 9339 OP *op = ((BINOP*)kid)->op_first; 9340 name = NULL; 9341 if (op) { 9342 SV *tmpstr = NULL; 9343 const char * const a = 9344 kid->op_type == OP_AELEM ? 9345 "[]" : "{}"; 9346 if (((op->op_type == OP_RV2AV) || 9347 (op->op_type == OP_RV2HV)) && 9348 (firstop = ((UNOP*)op)->op_first) && 9349 (firstop->op_type == OP_GV)) { 9350 /* packagevar $a[] or $h{} */ 9351 GV * const gv = cGVOPx_gv(firstop); 9352 if (gv) 9353 tmpstr = 9354 Perl_newSVpvf(aTHX_ 9355 "%s%c...%c", 9356 GvNAME(gv), 9357 a[0], a[1]); 9358 } 9359 else if (op->op_type == OP_PADAV 9360 || op->op_type == OP_PADHV) { 9361 /* lexicalvar $a[] or $h{} */ 9362 const char * const padname = 9363 PAD_COMPNAME_PV(op->op_targ); 9364 if (padname) 9365 tmpstr = 9366 Perl_newSVpvf(aTHX_ 9367 "%s%c...%c", 9368 padname + 1, 9369 a[0], a[1]); 9370 } 9371 if (tmpstr) { 9372 name = SvPV_const(tmpstr, len); 9373 name_utf8 = SvUTF8(tmpstr); 9374 sv_2mortal(tmpstr); 9375 } 9376 } 9377 if (!name) { 9378 name = "__ANONIO__"; 9379 len = 10; 9380 want_dollar = FALSE; 9381 } 9382 op_lvalue(kid, type); 9383 } 9384 if (name) { 9385 SV *namesv; 9386 targ = pad_alloc(OP_RV2GV, SVf_READONLY); 9387 namesv = PAD_SVl(targ); 9388 if (want_dollar && *name != '$') 9389 sv_setpvs(namesv, "$"); 9390 else 9391 sv_setpvs(namesv, ""); 9392 sv_catpvn(namesv, name, len); 9393 if ( name_utf8 ) SvUTF8_on(namesv); 9394 } 9395 } 9396 kid->op_sibling = 0; 9397 kid = newUNOP(OP_RV2GV, flags, scalar(kid)); 9398 kid->op_targ = targ; 9399 kid->op_private |= priv; 9400 } 9401 kid->op_sibling = sibl; 9402 *tokid = kid; 9403 } 9404 scalar(kid); 9405 break; 9406 case OA_SCALARREF: 9407 if ((type == OP_UNDEF || type == OP_POS) 9408 && numargs == 1 && !(oa >> 4) 9409 && kid->op_type == OP_LIST) 9410 return too_many_arguments_pv(o,PL_op_desc[type], 0); 9411 op_lvalue(scalar(kid), type); 9412 break; 9413 } 9414 oa >>= 4; 9415 tokid = &kid->op_sibling; 9416 kid = kid->op_sibling; 9417 } 9418 #ifdef PERL_MAD 9419 if (kid && kid->op_type != OP_STUB) 9420 return too_many_arguments_pv(o,OP_DESC(o), 0); 9421 o->op_private |= numargs; 9422 #else 9423 /* FIXME - should the numargs move as for the PERL_MAD case? */ 9424 o->op_private |= numargs; 9425 if (kid) 9426 return too_many_arguments_pv(o,OP_DESC(o), 0); 9427 #endif 9428 listkids(o); 9429 } 9430 else if (PL_opargs[type] & OA_DEFGV) { 9431 #ifdef PERL_MAD 9432 OP *newop = newUNOP(type, 0, newDEFSVOP()); 9433 op_getmad(o,newop,'O'); 9434 return newop; 9435 #else 9436 /* Ordering of these two is important to keep f_map.t passing. */ 9437 op_free(o); 9438 return newUNOP(type, 0, newDEFSVOP()); 9439 #endif 9440 } 9441 9442 if (oa) { 9443 while (oa & OA_OPTIONAL) 9444 oa >>= 4; 9445 if (oa && oa != OA_LIST) 9446 return too_few_arguments_pv(o,OP_DESC(o), 0); 9447 } 9448 return o; 9449 } 9450 9451 OP * 9452 Perl_ck_glob(pTHX_ OP *o) 9453 { 9454 dVAR; 9455 GV *gv; 9456 9457 PERL_ARGS_ASSERT_CK_GLOB; 9458 9459 o = ck_fun(o); 9460 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling) 9461 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */ 9462 9463 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4))) 9464 { 9465 /* convert 9466 * glob 9467 * \ null - const(wildcard) 9468 * into 9469 * null 9470 * \ enter 9471 * \ list 9472 * \ mark - glob - rv2cv 9473 * | \ gv(CORE::GLOBAL::glob) 9474 * | 9475 * \ null - const(wildcard) 9476 */ 9477 o->op_flags |= OPf_SPECIAL; 9478 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP); 9479 o = S_new_entersubop(aTHX_ gv, o); 9480 o = newUNOP(OP_NULL, 0, o); 9481 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */ 9482 return o; 9483 } 9484 else o->op_flags &= ~OPf_SPECIAL; 9485 #if !defined(PERL_EXTERNAL_GLOB) 9486 if (!PL_globhook) { 9487 ENTER; 9488 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, 9489 newSVpvs("File::Glob"), NULL, NULL, NULL); 9490 LEAVE; 9491 } 9492 #endif /* !PERL_EXTERNAL_GLOB */ 9493 gv = (GV *)newSV(0); 9494 gv_init(gv, 0, "", 0, 0); 9495 gv_IOadd(gv); 9496 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv)); 9497 SvREFCNT_dec_NN(gv); /* newGVOP increased it */ 9498 scalarkids(o); 9499 return o; 9500 } 9501 9502 OP * 9503 Perl_ck_grep(pTHX_ OP *o) 9504 { 9505 dVAR; 9506 LOGOP *gwop; 9507 OP *kid; 9508 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE; 9509 PADOFFSET offset; 9510 9511 PERL_ARGS_ASSERT_CK_GREP; 9512 9513 o->op_ppaddr = PL_ppaddr[OP_GREPSTART]; 9514 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */ 9515 9516 if (o->op_flags & OPf_STACKED) { 9517 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first; 9518 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE) 9519 return no_fh_allowed(o); 9520 o->op_flags &= ~OPf_STACKED; 9521 } 9522 kid = cLISTOPo->op_first->op_sibling; 9523 if (type == OP_MAPWHILE) 9524 list(kid); 9525 else 9526 scalar(kid); 9527 o = ck_fun(o); 9528 if (PL_parser && PL_parser->error_count) 9529 return o; 9530 kid = cLISTOPo->op_first->op_sibling; 9531 if (kid->op_type != OP_NULL) 9532 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type); 9533 kid = kUNOP->op_first; 9534 9535 NewOp(1101, gwop, 1, LOGOP); 9536 gwop->op_type = type; 9537 gwop->op_ppaddr = PL_ppaddr[type]; 9538 gwop->op_first = o; 9539 gwop->op_flags |= OPf_KIDS; 9540 gwop->op_other = LINKLIST(kid); 9541 kid->op_next = (OP*)gwop; 9542 offset = pad_findmy_pvs("$_", 0); 9543 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) { 9544 o->op_private = gwop->op_private = 0; 9545 gwop->op_targ = pad_alloc(type, SVs_PADTMP); 9546 } 9547 else { 9548 o->op_private = gwop->op_private = OPpGREP_LEX; 9549 gwop->op_targ = o->op_targ = offset; 9550 } 9551 9552 kid = cLISTOPo->op_first->op_sibling; 9553 for (kid = kid->op_sibling; kid; kid = kid->op_sibling) 9554 op_lvalue(kid, OP_GREPSTART); 9555 9556 return (OP*)gwop; 9557 } 9558 9559 OP * 9560 Perl_ck_index(pTHX_ OP *o) 9561 { 9562 PERL_ARGS_ASSERT_CK_INDEX; 9563 9564 if (o->op_flags & OPf_KIDS) { 9565 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ 9566 if (kid) 9567 kid = kid->op_sibling; /* get past "big" */ 9568 if (kid && kid->op_type == OP_CONST) { 9569 const bool save_taint = TAINT_get; 9570 SV *sv = kSVOP->op_sv; 9571 if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) { 9572 sv = newSV(0); 9573 sv_copypv(sv, kSVOP->op_sv); 9574 SvREFCNT_dec_NN(kSVOP->op_sv); 9575 kSVOP->op_sv = sv; 9576 } 9577 if (SvOK(sv)) fbm_compile(sv, 0); 9578 TAINT_set(save_taint); 9579 #ifdef NO_TAINT_SUPPORT 9580 PERL_UNUSED_VAR(save_taint); 9581 #endif 9582 } 9583 } 9584 return ck_fun(o); 9585 } 9586 9587 OP * 9588 Perl_ck_lfun(pTHX_ OP *o) 9589 { 9590 const OPCODE type = o->op_type; 9591 9592 PERL_ARGS_ASSERT_CK_LFUN; 9593 9594 return modkids(ck_fun(o), type); 9595 } 9596 9597 OP * 9598 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ 9599 { 9600 PERL_ARGS_ASSERT_CK_DEFINED; 9601 9602 if ((o->op_flags & OPf_KIDS)) { 9603 switch (cUNOPo->op_first->op_type) { 9604 case OP_RV2AV: 9605 case OP_PADAV: 9606 case OP_AASSIGN: /* Is this a good idea? */ 9607 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), 9608 "defined(@array) is deprecated"); 9609 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), 9610 "\t(Maybe you should just omit the defined()?)\n"); 9611 break; 9612 case OP_RV2HV: 9613 case OP_PADHV: 9614 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), 9615 "defined(%%hash) is deprecated"); 9616 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), 9617 "\t(Maybe you should just omit the defined()?)\n"); 9618 break; 9619 default: 9620 /* no warning */ 9621 break; 9622 } 9623 } 9624 return ck_rfun(o); 9625 } 9626 9627 OP * 9628 Perl_ck_readline(pTHX_ OP *o) 9629 { 9630 PERL_ARGS_ASSERT_CK_READLINE; 9631 9632 if (o->op_flags & OPf_KIDS) { 9633 OP *kid = cLISTOPo->op_first; 9634 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE; 9635 } 9636 else { 9637 OP * const newop 9638 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv)); 9639 #ifdef PERL_MAD 9640 op_getmad(o,newop,'O'); 9641 #else 9642 op_free(o); 9643 #endif 9644 return newop; 9645 } 9646 return o; 9647 } 9648 9649 OP * 9650 Perl_ck_rfun(pTHX_ OP *o) 9651 { 9652 const OPCODE type = o->op_type; 9653 9654 PERL_ARGS_ASSERT_CK_RFUN; 9655 9656 return refkids(ck_fun(o), type); 9657 } 9658 9659 OP * 9660 Perl_ck_listiob(pTHX_ OP *o) 9661 { 9662 OP *kid; 9663 9664 PERL_ARGS_ASSERT_CK_LISTIOB; 9665 9666 kid = cLISTOPo->op_first; 9667 if (!kid) { 9668 o = force_list(o); 9669 kid = cLISTOPo->op_first; 9670 } 9671 if (kid->op_type == OP_PUSHMARK) 9672 kid = kid->op_sibling; 9673 if (kid && o->op_flags & OPf_STACKED) 9674 kid = kid->op_sibling; 9675 else if (kid && !kid->op_sibling) { /* print HANDLE; */ 9676 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE 9677 && !kid->op_folded) { 9678 o->op_flags |= OPf_STACKED; /* make it a filehandle */ 9679 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid)); 9680 cLISTOPo->op_first->op_sibling = kid; 9681 cLISTOPo->op_last = kid; 9682 kid = kid->op_sibling; 9683 } 9684 } 9685 9686 if (!kid) 9687 op_append_elem(o->op_type, o, newDEFSVOP()); 9688 9689 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF); 9690 return listkids(o); 9691 } 9692 9693 OP * 9694 Perl_ck_smartmatch(pTHX_ OP *o) 9695 { 9696 dVAR; 9697 PERL_ARGS_ASSERT_CK_SMARTMATCH; 9698 if (0 == (o->op_flags & OPf_SPECIAL)) { 9699 OP *first = cBINOPo->op_first; 9700 OP *second = first->op_sibling; 9701 9702 /* Implicitly take a reference to an array or hash */ 9703 first->op_sibling = NULL; 9704 first = cBINOPo->op_first = ref_array_or_hash(first); 9705 second = first->op_sibling = ref_array_or_hash(second); 9706 9707 /* Implicitly take a reference to a regular expression */ 9708 if (first->op_type == OP_MATCH) { 9709 first->op_type = OP_QR; 9710 first->op_ppaddr = PL_ppaddr[OP_QR]; 9711 } 9712 if (second->op_type == OP_MATCH) { 9713 second->op_type = OP_QR; 9714 second->op_ppaddr = PL_ppaddr[OP_QR]; 9715 } 9716 } 9717 9718 return o; 9719 } 9720 9721 9722 OP * 9723 Perl_ck_sassign(pTHX_ OP *o) 9724 { 9725 dVAR; 9726 OP * const kid = cLISTOPo->op_first; 9727 9728 PERL_ARGS_ASSERT_CK_SASSIGN; 9729 9730 /* has a disposable target? */ 9731 if ((PL_opargs[kid->op_type] & OA_TARGLEX) 9732 && !(kid->op_flags & OPf_STACKED) 9733 /* Cannot steal the second time! */ 9734 && !(kid->op_private & OPpTARGET_MY) 9735 /* Keep the full thing for madskills */ 9736 && !PL_madskills 9737 ) 9738 { 9739 OP * const kkid = kid->op_sibling; 9740 9741 /* Can just relocate the target. */ 9742 if (kkid && kkid->op_type == OP_PADSV 9743 && !(kkid->op_private & OPpLVAL_INTRO)) 9744 { 9745 kid->op_targ = kkid->op_targ; 9746 kkid->op_targ = 0; 9747 /* Now we do not need PADSV and SASSIGN. */ 9748 kid->op_sibling = o->op_sibling; /* NULL */ 9749 cLISTOPo->op_first = NULL; 9750 op_free(o); 9751 op_free(kkid); 9752 kid->op_private |= OPpTARGET_MY; /* Used for context settings */ 9753 return kid; 9754 } 9755 } 9756 if (kid->op_sibling) { 9757 OP *kkid = kid->op_sibling; 9758 /* For state variable assignment, kkid is a list op whose op_last 9759 is a padsv. */ 9760 if ((kkid->op_type == OP_PADSV || 9761 (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) && 9762 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV 9763 ) 9764 ) 9765 && (kkid->op_private & OPpLVAL_INTRO) 9766 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) { 9767 const PADOFFSET target = kkid->op_targ; 9768 OP *const other = newOP(OP_PADSV, 9769 kkid->op_flags 9770 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8)); 9771 OP *const first = newOP(OP_NULL, 0); 9772 OP *const nullop = newCONDOP(0, first, o, other); 9773 OP *const condop = first->op_next; 9774 /* hijacking PADSTALE for uninitialized state variables */ 9775 SvPADSTALE_on(PAD_SVl(target)); 9776 9777 condop->op_type = OP_ONCE; 9778 condop->op_ppaddr = PL_ppaddr[OP_ONCE]; 9779 condop->op_targ = target; 9780 other->op_targ = target; 9781 9782 /* Because we change the type of the op here, we will skip the 9783 assignment binop->op_last = binop->op_first->op_sibling; at the 9784 end of Perl_newBINOP(). So need to do it here. */ 9785 cBINOPo->op_last = cBINOPo->op_first->op_sibling; 9786 9787 return nullop; 9788 } 9789 } 9790 return o; 9791 } 9792 9793 OP * 9794 Perl_ck_match(pTHX_ OP *o) 9795 { 9796 dVAR; 9797 9798 PERL_ARGS_ASSERT_CK_MATCH; 9799 9800 if (o->op_type != OP_QR && PL_compcv) { 9801 const PADOFFSET offset = pad_findmy_pvs("$_", 0); 9802 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) { 9803 o->op_targ = offset; 9804 o->op_private |= OPpTARGET_MY; 9805 } 9806 } 9807 if (o->op_type == OP_MATCH || o->op_type == OP_QR) 9808 o->op_private |= OPpRUNTIME; 9809 return o; 9810 } 9811 9812 OP * 9813 Perl_ck_method(pTHX_ OP *o) 9814 { 9815 OP * const kid = cUNOPo->op_first; 9816 9817 PERL_ARGS_ASSERT_CK_METHOD; 9818 9819 if (kid->op_type == OP_CONST) { 9820 SV* sv = kSVOP->op_sv; 9821 const char * const method = SvPVX_const(sv); 9822 if (!(strchr(method, ':') || strchr(method, '\''))) { 9823 OP *cmop; 9824 if (!SvIsCOW_shared_hash(sv)) { 9825 sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0); 9826 } 9827 else { 9828 kSVOP->op_sv = NULL; 9829 } 9830 cmop = newSVOP(OP_METHOD_NAMED, 0, sv); 9831 #ifdef PERL_MAD 9832 op_getmad(o,cmop,'O'); 9833 #else 9834 op_free(o); 9835 #endif 9836 return cmop; 9837 } 9838 } 9839 return o; 9840 } 9841 9842 OP * 9843 Perl_ck_null(pTHX_ OP *o) 9844 { 9845 PERL_ARGS_ASSERT_CK_NULL; 9846 PERL_UNUSED_CONTEXT; 9847 return o; 9848 } 9849 9850 OP * 9851 Perl_ck_open(pTHX_ OP *o) 9852 { 9853 dVAR; 9854 9855 PERL_ARGS_ASSERT_CK_OPEN; 9856 9857 S_io_hints(aTHX_ o); 9858 { 9859 /* In case of three-arg dup open remove strictness 9860 * from the last arg if it is a bareword. */ 9861 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */ 9862 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */ 9863 OP *oa; 9864 const char *mode; 9865 9866 if ((last->op_type == OP_CONST) && /* The bareword. */ 9867 (last->op_private & OPpCONST_BARE) && 9868 (last->op_private & OPpCONST_STRICT) && 9869 (oa = first->op_sibling) && /* The fh. */ 9870 (oa = oa->op_sibling) && /* The mode. */ 9871 (oa->op_type == OP_CONST) && 9872 SvPOK(((SVOP*)oa)->op_sv) && 9873 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) && 9874 mode[0] == '>' && mode[1] == '&' && /* A dup open. */ 9875 (last == oa->op_sibling)) /* The bareword. */ 9876 last->op_private &= ~OPpCONST_STRICT; 9877 } 9878 return ck_fun(o); 9879 } 9880 9881 OP * 9882 Perl_ck_repeat(pTHX_ OP *o) 9883 { 9884 PERL_ARGS_ASSERT_CK_REPEAT; 9885 9886 if (cBINOPo->op_first->op_flags & OPf_PARENS) { 9887 o->op_private |= OPpREPEAT_DOLIST; 9888 cBINOPo->op_first = force_list(cBINOPo->op_first); 9889 } 9890 else 9891 scalar(o); 9892 return o; 9893 } 9894 9895 OP * 9896 Perl_ck_require(pTHX_ OP *o) 9897 { 9898 dVAR; 9899 GV* gv; 9900 9901 PERL_ARGS_ASSERT_CK_REQUIRE; 9902 9903 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */ 9904 SVOP * const kid = (SVOP*)cUNOPo->op_first; 9905 9906 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { 9907 SV * const sv = kid->op_sv; 9908 U32 was_readonly = SvREADONLY(sv); 9909 char *s; 9910 STRLEN len; 9911 const char *end; 9912 9913 if (was_readonly) { 9914 SvREADONLY_off(sv); 9915 } 9916 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0); 9917 9918 s = SvPVX(sv); 9919 len = SvCUR(sv); 9920 end = s + len; 9921 for (; s < end; s++) { 9922 if (*s == ':' && s[1] == ':') { 9923 *s = '/'; 9924 Move(s+2, s+1, end - s - 1, char); 9925 --end; 9926 } 9927 } 9928 SvEND_set(sv, end); 9929 sv_catpvs(sv, ".pm"); 9930 SvFLAGS(sv) |= was_readonly; 9931 } 9932 } 9933 9934 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */ 9935 /* handle override, if any */ 9936 && (gv = gv_override("require", 7))) { 9937 OP *kid, *newop; 9938 if (o->op_flags & OPf_KIDS) { 9939 kid = cUNOPo->op_first; 9940 cUNOPo->op_first = NULL; 9941 } 9942 else { 9943 kid = newDEFSVOP(); 9944 } 9945 #ifndef PERL_MAD 9946 op_free(o); 9947 #endif 9948 newop = S_new_entersubop(aTHX_ gv, kid); 9949 op_getmad(o,newop,'O'); 9950 return newop; 9951 } 9952 9953 return scalar(ck_fun(o)); 9954 } 9955 9956 OP * 9957 Perl_ck_return(pTHX_ OP *o) 9958 { 9959 dVAR; 9960 OP *kid; 9961 9962 PERL_ARGS_ASSERT_CK_RETURN; 9963 9964 kid = cLISTOPo->op_first->op_sibling; 9965 if (CvLVALUE(PL_compcv)) { 9966 for (; kid; kid = kid->op_sibling) 9967 op_lvalue(kid, OP_LEAVESUBLV); 9968 } 9969 9970 return o; 9971 } 9972 9973 OP * 9974 Perl_ck_select(pTHX_ OP *o) 9975 { 9976 dVAR; 9977 OP* kid; 9978 9979 PERL_ARGS_ASSERT_CK_SELECT; 9980 9981 if (o->op_flags & OPf_KIDS) { 9982 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ 9983 if (kid && kid->op_sibling) { 9984 o->op_type = OP_SSELECT; 9985 o->op_ppaddr = PL_ppaddr[OP_SSELECT]; 9986 o = ck_fun(o); 9987 return fold_constants(op_integerize(op_std_init(o))); 9988 } 9989 } 9990 o = ck_fun(o); 9991 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ 9992 if (kid && kid->op_type == OP_RV2GV) 9993 kid->op_private &= ~HINT_STRICT_REFS; 9994 return o; 9995 } 9996 9997 OP * 9998 Perl_ck_shift(pTHX_ OP *o) 9999 { 10000 dVAR; 10001 const I32 type = o->op_type; 10002 10003 PERL_ARGS_ASSERT_CK_SHIFT; 10004 10005 if (!(o->op_flags & OPf_KIDS)) { 10006 OP *argop; 10007 10008 if (!CvUNIQUE(PL_compcv)) { 10009 o->op_flags |= OPf_SPECIAL; 10010 return o; 10011 } 10012 10013 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv))); 10014 #ifdef PERL_MAD 10015 { 10016 OP * const oldo = o; 10017 o = newUNOP(type, 0, scalar(argop)); 10018 op_getmad(oldo,o,'O'); 10019 return o; 10020 } 10021 #else 10022 op_free(o); 10023 return newUNOP(type, 0, scalar(argop)); 10024 #endif 10025 } 10026 return scalar(ck_fun(o)); 10027 } 10028 10029 OP * 10030 Perl_ck_sort(pTHX_ OP *o) 10031 { 10032 dVAR; 10033 OP *firstkid; 10034 OP *kid; 10035 HV * const hinthv = 10036 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL; 10037 U8 stacked; 10038 10039 PERL_ARGS_ASSERT_CK_SORT; 10040 10041 if (hinthv) { 10042 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE); 10043 if (svp) { 10044 const I32 sorthints = (I32)SvIV(*svp); 10045 if ((sorthints & HINT_SORT_QUICKSORT) != 0) 10046 o->op_private |= OPpSORT_QSORT; 10047 if ((sorthints & HINT_SORT_STABLE) != 0) 10048 o->op_private |= OPpSORT_STABLE; 10049 } 10050 } 10051 10052 if (o->op_flags & OPf_STACKED) 10053 simplify_sort(o); 10054 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ 10055 10056 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */ 10057 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */ 10058 10059 /* if the first arg is a code block, process it and mark sort as 10060 * OPf_SPECIAL */ 10061 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) { 10062 LINKLIST(kid); 10063 if (kid->op_type == OP_LEAVE) 10064 op_null(kid); /* wipe out leave */ 10065 /* Prevent execution from escaping out of the sort block. */ 10066 kid->op_next = 0; 10067 10068 /* provide scalar context for comparison function/block */ 10069 kid = scalar(firstkid); 10070 kid->op_next = kid; 10071 o->op_flags |= OPf_SPECIAL; 10072 } 10073 10074 firstkid = firstkid->op_sibling; 10075 } 10076 10077 for (kid = firstkid; kid; kid = kid->op_sibling) { 10078 /* provide list context for arguments */ 10079 list(kid); 10080 if (stacked) 10081 op_lvalue(kid, OP_GREPSTART); 10082 } 10083 10084 return o; 10085 } 10086 10087 /* for sort { X } ..., where X is one of 10088 * $a <=> $b, $b <= $a, $a cmp $b, $b cmp $a 10089 * elide the second child of the sort (the one containing X), 10090 * and set these flags as appropriate 10091 OPpSORT_NUMERIC; 10092 OPpSORT_INTEGER; 10093 OPpSORT_DESCEND; 10094 * Also, check and warn on lexical $a, $b. 10095 */ 10096 10097 STATIC void 10098 S_simplify_sort(pTHX_ OP *o) 10099 { 10100 dVAR; 10101 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ 10102 OP *k; 10103 int descending; 10104 GV *gv; 10105 const char *gvname; 10106 bool have_scopeop; 10107 10108 PERL_ARGS_ASSERT_SIMPLIFY_SORT; 10109 10110 kid = kUNOP->op_first; /* get past null */ 10111 if (!(have_scopeop = kid->op_type == OP_SCOPE) 10112 && kid->op_type != OP_LEAVE) 10113 return; 10114 kid = kLISTOP->op_last; /* get past scope */ 10115 switch(kid->op_type) { 10116 case OP_NCMP: 10117 case OP_I_NCMP: 10118 case OP_SCMP: 10119 if (!have_scopeop) goto padkids; 10120 break; 10121 default: 10122 return; 10123 } 10124 k = kid; /* remember this node*/ 10125 if (kBINOP->op_first->op_type != OP_RV2SV 10126 || kBINOP->op_last ->op_type != OP_RV2SV) 10127 { 10128 /* 10129 Warn about my($a) or my($b) in a sort block, *if* $a or $b is 10130 then used in a comparison. This catches most, but not 10131 all cases. For instance, it catches 10132 sort { my($a); $a <=> $b } 10133 but not 10134 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; } 10135 (although why you'd do that is anyone's guess). 10136 */ 10137 10138 padkids: 10139 if (!ckWARN(WARN_SYNTAX)) return; 10140 kid = kBINOP->op_first; 10141 do { 10142 if (kid->op_type == OP_PADSV) { 10143 SV * const name = AvARRAY(PL_comppad_name)[kid->op_targ]; 10144 if (SvCUR(name) == 2 && *SvPVX(name) == '$' 10145 && (SvPVX(name)[1] == 'a' || SvPVX(name)[1] == 'b')) 10146 /* diag_listed_as: "my %s" used in sort comparison */ 10147 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 10148 "\"%s %s\" used in sort comparison", 10149 SvPAD_STATE(name) ? "state" : "my", 10150 SvPVX(name)); 10151 } 10152 } while ((kid = kid->op_sibling)); 10153 return; 10154 } 10155 kid = kBINOP->op_first; /* get past cmp */ 10156 if (kUNOP->op_first->op_type != OP_GV) 10157 return; 10158 kid = kUNOP->op_first; /* get past rv2sv */ 10159 gv = kGVOP_gv; 10160 if (GvSTASH(gv) != PL_curstash) 10161 return; 10162 gvname = GvNAME(gv); 10163 if (*gvname == 'a' && gvname[1] == '\0') 10164 descending = 0; 10165 else if (*gvname == 'b' && gvname[1] == '\0') 10166 descending = 1; 10167 else 10168 return; 10169 10170 kid = k; /* back to cmp */ 10171 /* already checked above that it is rv2sv */ 10172 kid = kBINOP->op_last; /* down to 2nd arg */ 10173 if (kUNOP->op_first->op_type != OP_GV) 10174 return; 10175 kid = kUNOP->op_first; /* get past rv2sv */ 10176 gv = kGVOP_gv; 10177 if (GvSTASH(gv) != PL_curstash) 10178 return; 10179 gvname = GvNAME(gv); 10180 if ( descending 10181 ? !(*gvname == 'a' && gvname[1] == '\0') 10182 : !(*gvname == 'b' && gvname[1] == '\0')) 10183 return; 10184 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL); 10185 if (descending) 10186 o->op_private |= OPpSORT_DESCEND; 10187 if (k->op_type == OP_NCMP) 10188 o->op_private |= OPpSORT_NUMERIC; 10189 if (k->op_type == OP_I_NCMP) 10190 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER; 10191 kid = cLISTOPo->op_first->op_sibling; 10192 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */ 10193 #ifdef PERL_MAD 10194 op_getmad(kid,o,'S'); /* then delete it */ 10195 #else 10196 op_free(kid); /* then delete it */ 10197 #endif 10198 } 10199 10200 OP * 10201 Perl_ck_split(pTHX_ OP *o) 10202 { 10203 dVAR; 10204 OP *kid; 10205 10206 PERL_ARGS_ASSERT_CK_SPLIT; 10207 10208 if (o->op_flags & OPf_STACKED) 10209 return no_fh_allowed(o); 10210 10211 kid = cLISTOPo->op_first; 10212 if (kid->op_type != OP_NULL) 10213 Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type); 10214 kid = kid->op_sibling; 10215 op_free(cLISTOPo->op_first); 10216 if (kid) 10217 cLISTOPo->op_first = kid; 10218 else { 10219 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" ")); 10220 cLISTOPo->op_last = kid; /* There was only one element previously */ 10221 } 10222 10223 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) { 10224 OP * const sibl = kid->op_sibling; 10225 kid->op_sibling = 0; 10226 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0, 0); /* OPf_SPECIAL is used to trigger split " " behavior */ 10227 if (cLISTOPo->op_first == cLISTOPo->op_last) 10228 cLISTOPo->op_last = kid; 10229 cLISTOPo->op_first = kid; 10230 kid->op_sibling = sibl; 10231 } 10232 10233 kid->op_type = OP_PUSHRE; 10234 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE]; 10235 scalar(kid); 10236 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) { 10237 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), 10238 "Use of /g modifier is meaningless in split"); 10239 } 10240 10241 if (!kid->op_sibling) 10242 op_append_elem(OP_SPLIT, o, newDEFSVOP()); 10243 10244 kid = kid->op_sibling; 10245 scalar(kid); 10246 10247 if (!kid->op_sibling) 10248 { 10249 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0))); 10250 o->op_private |= OPpSPLIT_IMPLIM; 10251 } 10252 assert(kid->op_sibling); 10253 10254 kid = kid->op_sibling; 10255 scalar(kid); 10256 10257 if (kid->op_sibling) 10258 return too_many_arguments_pv(o,OP_DESC(o), 0); 10259 10260 return o; 10261 } 10262 10263 OP * 10264 Perl_ck_join(pTHX_ OP *o) 10265 { 10266 const OP * const kid = cLISTOPo->op_first->op_sibling; 10267 10268 PERL_ARGS_ASSERT_CK_JOIN; 10269 10270 if (kid && kid->op_type == OP_MATCH) { 10271 if (ckWARN(WARN_SYNTAX)) { 10272 const REGEXP *re = PM_GETRE(kPMOP); 10273 const SV *msg = re 10274 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re), 10275 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) ) 10276 : newSVpvs_flags( "STRING", SVs_TEMP ); 10277 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 10278 "/%"SVf"/ should probably be written as \"%"SVf"\"", 10279 SVfARG(msg), SVfARG(msg)); 10280 } 10281 } 10282 return ck_fun(o); 10283 } 10284 10285 /* 10286 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags 10287 10288 Examines an op, which is expected to identify a subroutine at runtime, 10289 and attempts to determine at compile time which subroutine it identifies. 10290 This is normally used during Perl compilation to determine whether 10291 a prototype can be applied to a function call. I<cvop> is the op 10292 being considered, normally an C<rv2cv> op. A pointer to the identified 10293 subroutine is returned, if it could be determined statically, and a null 10294 pointer is returned if it was not possible to determine statically. 10295 10296 Currently, the subroutine can be identified statically if the RV that the 10297 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op. 10298 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is 10299 suitable if the constant value must be an RV pointing to a CV. Details of 10300 this process may change in future versions of Perl. If the C<rv2cv> op 10301 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify 10302 the subroutine statically: this flag is used to suppress compile-time 10303 magic on a subroutine call, forcing it to use default runtime behaviour. 10304 10305 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling 10306 of a GV reference is modified. If a GV was examined and its CV slot was 10307 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set. 10308 If the op is not optimised away, and the CV slot is later populated with 10309 a subroutine having a prototype, that flag eventually triggers the warning 10310 "called too early to check prototype". 10311 10312 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead 10313 of returning a pointer to the subroutine it returns a pointer to the 10314 GV giving the most appropriate name for the subroutine in this context. 10315 Normally this is just the C<CvGV> of the subroutine, but for an anonymous 10316 (C<CvANON>) subroutine that is referenced through a GV it will be the 10317 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned. 10318 A null pointer is returned as usual if there is no statically-determinable 10319 subroutine. 10320 10321 =cut 10322 */ 10323 10324 /* shared by toke.c:yylex */ 10325 CV * 10326 Perl_find_lexical_cv(pTHX_ PADOFFSET off) 10327 { 10328 PADNAME *name = PAD_COMPNAME(off); 10329 CV *compcv = PL_compcv; 10330 while (PadnameOUTER(name)) { 10331 assert(PARENT_PAD_INDEX(name)); 10332 compcv = CvOUTSIDE(PL_compcv); 10333 name = PadlistNAMESARRAY(CvPADLIST(compcv)) 10334 [off = PARENT_PAD_INDEX(name)]; 10335 } 10336 assert(!PadnameIsOUR(name)); 10337 if (!PadnameIsSTATE(name) && SvMAGICAL(name)) { 10338 MAGIC * mg = mg_find(name, PERL_MAGIC_proto); 10339 assert(mg); 10340 assert(mg->mg_obj); 10341 return (CV *)mg->mg_obj; 10342 } 10343 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off]; 10344 } 10345 10346 CV * 10347 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags) 10348 { 10349 OP *rvop; 10350 CV *cv; 10351 GV *gv; 10352 PERL_ARGS_ASSERT_RV2CV_OP_CV; 10353 if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV)) 10354 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags); 10355 if (cvop->op_type != OP_RV2CV) 10356 return NULL; 10357 if (cvop->op_private & OPpENTERSUB_AMPER) 10358 return NULL; 10359 if (!(cvop->op_flags & OPf_KIDS)) 10360 return NULL; 10361 rvop = cUNOPx(cvop)->op_first; 10362 switch (rvop->op_type) { 10363 case OP_GV: { 10364 gv = cGVOPx_gv(rvop); 10365 cv = GvCVu(gv); 10366 if (!cv) { 10367 if (flags & RV2CVOPCV_MARK_EARLY) 10368 rvop->op_private |= OPpEARLY_CV; 10369 return NULL; 10370 } 10371 } break; 10372 case OP_CONST: { 10373 SV *rv = cSVOPx_sv(rvop); 10374 if (!SvROK(rv)) 10375 return NULL; 10376 cv = (CV*)SvRV(rv); 10377 gv = NULL; 10378 } break; 10379 case OP_PADCV: { 10380 cv = find_lexical_cv(rvop->op_targ); 10381 gv = NULL; 10382 } break; 10383 default: { 10384 return NULL; 10385 } break; 10386 } 10387 if (SvTYPE((SV*)cv) != SVt_PVCV) 10388 return NULL; 10389 if (flags & RV2CVOPCV_RETURN_NAME_GV) { 10390 if (!CvANON(cv) || !gv) 10391 gv = CvGV(cv); 10392 return (CV*)gv; 10393 } else { 10394 return cv; 10395 } 10396 } 10397 10398 /* 10399 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop 10400 10401 Performs the default fixup of the arguments part of an C<entersub> 10402 op tree. This consists of applying list context to each of the 10403 argument ops. This is the standard treatment used on a call marked 10404 with C<&>, or a method call, or a call through a subroutine reference, 10405 or any other call where the callee can't be identified at compile time, 10406 or a call where the callee has no prototype. 10407 10408 =cut 10409 */ 10410 10411 OP * 10412 Perl_ck_entersub_args_list(pTHX_ OP *entersubop) 10413 { 10414 OP *aop; 10415 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST; 10416 aop = cUNOPx(entersubop)->op_first; 10417 if (!aop->op_sibling) 10418 aop = cUNOPx(aop)->op_first; 10419 for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) { 10420 if (!(PL_madskills && aop->op_type == OP_STUB)) { 10421 list(aop); 10422 op_lvalue(aop, OP_ENTERSUB); 10423 } 10424 } 10425 return entersubop; 10426 } 10427 10428 /* 10429 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv 10430 10431 Performs the fixup of the arguments part of an C<entersub> op tree 10432 based on a subroutine prototype. This makes various modifications to 10433 the argument ops, from applying context up to inserting C<refgen> ops, 10434 and checking the number and syntactic types of arguments, as directed by 10435 the prototype. This is the standard treatment used on a subroutine call, 10436 not marked with C<&>, where the callee can be identified at compile time 10437 and has a prototype. 10438 10439 I<protosv> supplies the subroutine prototype to be applied to the call. 10440 It may be a normal defined scalar, of which the string value will be used. 10441 Alternatively, for convenience, it may be a subroutine object (a C<CV*> 10442 that has been cast to C<SV*>) which has a prototype. The prototype 10443 supplied, in whichever form, does not need to match the actual callee 10444 referenced by the op tree. 10445 10446 If the argument ops disagree with the prototype, for example by having 10447 an unacceptable number of arguments, a valid op tree is returned anyway. 10448 The error is reflected in the parser state, normally resulting in a single 10449 exception at the top level of parsing which covers all the compilation 10450 errors that occurred. In the error message, the callee is referred to 10451 by the name defined by the I<namegv> parameter. 10452 10453 =cut 10454 */ 10455 10456 OP * 10457 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) 10458 { 10459 STRLEN proto_len; 10460 const char *proto, *proto_end; 10461 OP *aop, *prev, *cvop; 10462 int optional = 0; 10463 I32 arg = 0; 10464 I32 contextclass = 0; 10465 const char *e = NULL; 10466 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO; 10467 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv)) 10468 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, " 10469 "flags=%lx", (unsigned long) SvFLAGS(protosv)); 10470 if (SvTYPE(protosv) == SVt_PVCV) 10471 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv); 10472 else proto = SvPV(protosv, proto_len); 10473 proto = S_strip_spaces(aTHX_ proto, &proto_len); 10474 proto_end = proto + proto_len; 10475 aop = cUNOPx(entersubop)->op_first; 10476 if (!aop->op_sibling) 10477 aop = cUNOPx(aop)->op_first; 10478 prev = aop; 10479 aop = aop->op_sibling; 10480 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ; 10481 while (aop != cvop) { 10482 OP* o3; 10483 if (PL_madskills && aop->op_type == OP_STUB) { 10484 aop = aop->op_sibling; 10485 continue; 10486 } 10487 if (PL_madskills && aop->op_type == OP_NULL) 10488 o3 = ((UNOP*)aop)->op_first; 10489 else 10490 o3 = aop; 10491 10492 if (proto >= proto_end) 10493 return too_many_arguments_sv(entersubop, gv_ename(namegv), 0); 10494 10495 switch (*proto) { 10496 case ';': 10497 optional = 1; 10498 proto++; 10499 continue; 10500 case '_': 10501 /* _ must be at the end */ 10502 if (proto[1] && !strchr(";@%", proto[1])) 10503 goto oops; 10504 case '$': 10505 proto++; 10506 arg++; 10507 scalar(aop); 10508 break; 10509 case '%': 10510 case '@': 10511 list(aop); 10512 arg++; 10513 break; 10514 case '&': 10515 proto++; 10516 arg++; 10517 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF) 10518 bad_type_gv(arg, 10519 arg == 1 ? "block or sub {}" : "sub {}", 10520 namegv, 0, o3); 10521 break; 10522 case '*': 10523 /* '*' allows any scalar type, including bareword */ 10524 proto++; 10525 arg++; 10526 if (o3->op_type == OP_RV2GV) 10527 goto wrapref; /* autoconvert GLOB -> GLOBref */ 10528 else if (o3->op_type == OP_CONST) 10529 o3->op_private &= ~OPpCONST_STRICT; 10530 else if (o3->op_type == OP_ENTERSUB) { 10531 /* accidental subroutine, revert to bareword */ 10532 OP *gvop = ((UNOP*)o3)->op_first; 10533 if (gvop && gvop->op_type == OP_NULL) { 10534 gvop = ((UNOP*)gvop)->op_first; 10535 if (gvop) { 10536 for (; gvop->op_sibling; gvop = gvop->op_sibling) 10537 ; 10538 if (gvop && 10539 (gvop->op_private & OPpENTERSUB_NOPAREN) && 10540 (gvop = ((UNOP*)gvop)->op_first) && 10541 gvop->op_type == OP_GV) 10542 { 10543 GV * const gv = cGVOPx_gv(gvop); 10544 OP * const sibling = aop->op_sibling; 10545 SV * const n = newSVpvs(""); 10546 #ifdef PERL_MAD 10547 OP * const oldaop = aop; 10548 #else 10549 op_free(aop); 10550 #endif 10551 gv_fullname4(n, gv, "", FALSE); 10552 aop = newSVOP(OP_CONST, 0, n); 10553 op_getmad(oldaop,aop,'O'); 10554 prev->op_sibling = aop; 10555 aop->op_sibling = sibling; 10556 } 10557 } 10558 } 10559 } 10560 scalar(aop); 10561 break; 10562 case '+': 10563 proto++; 10564 arg++; 10565 if (o3->op_type == OP_RV2AV || 10566 o3->op_type == OP_PADAV || 10567 o3->op_type == OP_RV2HV || 10568 o3->op_type == OP_PADHV 10569 ) { 10570 goto wrapref; 10571 } 10572 scalar(aop); 10573 break; 10574 case '[': case ']': 10575 goto oops; 10576 break; 10577 case '\\': 10578 proto++; 10579 arg++; 10580 again: 10581 switch (*proto++) { 10582 case '[': 10583 if (contextclass++ == 0) { 10584 e = strchr(proto, ']'); 10585 if (!e || e == proto) 10586 goto oops; 10587 } 10588 else 10589 goto oops; 10590 goto again; 10591 break; 10592 case ']': 10593 if (contextclass) { 10594 const char *p = proto; 10595 const char *const end = proto; 10596 contextclass = 0; 10597 while (*--p != '[') 10598 /* \[$] accepts any scalar lvalue */ 10599 if (*p == '$' 10600 && Perl_op_lvalue_flags(aTHX_ 10601 scalar(o3), 10602 OP_READ, /* not entersub */ 10603 OP_LVALUE_NO_CROAK 10604 )) goto wrapref; 10605 bad_type_gv(arg, Perl_form(aTHX_ "one of %.*s", 10606 (int)(end - p), p), 10607 namegv, 0, o3); 10608 } else 10609 goto oops; 10610 break; 10611 case '*': 10612 if (o3->op_type == OP_RV2GV) 10613 goto wrapref; 10614 if (!contextclass) 10615 bad_type_gv(arg, "symbol", namegv, 0, o3); 10616 break; 10617 case '&': 10618 if (o3->op_type == OP_ENTERSUB) 10619 goto wrapref; 10620 if (!contextclass) 10621 bad_type_gv(arg, "subroutine entry", namegv, 0, 10622 o3); 10623 break; 10624 case '$': 10625 if (o3->op_type == OP_RV2SV || 10626 o3->op_type == OP_PADSV || 10627 o3->op_type == OP_HELEM || 10628 o3->op_type == OP_AELEM) 10629 goto wrapref; 10630 if (!contextclass) { 10631 /* \$ accepts any scalar lvalue */ 10632 if (Perl_op_lvalue_flags(aTHX_ 10633 scalar(o3), 10634 OP_READ, /* not entersub */ 10635 OP_LVALUE_NO_CROAK 10636 )) goto wrapref; 10637 bad_type_gv(arg, "scalar", namegv, 0, o3); 10638 } 10639 break; 10640 case '@': 10641 if (o3->op_type == OP_RV2AV || 10642 o3->op_type == OP_PADAV) 10643 goto wrapref; 10644 if (!contextclass) 10645 bad_type_gv(arg, "array", namegv, 0, o3); 10646 break; 10647 case '%': 10648 if (o3->op_type == OP_RV2HV || 10649 o3->op_type == OP_PADHV) 10650 goto wrapref; 10651 if (!contextclass) 10652 bad_type_gv(arg, "hash", namegv, 0, o3); 10653 break; 10654 wrapref: 10655 { 10656 OP* const kid = aop; 10657 OP* const sib = kid->op_sibling; 10658 kid->op_sibling = 0; 10659 aop = newUNOP(OP_REFGEN, 0, kid); 10660 aop->op_sibling = sib; 10661 prev->op_sibling = aop; 10662 } 10663 if (contextclass && e) { 10664 proto = e + 1; 10665 contextclass = 0; 10666 } 10667 break; 10668 default: goto oops; 10669 } 10670 if (contextclass) 10671 goto again; 10672 break; 10673 case ' ': 10674 proto++; 10675 continue; 10676 default: 10677 oops: { 10678 SV* const tmpsv = sv_newmortal(); 10679 gv_efullname3(tmpsv, namegv, NULL); 10680 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf, 10681 SVfARG(tmpsv), SVfARG(protosv)); 10682 } 10683 } 10684 10685 op_lvalue(aop, OP_ENTERSUB); 10686 prev = aop; 10687 aop = aop->op_sibling; 10688 } 10689 if (aop == cvop && *proto == '_') { 10690 /* generate an access to $_ */ 10691 aop = newDEFSVOP(); 10692 aop->op_sibling = prev->op_sibling; 10693 prev->op_sibling = aop; /* instead of cvop */ 10694 } 10695 if (!optional && proto_end > proto && 10696 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_')) 10697 return too_few_arguments_sv(entersubop, gv_ename(namegv), 0); 10698 return entersubop; 10699 } 10700 10701 /* 10702 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv 10703 10704 Performs the fixup of the arguments part of an C<entersub> op tree either 10705 based on a subroutine prototype or using default list-context processing. 10706 This is the standard treatment used on a subroutine call, not marked 10707 with C<&>, where the callee can be identified at compile time. 10708 10709 I<protosv> supplies the subroutine prototype to be applied to the call, 10710 or indicates that there is no prototype. It may be a normal scalar, 10711 in which case if it is defined then the string value will be used 10712 as a prototype, and if it is undefined then there is no prototype. 10713 Alternatively, for convenience, it may be a subroutine object (a C<CV*> 10714 that has been cast to C<SV*>), of which the prototype will be used if it 10715 has one. The prototype (or lack thereof) supplied, in whichever form, 10716 does not need to match the actual callee referenced by the op tree. 10717 10718 If the argument ops disagree with the prototype, for example by having 10719 an unacceptable number of arguments, a valid op tree is returned anyway. 10720 The error is reflected in the parser state, normally resulting in a single 10721 exception at the top level of parsing which covers all the compilation 10722 errors that occurred. In the error message, the callee is referred to 10723 by the name defined by the I<namegv> parameter. 10724 10725 =cut 10726 */ 10727 10728 OP * 10729 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop, 10730 GV *namegv, SV *protosv) 10731 { 10732 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST; 10733 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv)) 10734 return ck_entersub_args_proto(entersubop, namegv, protosv); 10735 else 10736 return ck_entersub_args_list(entersubop); 10737 } 10738 10739 OP * 10740 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv) 10741 { 10742 int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv); 10743 OP *aop = cUNOPx(entersubop)->op_first; 10744 10745 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE; 10746 10747 if (!opnum) { 10748 OP *cvop; 10749 if (!aop->op_sibling) 10750 aop = cUNOPx(aop)->op_first; 10751 aop = aop->op_sibling; 10752 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ; 10753 if (PL_madskills) while (aop != cvop && aop->op_type == OP_STUB) { 10754 aop = aop->op_sibling; 10755 } 10756 if (aop != cvop) 10757 (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0); 10758 10759 op_free(entersubop); 10760 switch(GvNAME(namegv)[2]) { 10761 case 'F': return newSVOP(OP_CONST, 0, 10762 newSVpv(CopFILE(PL_curcop),0)); 10763 case 'L': return newSVOP( 10764 OP_CONST, 0, 10765 Perl_newSVpvf(aTHX_ 10766 "%"IVdf, (IV)CopLINE(PL_curcop) 10767 ) 10768 ); 10769 case 'P': return newSVOP(OP_CONST, 0, 10770 (PL_curstash 10771 ? newSVhek(HvNAME_HEK(PL_curstash)) 10772 : &PL_sv_undef 10773 ) 10774 ); 10775 } 10776 NOT_REACHED; 10777 } 10778 else { 10779 OP *prev, *cvop; 10780 U32 flags; 10781 #ifdef PERL_MAD 10782 bool seenarg = FALSE; 10783 #endif 10784 if (!aop->op_sibling) 10785 aop = cUNOPx(aop)->op_first; 10786 10787 prev = aop; 10788 aop = aop->op_sibling; 10789 prev->op_sibling = NULL; 10790 for (cvop = aop; 10791 cvop->op_sibling; 10792 prev=cvop, cvop = cvop->op_sibling) 10793 #ifdef PERL_MAD 10794 if (PL_madskills && cvop->op_sibling 10795 && cvop->op_type != OP_STUB) seenarg = TRUE 10796 #endif 10797 ; 10798 prev->op_sibling = NULL; 10799 flags = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN); 10800 op_free(cvop); 10801 if (aop == cvop) aop = NULL; 10802 op_free(entersubop); 10803 10804 if (opnum == OP_ENTEREVAL 10805 && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9)) 10806 flags |= OPpEVAL_BYTES <<8; 10807 10808 switch (PL_opargs[opnum] & OA_CLASS_MASK) { 10809 case OA_UNOP: 10810 case OA_BASEOP_OR_UNOP: 10811 case OA_FILESTATOP: 10812 return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags); 10813 case OA_BASEOP: 10814 if (aop) { 10815 #ifdef PERL_MAD 10816 if (!PL_madskills || seenarg) 10817 #endif 10818 (void)too_many_arguments_pv(aop, GvNAME(namegv), 0); 10819 op_free(aop); 10820 } 10821 return opnum == OP_RUNCV 10822 ? newPVOP(OP_RUNCV,0,NULL) 10823 : newOP(opnum,0); 10824 default: 10825 return convert(opnum,0,aop); 10826 } 10827 } 10828 assert(0); 10829 return entersubop; 10830 } 10831 10832 /* 10833 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p 10834 10835 Retrieves the function that will be used to fix up a call to I<cv>. 10836 Specifically, the function is applied to an C<entersub> op tree for a 10837 subroutine call, not marked with C<&>, where the callee can be identified 10838 at compile time as I<cv>. 10839 10840 The C-level function pointer is returned in I<*ckfun_p>, and an SV 10841 argument for it is returned in I<*ckobj_p>. The function is intended 10842 to be called in this manner: 10843 10844 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p)); 10845 10846 In this call, I<entersubop> is a pointer to the C<entersub> op, 10847 which may be replaced by the check function, and I<namegv> is a GV 10848 supplying the name that should be used by the check function to refer 10849 to the callee of the C<entersub> op if it needs to emit any diagnostics. 10850 It is permitted to apply the check function in non-standard situations, 10851 such as to a call to a different subroutine or to a method call. 10852 10853 By default, the function is 10854 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>, 10855 and the SV parameter is I<cv> itself. This implements standard 10856 prototype processing. It can be changed, for a particular subroutine, 10857 by L</cv_set_call_checker>. 10858 10859 =cut 10860 */ 10861 10862 void 10863 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p) 10864 { 10865 MAGIC *callmg; 10866 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER; 10867 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL; 10868 if (callmg) { 10869 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr); 10870 *ckobj_p = callmg->mg_obj; 10871 } else { 10872 *ckfun_p = Perl_ck_entersub_args_proto_or_list; 10873 *ckobj_p = (SV*)cv; 10874 } 10875 } 10876 10877 /* 10878 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj 10879 10880 Sets the function that will be used to fix up a call to I<cv>. 10881 Specifically, the function is applied to an C<entersub> op tree for a 10882 subroutine call, not marked with C<&>, where the callee can be identified 10883 at compile time as I<cv>. 10884 10885 The C-level function pointer is supplied in I<ckfun>, and an SV argument 10886 for it is supplied in I<ckobj>. The function should be defined like this: 10887 10888 STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj) 10889 10890 It is intended to be called in this manner: 10891 10892 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj); 10893 10894 In this call, I<entersubop> is a pointer to the C<entersub> op, 10895 which may be replaced by the check function, and I<namegv> is a GV 10896 supplying the name that should be used by the check function to refer 10897 to the callee of the C<entersub> op if it needs to emit any diagnostics. 10898 It is permitted to apply the check function in non-standard situations, 10899 such as to a call to a different subroutine or to a method call. 10900 10901 The current setting for a particular CV can be retrieved by 10902 L</cv_get_call_checker>. 10903 10904 =cut 10905 */ 10906 10907 void 10908 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj) 10909 { 10910 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER; 10911 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) { 10912 if (SvMAGICAL((SV*)cv)) 10913 mg_free_type((SV*)cv, PERL_MAGIC_checkcall); 10914 } else { 10915 MAGIC *callmg; 10916 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0); 10917 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall); 10918 if (callmg->mg_flags & MGf_REFCOUNTED) { 10919 SvREFCNT_dec(callmg->mg_obj); 10920 callmg->mg_flags &= ~MGf_REFCOUNTED; 10921 } 10922 callmg->mg_ptr = FPTR2DPTR(char *, ckfun); 10923 callmg->mg_obj = ckobj; 10924 if (ckobj != (SV*)cv) { 10925 SvREFCNT_inc_simple_void_NN(ckobj); 10926 callmg->mg_flags |= MGf_REFCOUNTED; 10927 } 10928 callmg->mg_flags |= MGf_COPY; 10929 } 10930 } 10931 10932 OP * 10933 Perl_ck_subr(pTHX_ OP *o) 10934 { 10935 OP *aop, *cvop; 10936 CV *cv; 10937 GV *namegv; 10938 10939 PERL_ARGS_ASSERT_CK_SUBR; 10940 10941 aop = cUNOPx(o)->op_first; 10942 if (!aop->op_sibling) 10943 aop = cUNOPx(aop)->op_first; 10944 aop = aop->op_sibling; 10945 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ; 10946 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY); 10947 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL; 10948 10949 o->op_private &= ~1; 10950 o->op_private |= OPpENTERSUB_HASTARG; 10951 o->op_private |= (PL_hints & HINT_STRICT_REFS); 10952 if (PERLDB_SUB && PL_curstash != PL_debstash) 10953 o->op_private |= OPpENTERSUB_DB; 10954 if (cvop->op_type == OP_RV2CV) { 10955 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER); 10956 op_null(cvop); 10957 } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) { 10958 if (aop->op_type == OP_CONST) 10959 aop->op_private &= ~OPpCONST_STRICT; 10960 else if (aop->op_type == OP_LIST) { 10961 OP * const sib = ((UNOP*)aop)->op_first->op_sibling; 10962 if (sib && sib->op_type == OP_CONST) 10963 sib->op_private &= ~OPpCONST_STRICT; 10964 } 10965 } 10966 10967 if (!cv) { 10968 return ck_entersub_args_list(o); 10969 } else { 10970 Perl_call_checker ckfun; 10971 SV *ckobj; 10972 cv_get_call_checker(cv, &ckfun, &ckobj); 10973 if (!namegv) { /* expletive! */ 10974 /* XXX The call checker API is public. And it guarantees that 10975 a GV will be provided with the right name. So we have 10976 to create a GV. But it is still not correct, as its 10977 stringification will include the package. What we 10978 really need is a new call checker API that accepts a 10979 GV or string (or GV or CV). */ 10980 HEK * const hek = CvNAME_HEK(cv); 10981 /* After a syntax error in a lexical sub, the cv that 10982 rv2cv_op_cv returns may be a nameless stub. */ 10983 if (!hek) return ck_entersub_args_list(o);; 10984 namegv = (GV *)sv_newmortal(); 10985 gv_init_pvn(namegv, PL_curstash, HEK_KEY(hek), HEK_LEN(hek), 10986 SVf_UTF8 * !!HEK_UTF8(hek)); 10987 } 10988 return ckfun(aTHX_ o, namegv, ckobj); 10989 } 10990 } 10991 10992 OP * 10993 Perl_ck_svconst(pTHX_ OP *o) 10994 { 10995 SV * const sv = cSVOPo->op_sv; 10996 PERL_ARGS_ASSERT_CK_SVCONST; 10997 PERL_UNUSED_CONTEXT; 10998 #ifdef PERL_OLD_COPY_ON_WRITE 10999 if (SvIsCOW(sv)) sv_force_normal(sv); 11000 #elif defined(PERL_NEW_COPY_ON_WRITE) 11001 /* Since the read-only flag may be used to protect a string buffer, we 11002 cannot do copy-on-write with existing read-only scalars that are not 11003 already copy-on-write scalars. To allow $_ = "hello" to do COW with 11004 that constant, mark the constant as COWable here, if it is not 11005 already read-only. */ 11006 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) { 11007 SvIsCOW_on(sv); 11008 CowREFCNT(sv) = 0; 11009 # ifdef PERL_DEBUG_READONLY_COW 11010 sv_buf_to_ro(sv); 11011 # endif 11012 } 11013 #endif 11014 SvREADONLY_on(sv); 11015 return o; 11016 } 11017 11018 OP * 11019 Perl_ck_trunc(pTHX_ OP *o) 11020 { 11021 PERL_ARGS_ASSERT_CK_TRUNC; 11022 11023 if (o->op_flags & OPf_KIDS) { 11024 SVOP *kid = (SVOP*)cUNOPo->op_first; 11025 11026 if (kid->op_type == OP_NULL) 11027 kid = (SVOP*)kid->op_sibling; 11028 if (kid && kid->op_type == OP_CONST && 11029 (kid->op_private & OPpCONST_BARE) && 11030 !kid->op_folded) 11031 { 11032 o->op_flags |= OPf_SPECIAL; 11033 kid->op_private &= ~OPpCONST_STRICT; 11034 } 11035 } 11036 return ck_fun(o); 11037 } 11038 11039 OP * 11040 Perl_ck_substr(pTHX_ OP *o) 11041 { 11042 PERL_ARGS_ASSERT_CK_SUBSTR; 11043 11044 o = ck_fun(o); 11045 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) { 11046 OP *kid = cLISTOPo->op_first; 11047 11048 if (kid->op_type == OP_NULL) 11049 kid = kid->op_sibling; 11050 if (kid) 11051 kid->op_flags |= OPf_MOD; 11052 11053 } 11054 return o; 11055 } 11056 11057 OP * 11058 Perl_ck_tell(pTHX_ OP *o) 11059 { 11060 PERL_ARGS_ASSERT_CK_TELL; 11061 o = ck_fun(o); 11062 if (o->op_flags & OPf_KIDS) { 11063 OP *kid = cLISTOPo->op_first; 11064 if (kid->op_type == OP_NULL && kid->op_sibling) kid = kid->op_sibling; 11065 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE; 11066 } 11067 return o; 11068 } 11069 11070 OP * 11071 Perl_ck_each(pTHX_ OP *o) 11072 { 11073 dVAR; 11074 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL; 11075 const unsigned orig_type = o->op_type; 11076 const unsigned array_type = orig_type == OP_EACH ? OP_AEACH 11077 : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES; 11078 const unsigned ref_type = orig_type == OP_EACH ? OP_REACH 11079 : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES; 11080 11081 PERL_ARGS_ASSERT_CK_EACH; 11082 11083 if (kid) { 11084 switch (kid->op_type) { 11085 case OP_PADHV: 11086 case OP_RV2HV: 11087 break; 11088 case OP_PADAV: 11089 case OP_RV2AV: 11090 CHANGE_TYPE(o, array_type); 11091 break; 11092 case OP_CONST: 11093 if (kid->op_private == OPpCONST_BARE 11094 || !SvROK(cSVOPx_sv(kid)) 11095 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV 11096 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV ) 11097 ) 11098 /* we let ck_fun handle it */ 11099 break; 11100 default: 11101 CHANGE_TYPE(o, ref_type); 11102 scalar(kid); 11103 } 11104 } 11105 /* if treating as a reference, defer additional checks to runtime */ 11106 if (o->op_type == ref_type) { 11107 /* diag_listed_as: keys on reference is experimental */ 11108 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__AUTODEREF), 11109 "%s is experimental", PL_op_desc[ref_type]); 11110 return o; 11111 } 11112 return ck_fun(o); 11113 } 11114 11115 OP * 11116 Perl_ck_length(pTHX_ OP *o) 11117 { 11118 PERL_ARGS_ASSERT_CK_LENGTH; 11119 11120 o = ck_fun(o); 11121 11122 if (ckWARN(WARN_SYNTAX)) { 11123 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL; 11124 11125 if (kid) { 11126 SV *name = NULL; 11127 const bool hash = kid->op_type == OP_PADHV 11128 || kid->op_type == OP_RV2HV; 11129 switch (kid->op_type) { 11130 case OP_PADHV: 11131 case OP_PADAV: 11132 case OP_RV2HV: 11133 case OP_RV2AV: 11134 name = S_op_varname(aTHX_ kid); 11135 break; 11136 default: 11137 return o; 11138 } 11139 if (name) 11140 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 11141 "length() used on %"SVf" (did you mean \"scalar(%s%"SVf 11142 ")\"?)", 11143 name, hash ? "keys " : "", name 11144 ); 11145 else if (hash) 11146 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */ 11147 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 11148 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)"); 11149 else 11150 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */ 11151 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 11152 "length() used on @array (did you mean \"scalar(@array)\"?)"); 11153 } 11154 } 11155 11156 return o; 11157 } 11158 11159 /* Check for in place reverse and sort assignments like "@a = reverse @a" 11160 and modify the optree to make them work inplace */ 11161 11162 STATIC void 11163 S_inplace_aassign(pTHX_ OP *o) { 11164 11165 OP *modop, *modop_pushmark; 11166 OP *oright; 11167 OP *oleft, *oleft_pushmark; 11168 11169 PERL_ARGS_ASSERT_INPLACE_AASSIGN; 11170 11171 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID); 11172 11173 assert(cUNOPo->op_first->op_type == OP_NULL); 11174 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first; 11175 assert(modop_pushmark->op_type == OP_PUSHMARK); 11176 modop = modop_pushmark->op_sibling; 11177 11178 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE) 11179 return; 11180 11181 /* no other operation except sort/reverse */ 11182 if (modop->op_sibling) 11183 return; 11184 11185 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK); 11186 if (!(oright = cUNOPx(modop)->op_first->op_sibling)) return; 11187 11188 if (modop->op_flags & OPf_STACKED) { 11189 /* skip sort subroutine/block */ 11190 assert(oright->op_type == OP_NULL); 11191 oright = oright->op_sibling; 11192 } 11193 11194 assert(cUNOPo->op_first->op_sibling->op_type == OP_NULL); 11195 oleft_pushmark = cUNOPx(cUNOPo->op_first->op_sibling)->op_first; 11196 assert(oleft_pushmark->op_type == OP_PUSHMARK); 11197 oleft = oleft_pushmark->op_sibling; 11198 11199 /* Check the lhs is an array */ 11200 if (!oleft || 11201 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV) 11202 || oleft->op_sibling 11203 || (oleft->op_private & OPpLVAL_INTRO) 11204 ) 11205 return; 11206 11207 /* Only one thing on the rhs */ 11208 if (oright->op_sibling) 11209 return; 11210 11211 /* check the array is the same on both sides */ 11212 if (oleft->op_type == OP_RV2AV) { 11213 if (oright->op_type != OP_RV2AV 11214 || !cUNOPx(oright)->op_first 11215 || cUNOPx(oright)->op_first->op_type != OP_GV 11216 || cUNOPx(oleft )->op_first->op_type != OP_GV 11217 || cGVOPx_gv(cUNOPx(oleft)->op_first) != 11218 cGVOPx_gv(cUNOPx(oright)->op_first) 11219 ) 11220 return; 11221 } 11222 else if (oright->op_type != OP_PADAV 11223 || oright->op_targ != oleft->op_targ 11224 ) 11225 return; 11226 11227 /* This actually is an inplace assignment */ 11228 11229 modop->op_private |= OPpSORT_INPLACE; 11230 11231 /* transfer MODishness etc from LHS arg to RHS arg */ 11232 oright->op_flags = oleft->op_flags; 11233 11234 /* remove the aassign op and the lhs */ 11235 op_null(o); 11236 op_null(oleft_pushmark); 11237 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first) 11238 op_null(cUNOPx(oleft)->op_first); 11239 op_null(oleft); 11240 } 11241 11242 11243 11244 /* mechanism for deferring recursion in rpeep() */ 11245 11246 #define MAX_DEFERRED 4 11247 11248 #define DEFER(o) \ 11249 STMT_START { \ 11250 if (defer_ix == (MAX_DEFERRED-1)) { \ 11251 OP **defer = defer_queue[defer_base]; \ 11252 CALL_RPEEP(*defer); \ 11253 S_prune_chain_head(aTHX_ defer); \ 11254 defer_base = (defer_base + 1) % MAX_DEFERRED; \ 11255 defer_ix--; \ 11256 } \ 11257 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \ 11258 } STMT_END 11259 11260 #define IS_AND_OP(o) (o->op_type == OP_AND) 11261 #define IS_OR_OP(o) (o->op_type == OP_OR) 11262 11263 11264 STATIC void 11265 S_null_listop_in_list_context(pTHX_ OP *o) 11266 { 11267 PERL_ARGS_ASSERT_NULL_LISTOP_IN_LIST_CONTEXT; 11268 11269 /* This is an OP_LIST in list context. That means we 11270 * can ditch the OP_LIST and the OP_PUSHMARK within. */ 11271 11272 op_null(cUNOPo->op_first); /* NULL the pushmark */ 11273 op_null(o); /* NULL the list */ 11274 } 11275 11276 /* A peephole optimizer. We visit the ops in the order they're to execute. 11277 * See the comments at the top of this file for more details about when 11278 * peep() is called */ 11279 11280 void 11281 Perl_rpeep(pTHX_ OP *o) 11282 { 11283 dVAR; 11284 OP* oldop = NULL; 11285 OP* oldoldop = NULL; 11286 OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */ 11287 int defer_base = 0; 11288 int defer_ix = -1; 11289 11290 if (!o || o->op_opt) 11291 return; 11292 ENTER; 11293 SAVEOP(); 11294 SAVEVPTR(PL_curcop); 11295 for (;; o = o->op_next) { 11296 if (o && o->op_opt) 11297 o = NULL; 11298 if (!o) { 11299 while (defer_ix >= 0) { 11300 OP **defer = 11301 defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED]; 11302 CALL_RPEEP(*defer); 11303 S_prune_chain_head(aTHX_ defer); 11304 } 11305 break; 11306 } 11307 11308 /* By default, this op has now been optimised. A couple of cases below 11309 clear this again. */ 11310 o->op_opt = 1; 11311 PL_op = o; 11312 11313 11314 /* The following will have the OP_LIST and OP_PUSHMARK 11315 * patched out later IF the OP_LIST is in list context. 11316 * So in that case, we can set the this OP's op_next 11317 * to skip to after the OP_PUSHMARK: 11318 * a THIS -> b 11319 * d list -> e 11320 * b pushmark -> c 11321 * c whatever -> d 11322 * e whatever 11323 * will eventually become: 11324 * a THIS -> c 11325 * - ex-list -> - 11326 * - ex-pushmark -> - 11327 * c whatever -> e 11328 * e whatever 11329 */ 11330 { 11331 OP *sibling; 11332 OP *other_pushmark; 11333 if (OP_TYPE_IS(o->op_next, OP_PUSHMARK) 11334 && (sibling = o->op_sibling) 11335 && sibling->op_type == OP_LIST 11336 /* This KIDS check is likely superfluous since OP_LIST 11337 * would otherwise be an OP_STUB. */ 11338 && sibling->op_flags & OPf_KIDS 11339 && (sibling->op_flags & OPf_WANT) == OPf_WANT_LIST 11340 && (other_pushmark = cLISTOPx(sibling)->op_first) 11341 /* Pointer equality also effectively checks that it's a 11342 * pushmark. */ 11343 && other_pushmark == o->op_next) 11344 { 11345 o->op_next = other_pushmark->op_next; 11346 null_listop_in_list_context(sibling); 11347 } 11348 } 11349 11350 switch (o->op_type) { 11351 case OP_DBSTATE: 11352 PL_curcop = ((COP*)o); /* for warnings */ 11353 break; 11354 case OP_NEXTSTATE: 11355 PL_curcop = ((COP*)o); /* for warnings */ 11356 11357 /* Optimise a "return ..." at the end of a sub to just be "...". 11358 * This saves 2 ops. Before: 11359 * 1 <;> nextstate(main 1 -e:1) v ->2 11360 * 4 <@> return K ->5 11361 * 2 <0> pushmark s ->3 11362 * - <1> ex-rv2sv sK/1 ->4 11363 * 3 <#> gvsv[*cat] s ->4 11364 * 11365 * After: 11366 * - <@> return K ->- 11367 * - <0> pushmark s ->2 11368 * - <1> ex-rv2sv sK/1 ->- 11369 * 2 <$> gvsv(*cat) s ->3 11370 */ 11371 { 11372 OP *next = o->op_next; 11373 OP *sibling = o->op_sibling; 11374 if ( OP_TYPE_IS(next, OP_PUSHMARK) 11375 && OP_TYPE_IS(sibling, OP_RETURN) 11376 && OP_TYPE_IS(sibling->op_next, OP_LINESEQ) 11377 && OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB) 11378 && cUNOPx(sibling)->op_first == next 11379 && next->op_sibling && next->op_sibling->op_next 11380 && next->op_next 11381 ) { 11382 /* Look through the PUSHMARK's siblings for one that 11383 * points to the RETURN */ 11384 OP *top = next->op_sibling; 11385 while (top && top->op_next) { 11386 if (top->op_next == sibling) { 11387 top->op_next = sibling->op_next; 11388 o->op_next = next->op_next; 11389 break; 11390 } 11391 top = top->op_sibling; 11392 } 11393 } 11394 } 11395 11396 /* Optimise 'my $x; my $y;' into 'my ($x, $y);' 11397 * 11398 * This latter form is then suitable for conversion into padrange 11399 * later on. Convert: 11400 * 11401 * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3 11402 * 11403 * into: 11404 * 11405 * nextstate1 -> listop -> nextstate3 11406 * / \ 11407 * pushmark -> padop1 -> padop2 11408 */ 11409 if (o->op_next && ( 11410 o->op_next->op_type == OP_PADSV 11411 || o->op_next->op_type == OP_PADAV 11412 || o->op_next->op_type == OP_PADHV 11413 ) 11414 && !(o->op_next->op_private & ~OPpLVAL_INTRO) 11415 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE 11416 && o->op_next->op_next->op_next && ( 11417 o->op_next->op_next->op_next->op_type == OP_PADSV 11418 || o->op_next->op_next->op_next->op_type == OP_PADAV 11419 || o->op_next->op_next->op_next->op_type == OP_PADHV 11420 ) 11421 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO) 11422 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE 11423 && (!CopLABEL((COP*)o)) /* Don't mess with labels */ 11424 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */ 11425 ) { 11426 OP *first; 11427 OP *last; 11428 OP *newop; 11429 11430 first = o->op_next; 11431 last = o->op_next->op_next->op_next; 11432 11433 newop = newLISTOP(OP_LIST, 0, first, last); 11434 newop->op_flags |= OPf_PARENS; 11435 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID; 11436 11437 /* Kill nextstate2 between padop1/padop2 */ 11438 op_free(first->op_next); 11439 11440 first->op_next = last; /* padop2 */ 11441 first->op_sibling = last; /* ... */ 11442 o->op_next = cUNOPx(newop)->op_first; /* pushmark */ 11443 o->op_next->op_next = first; /* padop1 */ 11444 o->op_next->op_sibling = first; /* ... */ 11445 newop->op_next = last->op_next; /* nextstate3 */ 11446 newop->op_sibling = last->op_sibling; 11447 last->op_next = newop; /* listop */ 11448 last->op_sibling = NULL; 11449 o->op_sibling = newop; /* ... */ 11450 11451 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID; 11452 11453 /* Ensure pushmark has this flag if padops do */ 11454 if (first->op_flags & OPf_MOD && last->op_flags & OPf_MOD) { 11455 o->op_next->op_flags |= OPf_MOD; 11456 } 11457 11458 break; 11459 } 11460 11461 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen 11462 to carry two labels. For now, take the easier option, and skip 11463 this optimisation if the first NEXTSTATE has a label. */ 11464 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) { 11465 OP *nextop = o->op_next; 11466 while (nextop && nextop->op_type == OP_NULL) 11467 nextop = nextop->op_next; 11468 11469 if (nextop && (nextop->op_type == OP_NEXTSTATE)) { 11470 COP *firstcop = (COP *)o; 11471 COP *secondcop = (COP *)nextop; 11472 /* We want the COP pointed to by o (and anything else) to 11473 become the next COP down the line. */ 11474 cop_free(firstcop); 11475 11476 firstcop->op_next = secondcop->op_next; 11477 11478 /* Now steal all its pointers, and duplicate the other 11479 data. */ 11480 firstcop->cop_line = secondcop->cop_line; 11481 #ifdef USE_ITHREADS 11482 firstcop->cop_stashoff = secondcop->cop_stashoff; 11483 firstcop->cop_file = secondcop->cop_file; 11484 #else 11485 firstcop->cop_stash = secondcop->cop_stash; 11486 firstcop->cop_filegv = secondcop->cop_filegv; 11487 #endif 11488 firstcop->cop_hints = secondcop->cop_hints; 11489 firstcop->cop_seq = secondcop->cop_seq; 11490 firstcop->cop_warnings = secondcop->cop_warnings; 11491 firstcop->cop_hints_hash = secondcop->cop_hints_hash; 11492 11493 #ifdef USE_ITHREADS 11494 secondcop->cop_stashoff = 0; 11495 secondcop->cop_file = NULL; 11496 #else 11497 secondcop->cop_stash = NULL; 11498 secondcop->cop_filegv = NULL; 11499 #endif 11500 secondcop->cop_warnings = NULL; 11501 secondcop->cop_hints_hash = NULL; 11502 11503 /* If we use op_null(), and hence leave an ex-COP, some 11504 warnings are misreported. For example, the compile-time 11505 error in 'use strict; no strict refs;' */ 11506 secondcop->op_type = OP_NULL; 11507 secondcop->op_ppaddr = PL_ppaddr[OP_NULL]; 11508 } 11509 } 11510 break; 11511 11512 case OP_CONCAT: 11513 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) { 11514 if (o->op_next->op_private & OPpTARGET_MY) { 11515 if (o->op_flags & OPf_STACKED) /* chained concats */ 11516 break; /* ignore_optimization */ 11517 else { 11518 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */ 11519 o->op_targ = o->op_next->op_targ; 11520 o->op_next->op_targ = 0; 11521 o->op_private |= OPpTARGET_MY; 11522 } 11523 } 11524 op_null(o->op_next); 11525 } 11526 break; 11527 case OP_STUB: 11528 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) { 11529 break; /* Scalar stub must produce undef. List stub is noop */ 11530 } 11531 goto nothin; 11532 case OP_NULL: 11533 if (o->op_targ == OP_NEXTSTATE 11534 || o->op_targ == OP_DBSTATE) 11535 { 11536 PL_curcop = ((COP*)o); 11537 } 11538 /* XXX: We avoid setting op_seq here to prevent later calls 11539 to rpeep() from mistakenly concluding that optimisation 11540 has already occurred. This doesn't fix the real problem, 11541 though (See 20010220.007). AMS 20010719 */ 11542 /* op_seq functionality is now replaced by op_opt */ 11543 o->op_opt = 0; 11544 /* FALL THROUGH */ 11545 case OP_SCALAR: 11546 case OP_LINESEQ: 11547 case OP_SCOPE: 11548 nothin: 11549 if (oldop) { 11550 oldop->op_next = o->op_next; 11551 o->op_opt = 0; 11552 continue; 11553 } 11554 break; 11555 11556 case OP_PUSHMARK: 11557 11558 /* Convert a series of PAD ops for my vars plus support into a 11559 * single padrange op. Basically 11560 * 11561 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest 11562 * 11563 * becomes, depending on circumstances, one of 11564 * 11565 * padrange ----------------------------------> (list) -> rest 11566 * padrange --------------------------------------------> rest 11567 * 11568 * where all the pad indexes are sequential and of the same type 11569 * (INTRO or not). 11570 * We convert the pushmark into a padrange op, then skip 11571 * any other pad ops, and possibly some trailing ops. 11572 * Note that we don't null() the skipped ops, to make it 11573 * easier for Deparse to undo this optimisation (and none of 11574 * the skipped ops are holding any resourses). It also makes 11575 * it easier for find_uninit_var(), as it can just ignore 11576 * padrange, and examine the original pad ops. 11577 */ 11578 { 11579 OP *p; 11580 OP *followop = NULL; /* the op that will follow the padrange op */ 11581 U8 count = 0; 11582 U8 intro = 0; 11583 PADOFFSET base = 0; /* init only to stop compiler whining */ 11584 U8 gimme = 0; /* init only to stop compiler whining */ 11585 bool defav = 0; /* seen (...) = @_ */ 11586 bool reuse = 0; /* reuse an existing padrange op */ 11587 11588 /* look for a pushmark -> gv[_] -> rv2av */ 11589 11590 { 11591 GV *gv; 11592 OP *rv2av, *q; 11593 p = o->op_next; 11594 if ( p->op_type == OP_GV 11595 && (gv = cGVOPx_gv(p)) 11596 && GvNAMELEN_get(gv) == 1 11597 && *GvNAME_get(gv) == '_' 11598 && GvSTASH(gv) == PL_defstash 11599 && (rv2av = p->op_next) 11600 && rv2av->op_type == OP_RV2AV 11601 && !(rv2av->op_flags & OPf_REF) 11602 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB)) 11603 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST) 11604 && o->op_sibling == rv2av /* these two for Deparse */ 11605 && cUNOPx(rv2av)->op_first == p 11606 ) { 11607 q = rv2av->op_next; 11608 if (q->op_type == OP_NULL) 11609 q = q->op_next; 11610 if (q->op_type == OP_PUSHMARK) { 11611 defav = 1; 11612 p = q; 11613 } 11614 } 11615 } 11616 if (!defav) { 11617 /* To allow Deparse to pessimise this, it needs to be able 11618 * to restore the pushmark's original op_next, which it 11619 * will assume to be the same as op_sibling. */ 11620 if (o->op_next != o->op_sibling) 11621 break; 11622 p = o; 11623 } 11624 11625 /* scan for PAD ops */ 11626 11627 for (p = p->op_next; p; p = p->op_next) { 11628 if (p->op_type == OP_NULL) 11629 continue; 11630 11631 if (( p->op_type != OP_PADSV 11632 && p->op_type != OP_PADAV 11633 && p->op_type != OP_PADHV 11634 ) 11635 /* any private flag other than INTRO? e.g. STATE */ 11636 || (p->op_private & ~OPpLVAL_INTRO) 11637 ) 11638 break; 11639 11640 /* let $a[N] potentially be optimised into AELEMFAST_LEX 11641 * instead */ 11642 if ( p->op_type == OP_PADAV 11643 && p->op_next 11644 && p->op_next->op_type == OP_CONST 11645 && p->op_next->op_next 11646 && p->op_next->op_next->op_type == OP_AELEM 11647 ) 11648 break; 11649 11650 /* for 1st padop, note what type it is and the range 11651 * start; for the others, check that it's the same type 11652 * and that the targs are contiguous */ 11653 if (count == 0) { 11654 intro = (p->op_private & OPpLVAL_INTRO); 11655 base = p->op_targ; 11656 gimme = (p->op_flags & OPf_WANT); 11657 } 11658 else { 11659 if ((p->op_private & OPpLVAL_INTRO) != intro) 11660 break; 11661 /* Note that you'd normally expect targs to be 11662 * contiguous in my($a,$b,$c), but that's not the case 11663 * when external modules start doing things, e.g. 11664 i* Function::Parameters */ 11665 if (p->op_targ != base + count) 11666 break; 11667 assert(p->op_targ == base + count); 11668 /* all the padops should be in the same context */ 11669 if (gimme != (p->op_flags & OPf_WANT)) 11670 break; 11671 } 11672 11673 /* for AV, HV, only when we're not flattening */ 11674 if ( p->op_type != OP_PADSV 11675 && gimme != OPf_WANT_VOID 11676 && !(p->op_flags & OPf_REF) 11677 ) 11678 break; 11679 11680 if (count >= OPpPADRANGE_COUNTMASK) 11681 break; 11682 11683 /* there's a biggest base we can fit into a 11684 * SAVEt_CLEARPADRANGE in pp_padrange */ 11685 if (intro && base > 11686 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))) 11687 break; 11688 11689 /* Success! We've got another valid pad op to optimise away */ 11690 count++; 11691 followop = p->op_next; 11692 } 11693 11694 if (count < 1) 11695 break; 11696 11697 /* pp_padrange in specifically compile-time void context 11698 * skips pushing a mark and lexicals; in all other contexts 11699 * (including unknown till runtime) it pushes a mark and the 11700 * lexicals. We must be very careful then, that the ops we 11701 * optimise away would have exactly the same effect as the 11702 * padrange. 11703 * In particular in void context, we can only optimise to 11704 * a padrange if see see the complete sequence 11705 * pushmark, pad*v, ...., list, nextstate 11706 * which has the net effect of of leaving the stack empty 11707 * (for now we leave the nextstate in the execution chain, for 11708 * its other side-effects). 11709 */ 11710 assert(followop); 11711 if (gimme == OPf_WANT_VOID) { 11712 if (OP_TYPE_IS_OR_WAS(followop, OP_LIST) 11713 && gimme == (followop->op_flags & OPf_WANT) 11714 && ( followop->op_next->op_type == OP_NEXTSTATE 11715 || followop->op_next->op_type == OP_DBSTATE)) 11716 { 11717 followop = followop->op_next; /* skip OP_LIST */ 11718 11719 /* consolidate two successive my(...);'s */ 11720 11721 if ( oldoldop 11722 && oldoldop->op_type == OP_PADRANGE 11723 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID 11724 && (oldoldop->op_private & OPpLVAL_INTRO) == intro 11725 && !(oldoldop->op_flags & OPf_SPECIAL) 11726 ) { 11727 U8 old_count; 11728 assert(oldoldop->op_next == oldop); 11729 assert( oldop->op_type == OP_NEXTSTATE 11730 || oldop->op_type == OP_DBSTATE); 11731 assert(oldop->op_next == o); 11732 11733 old_count 11734 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK); 11735 11736 /* Do not assume pad offsets for $c and $d are con- 11737 tiguous in 11738 my ($a,$b,$c); 11739 my ($d,$e,$f); 11740 */ 11741 if ( oldoldop->op_targ + old_count == base 11742 && old_count < OPpPADRANGE_COUNTMASK - count) { 11743 base = oldoldop->op_targ; 11744 count += old_count; 11745 reuse = 1; 11746 } 11747 } 11748 11749 /* if there's any immediately following singleton 11750 * my var's; then swallow them and the associated 11751 * nextstates; i.e. 11752 * my ($a,$b); my $c; my $d; 11753 * is treated as 11754 * my ($a,$b,$c,$d); 11755 */ 11756 11757 while ( ((p = followop->op_next)) 11758 && ( p->op_type == OP_PADSV 11759 || p->op_type == OP_PADAV 11760 || p->op_type == OP_PADHV) 11761 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID 11762 && (p->op_private & OPpLVAL_INTRO) == intro 11763 && !(p->op_private & ~OPpLVAL_INTRO) 11764 && p->op_next 11765 && ( p->op_next->op_type == OP_NEXTSTATE 11766 || p->op_next->op_type == OP_DBSTATE) 11767 && count < OPpPADRANGE_COUNTMASK 11768 && base + count == p->op_targ 11769 ) { 11770 count++; 11771 followop = p->op_next; 11772 } 11773 } 11774 else 11775 break; 11776 } 11777 11778 if (reuse) { 11779 assert(oldoldop->op_type == OP_PADRANGE); 11780 oldoldop->op_next = followop; 11781 oldoldop->op_private = (intro | count); 11782 o = oldoldop; 11783 oldop = NULL; 11784 oldoldop = NULL; 11785 } 11786 else { 11787 /* Convert the pushmark into a padrange. 11788 * To make Deparse easier, we guarantee that a padrange was 11789 * *always* formerly a pushmark */ 11790 assert(o->op_type == OP_PUSHMARK); 11791 o->op_next = followop; 11792 o->op_type = OP_PADRANGE; 11793 o->op_ppaddr = PL_ppaddr[OP_PADRANGE]; 11794 o->op_targ = base; 11795 /* bit 7: INTRO; bit 6..0: count */ 11796 o->op_private = (intro | count); 11797 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL)) 11798 | gimme | (defav ? OPf_SPECIAL : 0)); 11799 } 11800 break; 11801 } 11802 11803 case OP_PADAV: 11804 case OP_GV: 11805 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) { 11806 OP* const pop = (o->op_type == OP_PADAV) ? 11807 o->op_next : o->op_next->op_next; 11808 IV i; 11809 if (pop && pop->op_type == OP_CONST && 11810 ((PL_op = pop->op_next)) && 11811 pop->op_next->op_type == OP_AELEM && 11812 !(pop->op_next->op_private & 11813 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) && 11814 (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127) 11815 { 11816 GV *gv; 11817 if (cSVOPx(pop)->op_private & OPpCONST_STRICT) 11818 no_bareword_allowed(pop); 11819 if (o->op_type == OP_GV) 11820 op_null(o->op_next); 11821 op_null(pop->op_next); 11822 op_null(pop); 11823 o->op_flags |= pop->op_next->op_flags & OPf_MOD; 11824 o->op_next = pop->op_next->op_next; 11825 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST]; 11826 o->op_private = (U8)i; 11827 if (o->op_type == OP_GV) { 11828 gv = cGVOPo_gv; 11829 GvAVn(gv); 11830 o->op_type = OP_AELEMFAST; 11831 } 11832 else 11833 o->op_type = OP_AELEMFAST_LEX; 11834 } 11835 break; 11836 } 11837 11838 if (o->op_next->op_type == OP_RV2SV) { 11839 if (!(o->op_next->op_private & OPpDEREF)) { 11840 op_null(o->op_next); 11841 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO 11842 | OPpOUR_INTRO); 11843 o->op_next = o->op_next->op_next; 11844 o->op_type = OP_GVSV; 11845 o->op_ppaddr = PL_ppaddr[OP_GVSV]; 11846 } 11847 } 11848 else if (o->op_next->op_type == OP_READLINE 11849 && o->op_next->op_next->op_type == OP_CONCAT 11850 && (o->op_next->op_next->op_flags & OPf_STACKED)) 11851 { 11852 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */ 11853 o->op_type = OP_RCATLINE; 11854 o->op_flags |= OPf_STACKED; 11855 o->op_ppaddr = PL_ppaddr[OP_RCATLINE]; 11856 op_null(o->op_next->op_next); 11857 op_null(o->op_next); 11858 } 11859 11860 break; 11861 11862 { 11863 OP *fop; 11864 OP *sop; 11865 11866 #define HV_OR_SCALARHV(op) \ 11867 ( (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \ 11868 ? (op) \ 11869 : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \ 11870 && ( cUNOPx(op)->op_first->op_type == OP_PADHV \ 11871 || cUNOPx(op)->op_first->op_type == OP_RV2HV) \ 11872 ? cUNOPx(op)->op_first \ 11873 : NULL) 11874 11875 case OP_NOT: 11876 if ((fop = HV_OR_SCALARHV(cUNOP->op_first))) 11877 fop->op_private |= OPpTRUEBOOL; 11878 break; 11879 11880 case OP_AND: 11881 case OP_OR: 11882 case OP_DOR: 11883 fop = cLOGOP->op_first; 11884 sop = fop->op_sibling; 11885 while (cLOGOP->op_other->op_type == OP_NULL) 11886 cLOGOP->op_other = cLOGOP->op_other->op_next; 11887 while (o->op_next && ( o->op_type == o->op_next->op_type 11888 || o->op_next->op_type == OP_NULL)) 11889 o->op_next = o->op_next->op_next; 11890 11891 /* if we're an OR and our next is a AND in void context, we'll 11892 follow it's op_other on short circuit, same for reverse. 11893 We can't do this with OP_DOR since if it's true, its return 11894 value is the underlying value which must be evaluated 11895 by the next op */ 11896 if (o->op_next && 11897 ( 11898 (IS_AND_OP(o) && IS_OR_OP(o->op_next)) 11899 || (IS_OR_OP(o) && IS_AND_OP(o->op_next)) 11900 ) 11901 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID 11902 ) { 11903 o->op_next = ((LOGOP*)o->op_next)->op_other; 11904 } 11905 DEFER(cLOGOP->op_other); 11906 11907 o->op_opt = 1; 11908 fop = HV_OR_SCALARHV(fop); 11909 if (sop) sop = HV_OR_SCALARHV(sop); 11910 if (fop || sop 11911 ){ 11912 OP * nop = o; 11913 OP * lop = o; 11914 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) { 11915 while (nop && nop->op_next) { 11916 switch (nop->op_next->op_type) { 11917 case OP_NOT: 11918 case OP_AND: 11919 case OP_OR: 11920 case OP_DOR: 11921 lop = nop = nop->op_next; 11922 break; 11923 case OP_NULL: 11924 nop = nop->op_next; 11925 break; 11926 default: 11927 nop = NULL; 11928 break; 11929 } 11930 } 11931 } 11932 if (fop) { 11933 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID 11934 || o->op_type == OP_AND ) 11935 fop->op_private |= OPpTRUEBOOL; 11936 else if (!(lop->op_flags & OPf_WANT)) 11937 fop->op_private |= OPpMAYBE_TRUEBOOL; 11938 } 11939 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID 11940 && sop) 11941 sop->op_private |= OPpTRUEBOOL; 11942 } 11943 11944 11945 break; 11946 11947 case OP_COND_EXPR: 11948 if ((fop = HV_OR_SCALARHV(cLOGOP->op_first))) 11949 fop->op_private |= OPpTRUEBOOL; 11950 #undef HV_OR_SCALARHV 11951 /* GERONIMO! */ 11952 } 11953 11954 case OP_MAPWHILE: 11955 case OP_GREPWHILE: 11956 case OP_ANDASSIGN: 11957 case OP_ORASSIGN: 11958 case OP_DORASSIGN: 11959 case OP_RANGE: 11960 case OP_ONCE: 11961 while (cLOGOP->op_other->op_type == OP_NULL) 11962 cLOGOP->op_other = cLOGOP->op_other->op_next; 11963 DEFER(cLOGOP->op_other); 11964 break; 11965 11966 case OP_ENTERLOOP: 11967 case OP_ENTERITER: 11968 while (cLOOP->op_redoop->op_type == OP_NULL) 11969 cLOOP->op_redoop = cLOOP->op_redoop->op_next; 11970 while (cLOOP->op_nextop->op_type == OP_NULL) 11971 cLOOP->op_nextop = cLOOP->op_nextop->op_next; 11972 while (cLOOP->op_lastop->op_type == OP_NULL) 11973 cLOOP->op_lastop = cLOOP->op_lastop->op_next; 11974 /* a while(1) loop doesn't have an op_next that escapes the 11975 * loop, so we have to explicitly follow the op_lastop to 11976 * process the rest of the code */ 11977 DEFER(cLOOP->op_lastop); 11978 break; 11979 11980 case OP_ENTERTRY: 11981 assert(cLOGOPo->op_other->op_type == OP_LEAVETRY); 11982 DEFER(cLOGOPo->op_other); 11983 break; 11984 11985 case OP_SUBST: 11986 assert(!(cPMOP->op_pmflags & PMf_ONCE)); 11987 while (cPMOP->op_pmstashstartu.op_pmreplstart && 11988 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL) 11989 cPMOP->op_pmstashstartu.op_pmreplstart 11990 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next; 11991 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart); 11992 break; 11993 11994 case OP_SORT: { 11995 OP *oright; 11996 11997 if (o->op_flags & OPf_SPECIAL) { 11998 /* first arg is a code block */ 11999 OP * const nullop = cLISTOP->op_first->op_sibling; 12000 OP * kid = cUNOPx(nullop)->op_first; 12001 12002 assert(nullop->op_type == OP_NULL); 12003 assert(kid->op_type == OP_SCOPE 12004 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE)); 12005 /* since OP_SORT doesn't have a handy op_other-style 12006 * field that can point directly to the start of the code 12007 * block, store it in the otherwise-unused op_next field 12008 * of the top-level OP_NULL. This will be quicker at 12009 * run-time, and it will also allow us to remove leading 12010 * OP_NULLs by just messing with op_nexts without 12011 * altering the basic op_first/op_sibling layout. */ 12012 kid = kLISTOP->op_first; 12013 assert( 12014 (kid->op_type == OP_NULL 12015 && ( kid->op_targ == OP_NEXTSTATE 12016 || kid->op_targ == OP_DBSTATE )) 12017 || kid->op_type == OP_STUB 12018 || kid->op_type == OP_ENTER); 12019 nullop->op_next = kLISTOP->op_next; 12020 DEFER(nullop->op_next); 12021 } 12022 12023 /* check that RHS of sort is a single plain array */ 12024 oright = cUNOPo->op_first; 12025 if (!oright || oright->op_type != OP_PUSHMARK) 12026 break; 12027 12028 if (o->op_private & OPpSORT_INPLACE) 12029 break; 12030 12031 /* reverse sort ... can be optimised. */ 12032 if (!cUNOPo->op_sibling) { 12033 /* Nothing follows us on the list. */ 12034 OP * const reverse = o->op_next; 12035 12036 if (reverse->op_type == OP_REVERSE && 12037 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) { 12038 OP * const pushmark = cUNOPx(reverse)->op_first; 12039 if (pushmark && (pushmark->op_type == OP_PUSHMARK) 12040 && (cUNOPx(pushmark)->op_sibling == o)) { 12041 /* reverse -> pushmark -> sort */ 12042 o->op_private |= OPpSORT_REVERSE; 12043 op_null(reverse); 12044 pushmark->op_next = oright->op_next; 12045 op_null(oright); 12046 } 12047 } 12048 } 12049 12050 break; 12051 } 12052 12053 case OP_REVERSE: { 12054 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av; 12055 OP *gvop = NULL; 12056 LISTOP *enter, *exlist; 12057 12058 if (o->op_private & OPpSORT_INPLACE) 12059 break; 12060 12061 enter = (LISTOP *) o->op_next; 12062 if (!enter) 12063 break; 12064 if (enter->op_type == OP_NULL) { 12065 enter = (LISTOP *) enter->op_next; 12066 if (!enter) 12067 break; 12068 } 12069 /* for $a (...) will have OP_GV then OP_RV2GV here. 12070 for (...) just has an OP_GV. */ 12071 if (enter->op_type == OP_GV) { 12072 gvop = (OP *) enter; 12073 enter = (LISTOP *) enter->op_next; 12074 if (!enter) 12075 break; 12076 if (enter->op_type == OP_RV2GV) { 12077 enter = (LISTOP *) enter->op_next; 12078 if (!enter) 12079 break; 12080 } 12081 } 12082 12083 if (enter->op_type != OP_ENTERITER) 12084 break; 12085 12086 iter = enter->op_next; 12087 if (!iter || iter->op_type != OP_ITER) 12088 break; 12089 12090 expushmark = enter->op_first; 12091 if (!expushmark || expushmark->op_type != OP_NULL 12092 || expushmark->op_targ != OP_PUSHMARK) 12093 break; 12094 12095 exlist = (LISTOP *) expushmark->op_sibling; 12096 if (!exlist || exlist->op_type != OP_NULL 12097 || exlist->op_targ != OP_LIST) 12098 break; 12099 12100 if (exlist->op_last != o) { 12101 /* Mmm. Was expecting to point back to this op. */ 12102 break; 12103 } 12104 theirmark = exlist->op_first; 12105 if (!theirmark || theirmark->op_type != OP_PUSHMARK) 12106 break; 12107 12108 if (theirmark->op_sibling != o) { 12109 /* There's something between the mark and the reverse, eg 12110 for (1, reverse (...)) 12111 so no go. */ 12112 break; 12113 } 12114 12115 ourmark = ((LISTOP *)o)->op_first; 12116 if (!ourmark || ourmark->op_type != OP_PUSHMARK) 12117 break; 12118 12119 ourlast = ((LISTOP *)o)->op_last; 12120 if (!ourlast || ourlast->op_next != o) 12121 break; 12122 12123 rv2av = ourmark->op_sibling; 12124 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0 12125 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS) 12126 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) { 12127 /* We're just reversing a single array. */ 12128 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF; 12129 enter->op_flags |= OPf_STACKED; 12130 } 12131 12132 /* We don't have control over who points to theirmark, so sacrifice 12133 ours. */ 12134 theirmark->op_next = ourmark->op_next; 12135 theirmark->op_flags = ourmark->op_flags; 12136 ourlast->op_next = gvop ? gvop : (OP *) enter; 12137 op_null(ourmark); 12138 op_null(o); 12139 enter->op_private |= OPpITER_REVERSED; 12140 iter->op_private |= OPpITER_REVERSED; 12141 12142 break; 12143 } 12144 12145 case OP_QR: 12146 case OP_MATCH: 12147 if (!(cPMOP->op_pmflags & PMf_ONCE)) { 12148 assert (!cPMOP->op_pmstashstartu.op_pmreplstart); 12149 } 12150 break; 12151 12152 case OP_RUNCV: 12153 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)) { 12154 SV *sv; 12155 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef; 12156 else { 12157 sv = newRV((SV *)PL_compcv); 12158 sv_rvweaken(sv); 12159 SvREADONLY_on(sv); 12160 } 12161 o->op_type = OP_CONST; 12162 o->op_ppaddr = PL_ppaddr[OP_CONST]; 12163 o->op_flags |= OPf_SPECIAL; 12164 cSVOPo->op_sv = sv; 12165 } 12166 break; 12167 12168 case OP_SASSIGN: 12169 if (OP_GIMME(o,0) == G_VOID) { 12170 OP *right = cBINOP->op_first; 12171 if (right) { 12172 /* sassign 12173 * RIGHT 12174 * substr 12175 * pushmark 12176 * arg1 12177 * arg2 12178 * ... 12179 * becomes 12180 * 12181 * ex-sassign 12182 * substr 12183 * pushmark 12184 * RIGHT 12185 * arg1 12186 * arg2 12187 * ... 12188 */ 12189 OP *left = right->op_sibling; 12190 if (left->op_type == OP_SUBSTR 12191 && (left->op_private & 7) < 4) { 12192 op_null(o); 12193 cBINOP->op_first = left; 12194 right->op_sibling = 12195 cBINOPx(left)->op_first->op_sibling; 12196 cBINOPx(left)->op_first->op_sibling = right; 12197 left->op_private |= OPpSUBSTR_REPL_FIRST; 12198 left->op_flags = 12199 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID; 12200 } 12201 } 12202 } 12203 break; 12204 12205 case OP_CUSTOM: { 12206 Perl_cpeep_t cpeep = 12207 XopENTRYCUSTOM(o, xop_peep); 12208 if (cpeep) 12209 cpeep(aTHX_ o, oldop); 12210 break; 12211 } 12212 12213 } 12214 /* did we just null the current op? If so, re-process it to handle 12215 * eliding "empty" ops from the chain */ 12216 if (o->op_type == OP_NULL && oldop && oldop->op_next == o) { 12217 o->op_opt = 0; 12218 o = oldop; 12219 } 12220 else { 12221 oldoldop = oldop; 12222 oldop = o; 12223 } 12224 } 12225 LEAVE; 12226 } 12227 12228 void 12229 Perl_peep(pTHX_ OP *o) 12230 { 12231 CALL_RPEEP(o); 12232 } 12233 12234 /* 12235 =head1 Custom Operators 12236 12237 =for apidoc Ao||custom_op_xop 12238 Return the XOP structure for a given custom op. This macro should be 12239 considered internal to OP_NAME and the other access macros: use them instead. 12240 This macro does call a function. Prior 12241 to 5.19.6, this was implemented as a 12242 function. 12243 12244 =cut 12245 */ 12246 12247 XOPRETANY 12248 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field) 12249 { 12250 SV *keysv; 12251 HE *he = NULL; 12252 XOP *xop; 12253 12254 static const XOP xop_null = { 0, 0, 0, 0, 0 }; 12255 12256 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD; 12257 assert(o->op_type == OP_CUSTOM); 12258 12259 /* This is wrong. It assumes a function pointer can be cast to IV, 12260 * which isn't guaranteed, but this is what the old custom OP code 12261 * did. In principle it should be safer to Copy the bytes of the 12262 * pointer into a PV: since the new interface is hidden behind 12263 * functions, this can be changed later if necessary. */ 12264 /* Change custom_op_xop if this ever happens */ 12265 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr))); 12266 12267 if (PL_custom_ops) 12268 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0); 12269 12270 /* assume noone will have just registered a desc */ 12271 if (!he && PL_custom_op_names && 12272 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0)) 12273 ) { 12274 const char *pv; 12275 STRLEN l; 12276 12277 /* XXX does all this need to be shared mem? */ 12278 Newxz(xop, 1, XOP); 12279 pv = SvPV(HeVAL(he), l); 12280 XopENTRY_set(xop, xop_name, savepvn(pv, l)); 12281 if (PL_custom_op_descs && 12282 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0)) 12283 ) { 12284 pv = SvPV(HeVAL(he), l); 12285 XopENTRY_set(xop, xop_desc, savepvn(pv, l)); 12286 } 12287 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop); 12288 } 12289 else { 12290 if (!he) 12291 xop = (XOP *)&xop_null; 12292 else 12293 xop = INT2PTR(XOP *, SvIV(HeVAL(he))); 12294 } 12295 { 12296 XOPRETANY any; 12297 if(field == XOPe_xop_ptr) { 12298 any.xop_ptr = xop; 12299 } else { 12300 const U32 flags = XopFLAGS(xop); 12301 if(flags & field) { 12302 switch(field) { 12303 case XOPe_xop_name: 12304 any.xop_name = xop->xop_name; 12305 break; 12306 case XOPe_xop_desc: 12307 any.xop_desc = xop->xop_desc; 12308 break; 12309 case XOPe_xop_class: 12310 any.xop_class = xop->xop_class; 12311 break; 12312 case XOPe_xop_peep: 12313 any.xop_peep = xop->xop_peep; 12314 break; 12315 default: 12316 NOT_REACHED; 12317 break; 12318 } 12319 } else { 12320 switch(field) { 12321 case XOPe_xop_name: 12322 any.xop_name = XOPd_xop_name; 12323 break; 12324 case XOPe_xop_desc: 12325 any.xop_desc = XOPd_xop_desc; 12326 break; 12327 case XOPe_xop_class: 12328 any.xop_class = XOPd_xop_class; 12329 break; 12330 case XOPe_xop_peep: 12331 any.xop_peep = XOPd_xop_peep; 12332 break; 12333 default: 12334 NOT_REACHED; 12335 break; 12336 } 12337 } 12338 } 12339 return any; 12340 } 12341 } 12342 12343 /* 12344 =for apidoc Ao||custom_op_register 12345 Register a custom op. See L<perlguts/"Custom Operators">. 12346 12347 =cut 12348 */ 12349 12350 void 12351 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop) 12352 { 12353 SV *keysv; 12354 12355 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER; 12356 12357 /* see the comment in custom_op_xop */ 12358 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr))); 12359 12360 if (!PL_custom_ops) 12361 PL_custom_ops = newHV(); 12362 12363 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0)) 12364 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name); 12365 } 12366 12367 /* 12368 =head1 Functions in file op.c 12369 12370 =for apidoc core_prototype 12371 This function assigns the prototype of the named core function to C<sv>, or 12372 to a new mortal SV if C<sv> is NULL. It returns the modified C<sv>, or 12373 NULL if the core function has no prototype. C<code> is a code as returned 12374 by C<keyword()>. It must not be equal to 0. 12375 12376 =cut 12377 */ 12378 12379 SV * 12380 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code, 12381 int * const opnum) 12382 { 12383 int i = 0, n = 0, seen_question = 0, defgv = 0; 12384 I32 oa; 12385 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2) 12386 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */ 12387 bool nullret = FALSE; 12388 12389 PERL_ARGS_ASSERT_CORE_PROTOTYPE; 12390 12391 assert (code); 12392 12393 if (!sv) sv = sv_newmortal(); 12394 12395 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv 12396 12397 switch (code < 0 ? -code : code) { 12398 case KEY_and : case KEY_chop: case KEY_chomp: 12399 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec : 12400 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto : 12401 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le : 12402 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next : 12403 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr : 12404 case KEY_redo : case KEY_require: case KEY_return: case KEY_say : 12405 case KEY_select: case KEY_sort : case KEY_split : case KEY_system: 12406 case KEY_x : case KEY_xor : 12407 if (!opnum) return NULL; nullret = TRUE; goto findopnum; 12408 case KEY_glob: retsetpvs("_;", OP_GLOB); 12409 case KEY_keys: retsetpvs("+", OP_KEYS); 12410 case KEY_values: retsetpvs("+", OP_VALUES); 12411 case KEY_each: retsetpvs("+", OP_EACH); 12412 case KEY_push: retsetpvs("+@", OP_PUSH); 12413 case KEY_unshift: retsetpvs("+@", OP_UNSHIFT); 12414 case KEY_pop: retsetpvs(";+", OP_POP); 12415 case KEY_shift: retsetpvs(";+", OP_SHIFT); 12416 case KEY_pos: retsetpvs(";\\[$*]", OP_POS); 12417 case KEY_splice: 12418 retsetpvs("+;$$@", OP_SPLICE); 12419 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__: 12420 retsetpvs("", 0); 12421 case KEY_evalbytes: 12422 name = "entereval"; break; 12423 case KEY_readpipe: 12424 name = "backtick"; 12425 } 12426 12427 #undef retsetpvs 12428 12429 findopnum: 12430 while (i < MAXO) { /* The slow way. */ 12431 if (strEQ(name, PL_op_name[i]) 12432 || strEQ(name, PL_op_desc[i])) 12433 { 12434 if (nullret) { assert(opnum); *opnum = i; return NULL; } 12435 goto found; 12436 } 12437 i++; 12438 } 12439 return NULL; 12440 found: 12441 defgv = PL_opargs[i] & OA_DEFGV; 12442 oa = PL_opargs[i] >> OASHIFT; 12443 while (oa) { 12444 if (oa & OA_OPTIONAL && !seen_question && ( 12445 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF 12446 )) { 12447 seen_question = 1; 12448 str[n++] = ';'; 12449 } 12450 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF 12451 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF 12452 /* But globs are already references (kinda) */ 12453 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF 12454 ) { 12455 str[n++] = '\\'; 12456 } 12457 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF 12458 && !scalar_mod_type(NULL, i)) { 12459 str[n++] = '['; 12460 str[n++] = '$'; 12461 str[n++] = '@'; 12462 str[n++] = '%'; 12463 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&'; 12464 str[n++] = '*'; 12465 str[n++] = ']'; 12466 } 12467 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)]; 12468 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') { 12469 str[n-1] = '_'; defgv = 0; 12470 } 12471 oa = oa >> 4; 12472 } 12473 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';'; 12474 str[n++] = '\0'; 12475 sv_setpvn(sv, str, n - 1); 12476 if (opnum) *opnum = i; 12477 return sv; 12478 } 12479 12480 OP * 12481 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code, 12482 const int opnum) 12483 { 12484 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv); 12485 OP *o; 12486 12487 PERL_ARGS_ASSERT_CORESUB_OP; 12488 12489 switch(opnum) { 12490 case 0: 12491 return op_append_elem(OP_LINESEQ, 12492 argop, 12493 newSLICEOP(0, 12494 newSVOP(OP_CONST, 0, newSViv(-code % 3)), 12495 newOP(OP_CALLER,0) 12496 ) 12497 ); 12498 case OP_SELECT: /* which represents OP_SSELECT as well */ 12499 if (code) 12500 return newCONDOP( 12501 0, 12502 newBINOP(OP_GT, 0, 12503 newAVREF(newGVOP(OP_GV, 0, PL_defgv)), 12504 newSVOP(OP_CONST, 0, newSVuv(1)) 12505 ), 12506 coresub_op(newSVuv((UV)OP_SSELECT), 0, 12507 OP_SSELECT), 12508 coresub_op(coreargssv, 0, OP_SELECT) 12509 ); 12510 /* FALL THROUGH */ 12511 default: 12512 switch (PL_opargs[opnum] & OA_CLASS_MASK) { 12513 case OA_BASEOP: 12514 return op_append_elem( 12515 OP_LINESEQ, argop, 12516 newOP(opnum, 12517 opnum == OP_WANTARRAY || opnum == OP_RUNCV 12518 ? OPpOFFBYONE << 8 : 0) 12519 ); 12520 case OA_BASEOP_OR_UNOP: 12521 if (opnum == OP_ENTEREVAL) { 12522 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop); 12523 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES; 12524 } 12525 else o = newUNOP(opnum,0,argop); 12526 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE; 12527 else { 12528 onearg: 12529 if (is_handle_constructor(o, 1)) 12530 argop->op_private |= OPpCOREARGS_DEREF1; 12531 if (scalar_mod_type(NULL, opnum)) 12532 argop->op_private |= OPpCOREARGS_SCALARMOD; 12533 } 12534 return o; 12535 default: 12536 o = convert(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop); 12537 if (is_handle_constructor(o, 2)) 12538 argop->op_private |= OPpCOREARGS_DEREF2; 12539 if (opnum == OP_SUBSTR) { 12540 o->op_private |= OPpMAYBE_LVSUB; 12541 return o; 12542 } 12543 else goto onearg; 12544 } 12545 } 12546 } 12547 12548 void 12549 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv, 12550 SV * const *new_const_svp) 12551 { 12552 const char *hvname; 12553 bool is_const = !!CvCONST(old_cv); 12554 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL; 12555 12556 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV; 12557 12558 if (is_const && new_const_svp && old_const_sv == *new_const_svp) 12559 return; 12560 /* They are 2 constant subroutines generated from 12561 the same constant. This probably means that 12562 they are really the "same" proxy subroutine 12563 instantiated in 2 places. Most likely this is 12564 when a constant is exported twice. Don't warn. 12565 */ 12566 if ( 12567 (ckWARN(WARN_REDEFINE) 12568 && !( 12569 CvGV(old_cv) && GvSTASH(CvGV(old_cv)) 12570 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7 12571 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))), 12572 strEQ(hvname, "autouse")) 12573 ) 12574 ) 12575 || (is_const 12576 && ckWARN_d(WARN_REDEFINE) 12577 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp)) 12578 ) 12579 ) 12580 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), 12581 is_const 12582 ? "Constant subroutine %"SVf" redefined" 12583 : "Subroutine %"SVf" redefined", 12584 name); 12585 } 12586 12587 /* 12588 =head1 Hook manipulation 12589 12590 These functions provide convenient and thread-safe means of manipulating 12591 hook variables. 12592 12593 =cut 12594 */ 12595 12596 /* 12597 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p 12598 12599 Puts a C function into the chain of check functions for a specified op 12600 type. This is the preferred way to manipulate the L</PL_check> array. 12601 I<opcode> specifies which type of op is to be affected. I<new_checker> 12602 is a pointer to the C function that is to be added to that opcode's 12603 check chain, and I<old_checker_p> points to the storage location where a 12604 pointer to the next function in the chain will be stored. The value of 12605 I<new_pointer> is written into the L</PL_check> array, while the value 12606 previously stored there is written to I<*old_checker_p>. 12607 12608 The function should be defined like this: 12609 12610 static OP *new_checker(pTHX_ OP *op) { ... } 12611 12612 It is intended to be called in this manner: 12613 12614 new_checker(aTHX_ op) 12615 12616 I<old_checker_p> should be defined like this: 12617 12618 static Perl_check_t old_checker_p; 12619 12620 L</PL_check> is global to an entire process, and a module wishing to 12621 hook op checking may find itself invoked more than once per process, 12622 typically in different threads. To handle that situation, this function 12623 is idempotent. The location I<*old_checker_p> must initially (once 12624 per process) contain a null pointer. A C variable of static duration 12625 (declared at file scope, typically also marked C<static> to give 12626 it internal linkage) will be implicitly initialised appropriately, 12627 if it does not have an explicit initialiser. This function will only 12628 actually modify the check chain if it finds I<*old_checker_p> to be null. 12629 This function is also thread safe on the small scale. It uses appropriate 12630 locking to avoid race conditions in accessing L</PL_check>. 12631 12632 When this function is called, the function referenced by I<new_checker> 12633 must be ready to be called, except for I<*old_checker_p> being unfilled. 12634 In a threading situation, I<new_checker> may be called immediately, 12635 even before this function has returned. I<*old_checker_p> will always 12636 be appropriately set before I<new_checker> is called. If I<new_checker> 12637 decides not to do anything special with an op that it is given (which 12638 is the usual case for most uses of op check hooking), it must chain the 12639 check function referenced by I<*old_checker_p>. 12640 12641 If you want to influence compilation of calls to a specific subroutine, 12642 then use L</cv_set_call_checker> rather than hooking checking of all 12643 C<entersub> ops. 12644 12645 =cut 12646 */ 12647 12648 void 12649 Perl_wrap_op_checker(pTHX_ Optype opcode, 12650 Perl_check_t new_checker, Perl_check_t *old_checker_p) 12651 { 12652 dVAR; 12653 12654 PERL_ARGS_ASSERT_WRAP_OP_CHECKER; 12655 if (*old_checker_p) return; 12656 OP_CHECK_MUTEX_LOCK; 12657 if (!*old_checker_p) { 12658 *old_checker_p = PL_check[opcode]; 12659 PL_check[opcode] = new_checker; 12660 } 12661 OP_CHECK_MUTEX_UNLOCK; 12662 } 12663 12664 #include "XSUB.h" 12665 12666 /* Efficient sub that returns a constant scalar value. */ 12667 static void 12668 const_sv_xsub(pTHX_ CV* cv) 12669 { 12670 dVAR; 12671 dXSARGS; 12672 SV *const sv = MUTABLE_SV(XSANY.any_ptr); 12673 PERL_UNUSED_ARG(items); 12674 if (!sv) { 12675 XSRETURN(0); 12676 } 12677 EXTEND(sp, 1); 12678 ST(0) = sv; 12679 XSRETURN(1); 12680 } 12681 12682 static void 12683 const_av_xsub(pTHX_ CV* cv) 12684 { 12685 dVAR; 12686 dXSARGS; 12687 AV * const av = MUTABLE_AV(XSANY.any_ptr); 12688 SP -= items; 12689 assert(av); 12690 #ifndef DEBUGGING 12691 if (!av) { 12692 XSRETURN(0); 12693 } 12694 #endif 12695 if (SvRMAGICAL(av)) 12696 Perl_croak(aTHX_ "Magical list constants are not supported"); 12697 if (GIMME_V != G_ARRAY) { 12698 EXTEND(SP, 1); 12699 ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1)); 12700 XSRETURN(1); 12701 } 12702 EXTEND(SP, AvFILLp(av)+1); 12703 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *); 12704 XSRETURN(AvFILLp(av)+1); 12705 } 12706 12707 /* 12708 * Local variables: 12709 * c-indentation-style: bsd 12710 * c-basic-offset: 4 12711 * indent-tabs-mode: nil 12712 * End: 12713 * 12714 * ex: set ts=8 sts=4 sw=4 et: 12715 */ 12716