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