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 106 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o) 107 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) CALL_FPTR(PL_opfreehook)(aTHX_ o) 108 109 #if defined(PL_OP_SLAB_ALLOC) 110 111 #ifdef PERL_DEBUG_READONLY_OPS 112 # define PERL_SLAB_SIZE 4096 113 # include <sys/mman.h> 114 #endif 115 116 #ifndef PERL_SLAB_SIZE 117 #define PERL_SLAB_SIZE 2048 118 #endif 119 120 void * 121 Perl_Slab_Alloc(pTHX_ size_t sz) 122 { 123 dVAR; 124 /* 125 * To make incrementing use count easy PL_OpSlab is an I32 * 126 * To make inserting the link to slab PL_OpPtr is I32 ** 127 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments 128 * Add an overhead for pointer to slab and round up as a number of pointers 129 */ 130 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *); 131 if ((PL_OpSpace -= sz) < 0) { 132 #ifdef PERL_DEBUG_READONLY_OPS 133 /* We need to allocate chunk by chunk so that we can control the VM 134 mapping */ 135 PL_OpPtr = (I32**) mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE, 136 MAP_ANON|MAP_PRIVATE, -1, 0); 137 138 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n", 139 (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), 140 PL_OpPtr)); 141 if(PL_OpPtr == MAP_FAILED) { 142 perror("mmap failed"); 143 abort(); 144 } 145 #else 146 147 PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*)); 148 #endif 149 if (!PL_OpPtr) { 150 return NULL; 151 } 152 /* We reserve the 0'th I32 sized chunk as a use count */ 153 PL_OpSlab = (I32 *) PL_OpPtr; 154 /* Reduce size by the use count word, and by the size we need. 155 * Latter is to mimic the '-=' in the if() above 156 */ 157 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz; 158 /* Allocation pointer starts at the top. 159 Theory: because we build leaves before trunk allocating at end 160 means that at run time access is cache friendly upward 161 */ 162 PL_OpPtr += PERL_SLAB_SIZE; 163 164 #ifdef PERL_DEBUG_READONLY_OPS 165 /* We remember this slab. */ 166 /* This implementation isn't efficient, but it is simple. */ 167 PL_slabs = (I32**) realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1)); 168 PL_slabs[PL_slab_count++] = PL_OpSlab; 169 DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab)); 170 #endif 171 } 172 assert( PL_OpSpace >= 0 ); 173 /* Move the allocation pointer down */ 174 PL_OpPtr -= sz; 175 assert( PL_OpPtr > (I32 **) PL_OpSlab ); 176 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */ 177 (*PL_OpSlab)++; /* Increment use count of slab */ 178 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) ); 179 assert( *PL_OpSlab > 0 ); 180 return (void *)(PL_OpPtr + 1); 181 } 182 183 #ifdef PERL_DEBUG_READONLY_OPS 184 void 185 Perl_pending_Slabs_to_ro(pTHX) { 186 /* Turn all the allocated op slabs read only. */ 187 U32 count = PL_slab_count; 188 I32 **const slabs = PL_slabs; 189 190 /* Reset the array of pending OP slabs, as we're about to turn this lot 191 read only. Also, do it ahead of the loop in case the warn triggers, 192 and a warn handler has an eval */ 193 194 PL_slabs = NULL; 195 PL_slab_count = 0; 196 197 /* Force a new slab for any further allocation. */ 198 PL_OpSpace = 0; 199 200 while (count--) { 201 void *const start = slabs[count]; 202 const size_t size = PERL_SLAB_SIZE* sizeof(I32*); 203 if(mprotect(start, size, PROT_READ)) { 204 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", 205 start, (unsigned long) size, errno); 206 } 207 } 208 209 free(slabs); 210 } 211 212 STATIC void 213 S_Slab_to_rw(pTHX_ void *op) 214 { 215 I32 * const * const ptr = (I32 **) op; 216 I32 * const slab = ptr[-1]; 217 218 PERL_ARGS_ASSERT_SLAB_TO_RW; 219 220 assert( ptr-1 > (I32 **) slab ); 221 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) ); 222 assert( *slab > 0 ); 223 if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) { 224 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", 225 slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno); 226 } 227 } 228 229 OP * 230 Perl_op_refcnt_inc(pTHX_ OP *o) 231 { 232 if(o) { 233 Slab_to_rw(o); 234 ++o->op_targ; 235 } 236 return o; 237 238 } 239 240 PADOFFSET 241 Perl_op_refcnt_dec(pTHX_ OP *o) 242 { 243 PERL_ARGS_ASSERT_OP_REFCNT_DEC; 244 Slab_to_rw(o); 245 return --o->op_targ; 246 } 247 #else 248 # define Slab_to_rw(op) 249 #endif 250 251 void 252 Perl_Slab_Free(pTHX_ void *op) 253 { 254 I32 * const * const ptr = (I32 **) op; 255 I32 * const slab = ptr[-1]; 256 PERL_ARGS_ASSERT_SLAB_FREE; 257 assert( ptr-1 > (I32 **) slab ); 258 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) ); 259 assert( *slab > 0 ); 260 Slab_to_rw(op); 261 if (--(*slab) == 0) { 262 # ifdef NETWARE 263 # define PerlMemShared PerlMem 264 # endif 265 266 #ifdef PERL_DEBUG_READONLY_OPS 267 U32 count = PL_slab_count; 268 /* Need to remove this slab from our list of slabs */ 269 if (count) { 270 while (count--) { 271 if (PL_slabs[count] == slab) { 272 dVAR; 273 /* Found it. Move the entry at the end to overwrite it. */ 274 DEBUG_m(PerlIO_printf(Perl_debug_log, 275 "Deallocate %p by moving %p from %lu to %lu\n", 276 PL_OpSlab, 277 PL_slabs[PL_slab_count - 1], 278 PL_slab_count, count)); 279 PL_slabs[count] = PL_slabs[--PL_slab_count]; 280 /* Could realloc smaller at this point, but probably not 281 worth it. */ 282 if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) { 283 perror("munmap failed"); 284 abort(); 285 } 286 break; 287 } 288 } 289 } 290 #else 291 PerlMemShared_free(slab); 292 #endif 293 if (slab == PL_OpSlab) { 294 PL_OpSpace = 0; 295 } 296 } 297 } 298 #endif 299 /* 300 * In the following definition, the ", (OP*)0" is just to make the compiler 301 * think the expression is of the right type: croak actually does a Siglongjmp. 302 */ 303 #define CHECKOP(type,o) \ 304 ((PL_op_mask && PL_op_mask[type]) \ 305 ? ( op_free((OP*)o), \ 306 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \ 307 (OP*)0 ) \ 308 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o)) 309 310 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2) 311 312 STATIC const char* 313 S_gv_ename(pTHX_ GV *gv) 314 { 315 SV* const tmpsv = sv_newmortal(); 316 317 PERL_ARGS_ASSERT_GV_ENAME; 318 319 gv_efullname3(tmpsv, gv, NULL); 320 return SvPV_nolen_const(tmpsv); 321 } 322 323 STATIC OP * 324 S_no_fh_allowed(pTHX_ OP *o) 325 { 326 PERL_ARGS_ASSERT_NO_FH_ALLOWED; 327 328 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function", 329 OP_DESC(o))); 330 return o; 331 } 332 333 STATIC OP * 334 S_too_few_arguments(pTHX_ OP *o, const char *name) 335 { 336 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS; 337 338 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name)); 339 return o; 340 } 341 342 STATIC OP * 343 S_too_many_arguments(pTHX_ OP *o, const char *name) 344 { 345 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS; 346 347 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name)); 348 return o; 349 } 350 351 STATIC void 352 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid) 353 { 354 PERL_ARGS_ASSERT_BAD_TYPE; 355 356 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)", 357 (int)n, name, t, OP_DESC(kid))); 358 } 359 360 STATIC void 361 S_no_bareword_allowed(pTHX_ const OP *o) 362 { 363 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED; 364 365 if (PL_madskills) 366 return; /* various ok barewords are hidden in extra OP_NULL */ 367 qerror(Perl_mess(aTHX_ 368 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use", 369 SVfARG(cSVOPo_sv))); 370 } 371 372 /* "register" allocation */ 373 374 PADOFFSET 375 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags) 376 { 377 dVAR; 378 PADOFFSET off; 379 const bool is_our = (PL_parser->in_my == KEY_our); 380 381 PERL_ARGS_ASSERT_ALLOCMY; 382 383 if (flags) 384 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf, 385 (UV)flags); 386 387 /* Until we're using the length for real, cross check that we're being 388 told the truth. */ 389 assert(strlen(name) == len); 390 391 /* complain about "my $<special_var>" etc etc */ 392 if (len && 393 !(is_our || 394 isALPHA(name[1]) || 395 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) || 396 (name[1] == '_' && (*name == '$' || len > 2)))) 397 { 398 /* name[2] is true if strlen(name) > 2 */ 399 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) { 400 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"", 401 name[0], toCTRL(name[1]), (int)(len - 2), name + 2, 402 PL_parser->in_my == KEY_state ? "state" : "my")); 403 } else { 404 yyerror(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name, 405 PL_parser->in_my == KEY_state ? "state" : "my")); 406 } 407 } 408 409 /* allocate a spare slot and store the name in that slot */ 410 411 off = pad_add_name(name, len, 412 is_our ? padadd_OUR : 413 PL_parser->in_my == KEY_state ? padadd_STATE : 0, 414 PL_parser->in_my_stash, 415 (is_our 416 /* $_ is always in main::, even with our */ 417 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash) 418 : NULL 419 ) 420 ); 421 /* anon sub prototypes contains state vars should always be cloned, 422 * otherwise the state var would be shared between anon subs */ 423 424 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv)) 425 CvCLONE_on(PL_compcv); 426 427 return off; 428 } 429 430 /* free the body of an op without examining its contents. 431 * Always use this rather than FreeOp directly */ 432 433 static void 434 S_op_destroy(pTHX_ OP *o) 435 { 436 if (o->op_latefree) { 437 o->op_latefreed = 1; 438 return; 439 } 440 FreeOp(o); 441 } 442 443 #ifdef USE_ITHREADS 444 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b) 445 #else 446 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a) 447 #endif 448 449 /* Destructor */ 450 451 void 452 Perl_op_free(pTHX_ OP *o) 453 { 454 dVAR; 455 OPCODE type; 456 457 if (!o) 458 return; 459 if (o->op_latefreed) { 460 if (o->op_latefree) 461 return; 462 goto do_free; 463 } 464 465 type = o->op_type; 466 if (o->op_private & OPpREFCOUNTED) { 467 switch (type) { 468 case OP_LEAVESUB: 469 case OP_LEAVESUBLV: 470 case OP_LEAVEEVAL: 471 case OP_LEAVE: 472 case OP_SCOPE: 473 case OP_LEAVEWRITE: 474 { 475 PADOFFSET refcnt; 476 OP_REFCNT_LOCK; 477 refcnt = OpREFCNT_dec(o); 478 OP_REFCNT_UNLOCK; 479 if (refcnt) { 480 /* Need to find and remove any pattern match ops from the list 481 we maintain for reset(). */ 482 find_and_forget_pmops(o); 483 return; 484 } 485 } 486 break; 487 default: 488 break; 489 } 490 } 491 492 /* Call the op_free hook if it has been set. Do it now so that it's called 493 * at the right time for refcounted ops, but still before all of the kids 494 * are freed. */ 495 CALL_OPFREEHOOK(o); 496 497 if (o->op_flags & OPf_KIDS) { 498 register OP *kid, *nextkid; 499 for (kid = cUNOPo->op_first; kid; kid = nextkid) { 500 nextkid = kid->op_sibling; /* Get before next freeing kid */ 501 op_free(kid); 502 } 503 } 504 505 #ifdef PERL_DEBUG_READONLY_OPS 506 Slab_to_rw(o); 507 #endif 508 509 /* COP* is not cleared by op_clear() so that we may track line 510 * numbers etc even after null() */ 511 if (type == OP_NEXTSTATE || type == OP_DBSTATE 512 || (type == OP_NULL /* the COP might have been null'ed */ 513 && ((OPCODE)o->op_targ == OP_NEXTSTATE 514 || (OPCODE)o->op_targ == OP_DBSTATE))) { 515 cop_free((COP*)o); 516 } 517 518 if (type == OP_NULL) 519 type = (OPCODE)o->op_targ; 520 521 op_clear(o); 522 if (o->op_latefree) { 523 o->op_latefreed = 1; 524 return; 525 } 526 do_free: 527 FreeOp(o); 528 #ifdef DEBUG_LEAKING_SCALARS 529 if (PL_op == o) 530 PL_op = NULL; 531 #endif 532 } 533 534 void 535 Perl_op_clear(pTHX_ OP *o) 536 { 537 538 dVAR; 539 540 PERL_ARGS_ASSERT_OP_CLEAR; 541 542 #ifdef PERL_MAD 543 /* if (o->op_madprop && o->op_madprop->mad_next) 544 abort(); */ 545 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with 546 "modification of a read only value" for a reason I can't fathom why. 547 It's the "" stringification of $_, where $_ was set to '' in a foreach 548 loop, but it defies simplification into a small test case. 549 However, commenting them out has caused ext/List/Util/t/weak.t to fail 550 the last test. */ 551 /* 552 mad_free(o->op_madprop); 553 o->op_madprop = 0; 554 */ 555 #endif 556 557 retry: 558 switch (o->op_type) { 559 case OP_NULL: /* Was holding old type, if any. */ 560 if (PL_madskills && o->op_targ != OP_NULL) { 561 o->op_type = (Optype)o->op_targ; 562 o->op_targ = 0; 563 goto retry; 564 } 565 case OP_ENTERTRY: 566 case OP_ENTEREVAL: /* Was holding hints. */ 567 o->op_targ = 0; 568 break; 569 default: 570 if (!(o->op_flags & OPf_REF) 571 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst))) 572 break; 573 /* FALL THROUGH */ 574 case OP_GVSV: 575 case OP_GV: 576 case OP_AELEMFAST: 577 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) { 578 /* not an OP_PADAV replacement */ 579 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV) 580 #ifdef USE_ITHREADS 581 && PL_curpad 582 #endif 583 ? cGVOPo_gv : NULL; 584 /* It's possible during global destruction that the GV is freed 585 before the optree. Whilst the SvREFCNT_inc is happy to bump from 586 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0 587 will trigger an assertion failure, because the entry to sv_clear 588 checks that the scalar is not already freed. A check of for 589 !SvIS_FREED(gv) turns out to be invalid, because during global 590 destruction the reference count can be forced down to zero 591 (with SVf_BREAK set). In which case raising to 1 and then 592 dropping to 0 triggers cleanup before it should happen. I 593 *think* that this might actually be a general, systematic, 594 weakness of the whole idea of SVf_BREAK, in that code *is* 595 allowed to raise and lower references during global destruction, 596 so any *valid* code that happens to do this during global 597 destruction might well trigger premature cleanup. */ 598 bool still_valid = gv && SvREFCNT(gv); 599 600 if (still_valid) 601 SvREFCNT_inc_simple_void(gv); 602 #ifdef USE_ITHREADS 603 if (cPADOPo->op_padix > 0) { 604 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references 605 * may still exist on the pad */ 606 pad_swipe(cPADOPo->op_padix, TRUE); 607 cPADOPo->op_padix = 0; 608 } 609 #else 610 SvREFCNT_dec(cSVOPo->op_sv); 611 cSVOPo->op_sv = NULL; 612 #endif 613 if (still_valid) { 614 int try_downgrade = SvREFCNT(gv) == 2; 615 SvREFCNT_dec(gv); 616 if (try_downgrade) 617 gv_try_downgrade(gv); 618 } 619 } 620 break; 621 case OP_METHOD_NAMED: 622 case OP_CONST: 623 case OP_HINTSEVAL: 624 SvREFCNT_dec(cSVOPo->op_sv); 625 cSVOPo->op_sv = NULL; 626 #ifdef USE_ITHREADS 627 /** Bug #15654 628 Even if op_clear does a pad_free for the target of the op, 629 pad_free doesn't actually remove the sv that exists in the pad; 630 instead it lives on. This results in that it could be reused as 631 a target later on when the pad was reallocated. 632 **/ 633 if(o->op_targ) { 634 pad_swipe(o->op_targ,1); 635 o->op_targ = 0; 636 } 637 #endif 638 break; 639 case OP_GOTO: 640 case OP_NEXT: 641 case OP_LAST: 642 case OP_REDO: 643 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS)) 644 break; 645 /* FALL THROUGH */ 646 case OP_TRANS: 647 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) { 648 #ifdef USE_ITHREADS 649 if (cPADOPo->op_padix > 0) { 650 pad_swipe(cPADOPo->op_padix, TRUE); 651 cPADOPo->op_padix = 0; 652 } 653 #else 654 SvREFCNT_dec(cSVOPo->op_sv); 655 cSVOPo->op_sv = NULL; 656 #endif 657 } 658 else { 659 PerlMemShared_free(cPVOPo->op_pv); 660 cPVOPo->op_pv = NULL; 661 } 662 break; 663 case OP_SUBST: 664 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot); 665 goto clear_pmop; 666 case OP_PUSHRE: 667 #ifdef USE_ITHREADS 668 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) { 669 /* No GvIN_PAD_off here, because other references may still 670 * exist on the pad */ 671 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE); 672 } 673 #else 674 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv)); 675 #endif 676 /* FALL THROUGH */ 677 case OP_MATCH: 678 case OP_QR: 679 clear_pmop: 680 forget_pmop(cPMOPo, 1); 681 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL; 682 /* we use the same protection as the "SAFE" version of the PM_ macros 683 * here since sv_clean_all might release some PMOPs 684 * after PL_regex_padav has been cleared 685 * and the clearing of PL_regex_padav needs to 686 * happen before sv_clean_all 687 */ 688 #ifdef USE_ITHREADS 689 if(PL_regex_pad) { /* We could be in destruction */ 690 const IV offset = (cPMOPo)->op_pmoffset; 691 ReREFCNT_dec(PM_GETRE(cPMOPo)); 692 PL_regex_pad[offset] = &PL_sv_undef; 693 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset, 694 sizeof(offset)); 695 } 696 #else 697 ReREFCNT_dec(PM_GETRE(cPMOPo)); 698 PM_SETRE(cPMOPo, NULL); 699 #endif 700 701 break; 702 } 703 704 if (o->op_targ > 0) { 705 pad_free(o->op_targ); 706 o->op_targ = 0; 707 } 708 } 709 710 STATIC void 711 S_cop_free(pTHX_ COP* cop) 712 { 713 PERL_ARGS_ASSERT_COP_FREE; 714 715 CopFILE_free(cop); 716 CopSTASH_free(cop); 717 if (! specialWARN(cop->cop_warnings)) 718 PerlMemShared_free(cop->cop_warnings); 719 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash); 720 } 721 722 STATIC void 723 S_forget_pmop(pTHX_ PMOP *const o 724 #ifdef USE_ITHREADS 725 , U32 flags 726 #endif 727 ) 728 { 729 HV * const pmstash = PmopSTASH(o); 730 731 PERL_ARGS_ASSERT_FORGET_PMOP; 732 733 if (pmstash && !SvIS_FREED(pmstash)) { 734 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab); 735 if (mg) { 736 PMOP **const array = (PMOP**) mg->mg_ptr; 737 U32 count = mg->mg_len / sizeof(PMOP**); 738 U32 i = count; 739 740 while (i--) { 741 if (array[i] == o) { 742 /* Found it. Move the entry at the end to overwrite it. */ 743 array[i] = array[--count]; 744 mg->mg_len = count * sizeof(PMOP**); 745 /* Could realloc smaller at this point always, but probably 746 not worth it. Probably worth free()ing if we're the 747 last. */ 748 if(!count) { 749 Safefree(mg->mg_ptr); 750 mg->mg_ptr = NULL; 751 } 752 break; 753 } 754 } 755 } 756 } 757 if (PL_curpm == o) 758 PL_curpm = NULL; 759 #ifdef USE_ITHREADS 760 if (flags) 761 PmopSTASH_free(o); 762 #endif 763 } 764 765 STATIC void 766 S_find_and_forget_pmops(pTHX_ OP *o) 767 { 768 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS; 769 770 if (o->op_flags & OPf_KIDS) { 771 OP *kid = cUNOPo->op_first; 772 while (kid) { 773 switch (kid->op_type) { 774 case OP_SUBST: 775 case OP_PUSHRE: 776 case OP_MATCH: 777 case OP_QR: 778 forget_pmop((PMOP*)kid, 0); 779 } 780 find_and_forget_pmops(kid); 781 kid = kid->op_sibling; 782 } 783 } 784 } 785 786 void 787 Perl_op_null(pTHX_ OP *o) 788 { 789 dVAR; 790 791 PERL_ARGS_ASSERT_OP_NULL; 792 793 if (o->op_type == OP_NULL) 794 return; 795 if (!PL_madskills) 796 op_clear(o); 797 o->op_targ = o->op_type; 798 o->op_type = OP_NULL; 799 o->op_ppaddr = PL_ppaddr[OP_NULL]; 800 } 801 802 void 803 Perl_op_refcnt_lock(pTHX) 804 { 805 dVAR; 806 PERL_UNUSED_CONTEXT; 807 OP_REFCNT_LOCK; 808 } 809 810 void 811 Perl_op_refcnt_unlock(pTHX) 812 { 813 dVAR; 814 PERL_UNUSED_CONTEXT; 815 OP_REFCNT_UNLOCK; 816 } 817 818 /* Contextualizers */ 819 820 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o)) 821 822 static OP * 823 S_linklist(pTHX_ OP *o) 824 { 825 OP *first; 826 827 PERL_ARGS_ASSERT_LINKLIST; 828 829 if (o->op_next) 830 return o->op_next; 831 832 /* establish postfix order */ 833 first = cUNOPo->op_first; 834 if (first) { 835 register OP *kid; 836 o->op_next = LINKLIST(first); 837 kid = first; 838 for (;;) { 839 if (kid->op_sibling) { 840 kid->op_next = LINKLIST(kid->op_sibling); 841 kid = kid->op_sibling; 842 } else { 843 kid->op_next = o; 844 break; 845 } 846 } 847 } 848 else 849 o->op_next = o; 850 851 return o->op_next; 852 } 853 854 static OP * 855 S_scalarkids(pTHX_ OP *o) 856 { 857 if (o && o->op_flags & OPf_KIDS) { 858 OP *kid; 859 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 860 scalar(kid); 861 } 862 return o; 863 } 864 865 STATIC OP * 866 S_scalarboolean(pTHX_ OP *o) 867 { 868 dVAR; 869 870 PERL_ARGS_ASSERT_SCALARBOOLEAN; 871 872 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) { 873 if (ckWARN(WARN_SYNTAX)) { 874 const line_t oldline = CopLINE(PL_curcop); 875 876 if (PL_parser && PL_parser->copline != NOLINE) 877 CopLINE_set(PL_curcop, PL_parser->copline); 878 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be =="); 879 CopLINE_set(PL_curcop, oldline); 880 } 881 } 882 return scalar(o); 883 } 884 885 OP * 886 Perl_scalar(pTHX_ OP *o) 887 { 888 dVAR; 889 OP *kid; 890 891 /* assumes no premature commitment */ 892 if (!o || (PL_parser && PL_parser->error_count) 893 || (o->op_flags & OPf_WANT) 894 || o->op_type == OP_RETURN) 895 { 896 return o; 897 } 898 899 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR; 900 901 switch (o->op_type) { 902 case OP_REPEAT: 903 scalar(cBINOPo->op_first); 904 break; 905 case OP_OR: 906 case OP_AND: 907 case OP_COND_EXPR: 908 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) 909 scalar(kid); 910 break; 911 /* FALL THROUGH */ 912 case OP_SPLIT: 913 case OP_MATCH: 914 case OP_QR: 915 case OP_SUBST: 916 case OP_NULL: 917 default: 918 if (o->op_flags & OPf_KIDS) { 919 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) 920 scalar(kid); 921 } 922 break; 923 case OP_LEAVE: 924 case OP_LEAVETRY: 925 kid = cLISTOPo->op_first; 926 scalar(kid); 927 while ((kid = kid->op_sibling)) { 928 if (kid->op_sibling) 929 scalarvoid(kid); 930 else 931 scalar(kid); 932 } 933 PL_curcop = &PL_compiling; 934 break; 935 case OP_SCOPE: 936 case OP_LINESEQ: 937 case OP_LIST: 938 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { 939 if (kid->op_sibling) 940 scalarvoid(kid); 941 else 942 scalar(kid); 943 } 944 PL_curcop = &PL_compiling; 945 break; 946 case OP_SORT: 947 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context"); 948 break; 949 } 950 return o; 951 } 952 953 OP * 954 Perl_scalarvoid(pTHX_ OP *o) 955 { 956 dVAR; 957 OP *kid; 958 const char* useless = NULL; 959 SV* sv; 960 U8 want; 961 962 PERL_ARGS_ASSERT_SCALARVOID; 963 964 /* trailing mad null ops don't count as "there" for void processing */ 965 if (PL_madskills && 966 o->op_type != OP_NULL && 967 o->op_sibling && 968 o->op_sibling->op_type == OP_NULL) 969 { 970 OP *sib; 971 for (sib = o->op_sibling; 972 sib && sib->op_type == OP_NULL; 973 sib = sib->op_sibling) ; 974 975 if (!sib) 976 return o; 977 } 978 979 if (o->op_type == OP_NEXTSTATE 980 || o->op_type == OP_DBSTATE 981 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE 982 || o->op_targ == OP_DBSTATE))) 983 PL_curcop = (COP*)o; /* for warning below */ 984 985 /* assumes no premature commitment */ 986 want = o->op_flags & OPf_WANT; 987 if ((want && want != OPf_WANT_SCALAR) 988 || (PL_parser && PL_parser->error_count) 989 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE) 990 { 991 return o; 992 } 993 994 if ((o->op_private & OPpTARGET_MY) 995 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */ 996 { 997 return scalar(o); /* As if inside SASSIGN */ 998 } 999 1000 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID; 1001 1002 switch (o->op_type) { 1003 default: 1004 if (!(PL_opargs[o->op_type] & OA_FOLDCONST)) 1005 break; 1006 /* FALL THROUGH */ 1007 case OP_REPEAT: 1008 if (o->op_flags & OPf_STACKED) 1009 break; 1010 goto func_ops; 1011 case OP_SUBSTR: 1012 if (o->op_private == 4) 1013 break; 1014 /* FALL THROUGH */ 1015 case OP_GVSV: 1016 case OP_WANTARRAY: 1017 case OP_GV: 1018 case OP_SMARTMATCH: 1019 case OP_PADSV: 1020 case OP_PADAV: 1021 case OP_PADHV: 1022 case OP_PADANY: 1023 case OP_AV2ARYLEN: 1024 case OP_REF: 1025 case OP_REFGEN: 1026 case OP_SREFGEN: 1027 case OP_DEFINED: 1028 case OP_HEX: 1029 case OP_OCT: 1030 case OP_LENGTH: 1031 case OP_VEC: 1032 case OP_INDEX: 1033 case OP_RINDEX: 1034 case OP_SPRINTF: 1035 case OP_AELEM: 1036 case OP_AELEMFAST: 1037 case OP_ASLICE: 1038 case OP_HELEM: 1039 case OP_HSLICE: 1040 case OP_UNPACK: 1041 case OP_PACK: 1042 case OP_JOIN: 1043 case OP_LSLICE: 1044 case OP_ANONLIST: 1045 case OP_ANONHASH: 1046 case OP_SORT: 1047 case OP_REVERSE: 1048 case OP_RANGE: 1049 case OP_FLIP: 1050 case OP_FLOP: 1051 case OP_CALLER: 1052 case OP_FILENO: 1053 case OP_EOF: 1054 case OP_TELL: 1055 case OP_GETSOCKNAME: 1056 case OP_GETPEERNAME: 1057 case OP_READLINK: 1058 case OP_TELLDIR: 1059 case OP_GETPPID: 1060 case OP_GETPGRP: 1061 case OP_GETPRIORITY: 1062 case OP_TIME: 1063 case OP_TMS: 1064 case OP_LOCALTIME: 1065 case OP_GMTIME: 1066 case OP_GHBYNAME: 1067 case OP_GHBYADDR: 1068 case OP_GHOSTENT: 1069 case OP_GNBYNAME: 1070 case OP_GNBYADDR: 1071 case OP_GNETENT: 1072 case OP_GPBYNAME: 1073 case OP_GPBYNUMBER: 1074 case OP_GPROTOENT: 1075 case OP_GSBYNAME: 1076 case OP_GSBYPORT: 1077 case OP_GSERVENT: 1078 case OP_GPWNAM: 1079 case OP_GPWUID: 1080 case OP_GGRNAM: 1081 case OP_GGRGID: 1082 case OP_GETLOGIN: 1083 case OP_PROTOTYPE: 1084 func_ops: 1085 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO))) 1086 /* Otherwise it's "Useless use of grep iterator" */ 1087 useless = OP_DESC(o); 1088 break; 1089 1090 case OP_SPLIT: 1091 kid = cLISTOPo->op_first; 1092 if (kid && kid->op_type == OP_PUSHRE 1093 #ifdef USE_ITHREADS 1094 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff) 1095 #else 1096 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv) 1097 #endif 1098 useless = OP_DESC(o); 1099 break; 1100 1101 case OP_NOT: 1102 kid = cUNOPo->op_first; 1103 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST && 1104 kid->op_type != OP_TRANS) { 1105 goto func_ops; 1106 } 1107 useless = "negative pattern binding (!~)"; 1108 break; 1109 1110 case OP_RV2GV: 1111 case OP_RV2SV: 1112 case OP_RV2AV: 1113 case OP_RV2HV: 1114 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) && 1115 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE)) 1116 useless = "a variable"; 1117 break; 1118 1119 case OP_CONST: 1120 sv = cSVOPo_sv; 1121 if (cSVOPo->op_private & OPpCONST_STRICT) 1122 no_bareword_allowed(o); 1123 else { 1124 if (ckWARN(WARN_VOID)) { 1125 if (SvOK(sv)) { 1126 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_ 1127 "a constant (%"SVf")", sv)); 1128 useless = SvPV_nolen(msv); 1129 } 1130 else 1131 useless = "a constant (undef)"; 1132 if (o->op_private & OPpCONST_ARYBASE) 1133 useless = NULL; 1134 /* don't warn on optimised away booleans, eg 1135 * use constant Foo, 5; Foo || print; */ 1136 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT) 1137 useless = NULL; 1138 /* the constants 0 and 1 are permitted as they are 1139 conventionally used as dummies in constructs like 1140 1 while some_condition_with_side_effects; */ 1141 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0)) 1142 useless = NULL; 1143 else if (SvPOK(sv)) { 1144 /* perl4's way of mixing documentation and code 1145 (before the invention of POD) was based on a 1146 trick to mix nroff and perl code. The trick was 1147 built upon these three nroff macros being used in 1148 void context. The pink camel has the details in 1149 the script wrapman near page 319. */ 1150 const char * const maybe_macro = SvPVX_const(sv); 1151 if (strnEQ(maybe_macro, "di", 2) || 1152 strnEQ(maybe_macro, "ds", 2) || 1153 strnEQ(maybe_macro, "ig", 2)) 1154 useless = NULL; 1155 } 1156 } 1157 } 1158 op_null(o); /* don't execute or even remember it */ 1159 break; 1160 1161 case OP_POSTINC: 1162 o->op_type = OP_PREINC; /* pre-increment is faster */ 1163 o->op_ppaddr = PL_ppaddr[OP_PREINC]; 1164 break; 1165 1166 case OP_POSTDEC: 1167 o->op_type = OP_PREDEC; /* pre-decrement is faster */ 1168 o->op_ppaddr = PL_ppaddr[OP_PREDEC]; 1169 break; 1170 1171 case OP_I_POSTINC: 1172 o->op_type = OP_I_PREINC; /* pre-increment is faster */ 1173 o->op_ppaddr = PL_ppaddr[OP_I_PREINC]; 1174 break; 1175 1176 case OP_I_POSTDEC: 1177 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */ 1178 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC]; 1179 break; 1180 1181 case OP_OR: 1182 case OP_AND: 1183 kid = cLOGOPo->op_first; 1184 if (kid->op_type == OP_NOT 1185 && (kid->op_flags & OPf_KIDS) 1186 && !PL_madskills) { 1187 if (o->op_type == OP_AND) { 1188 o->op_type = OP_OR; 1189 o->op_ppaddr = PL_ppaddr[OP_OR]; 1190 } else { 1191 o->op_type = OP_AND; 1192 o->op_ppaddr = PL_ppaddr[OP_AND]; 1193 } 1194 op_null(kid); 1195 } 1196 1197 case OP_DOR: 1198 case OP_COND_EXPR: 1199 case OP_ENTERGIVEN: 1200 case OP_ENTERWHEN: 1201 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) 1202 scalarvoid(kid); 1203 break; 1204 1205 case OP_NULL: 1206 if (o->op_flags & OPf_STACKED) 1207 break; 1208 /* FALL THROUGH */ 1209 case OP_NEXTSTATE: 1210 case OP_DBSTATE: 1211 case OP_ENTERTRY: 1212 case OP_ENTER: 1213 if (!(o->op_flags & OPf_KIDS)) 1214 break; 1215 /* FALL THROUGH */ 1216 case OP_SCOPE: 1217 case OP_LEAVE: 1218 case OP_LEAVETRY: 1219 case OP_LEAVELOOP: 1220 case OP_LINESEQ: 1221 case OP_LIST: 1222 case OP_LEAVEGIVEN: 1223 case OP_LEAVEWHEN: 1224 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 1225 scalarvoid(kid); 1226 break; 1227 case OP_ENTEREVAL: 1228 scalarkids(o); 1229 break; 1230 case OP_SCALAR: 1231 return scalar(o); 1232 } 1233 if (useless) 1234 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless); 1235 return o; 1236 } 1237 1238 static OP * 1239 S_listkids(pTHX_ OP *o) 1240 { 1241 if (o && o->op_flags & OPf_KIDS) { 1242 OP *kid; 1243 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 1244 list(kid); 1245 } 1246 return o; 1247 } 1248 1249 OP * 1250 Perl_list(pTHX_ OP *o) 1251 { 1252 dVAR; 1253 OP *kid; 1254 1255 /* assumes no premature commitment */ 1256 if (!o || (o->op_flags & OPf_WANT) 1257 || (PL_parser && PL_parser->error_count) 1258 || o->op_type == OP_RETURN) 1259 { 1260 return o; 1261 } 1262 1263 if ((o->op_private & OPpTARGET_MY) 1264 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */ 1265 { 1266 return o; /* As if inside SASSIGN */ 1267 } 1268 1269 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST; 1270 1271 switch (o->op_type) { 1272 case OP_FLOP: 1273 case OP_REPEAT: 1274 list(cBINOPo->op_first); 1275 break; 1276 case OP_OR: 1277 case OP_AND: 1278 case OP_COND_EXPR: 1279 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) 1280 list(kid); 1281 break; 1282 default: 1283 case OP_MATCH: 1284 case OP_QR: 1285 case OP_SUBST: 1286 case OP_NULL: 1287 if (!(o->op_flags & OPf_KIDS)) 1288 break; 1289 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) { 1290 list(cBINOPo->op_first); 1291 return gen_constant_list(o); 1292 } 1293 case OP_LIST: 1294 listkids(o); 1295 break; 1296 case OP_LEAVE: 1297 case OP_LEAVETRY: 1298 kid = cLISTOPo->op_first; 1299 list(kid); 1300 while ((kid = kid->op_sibling)) { 1301 if (kid->op_sibling) 1302 scalarvoid(kid); 1303 else 1304 list(kid); 1305 } 1306 PL_curcop = &PL_compiling; 1307 break; 1308 case OP_SCOPE: 1309 case OP_LINESEQ: 1310 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { 1311 if (kid->op_sibling) 1312 scalarvoid(kid); 1313 else 1314 list(kid); 1315 } 1316 PL_curcop = &PL_compiling; 1317 break; 1318 } 1319 return o; 1320 } 1321 1322 static OP * 1323 S_scalarseq(pTHX_ OP *o) 1324 { 1325 dVAR; 1326 if (o) { 1327 const OPCODE type = o->op_type; 1328 1329 if (type == OP_LINESEQ || type == OP_SCOPE || 1330 type == OP_LEAVE || type == OP_LEAVETRY) 1331 { 1332 OP *kid; 1333 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { 1334 if (kid->op_sibling) { 1335 scalarvoid(kid); 1336 } 1337 } 1338 PL_curcop = &PL_compiling; 1339 } 1340 o->op_flags &= ~OPf_PARENS; 1341 if (PL_hints & HINT_BLOCK_SCOPE) 1342 o->op_flags |= OPf_PARENS; 1343 } 1344 else 1345 o = newOP(OP_STUB, 0); 1346 return o; 1347 } 1348 1349 STATIC OP * 1350 S_modkids(pTHX_ OP *o, I32 type) 1351 { 1352 if (o && o->op_flags & OPf_KIDS) { 1353 OP *kid; 1354 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 1355 mod(kid, type); 1356 } 1357 return o; 1358 } 1359 1360 /* Propagate lvalue ("modifiable") context to an op and its children. 1361 * 'type' represents the context type, roughly based on the type of op that 1362 * would do the modifying, although local() is represented by OP_NULL. 1363 * It's responsible for detecting things that can't be modified, flag 1364 * things that need to behave specially in an lvalue context (e.g., "$$x = 5" 1365 * might have to vivify a reference in $x), and so on. 1366 * 1367 * For example, "$a+1 = 2" would cause mod() to be called with o being 1368 * OP_ADD and type being OP_SASSIGN, and would output an error. 1369 */ 1370 1371 OP * 1372 Perl_mod(pTHX_ OP *o, I32 type) 1373 { 1374 dVAR; 1375 OP *kid; 1376 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */ 1377 int localize = -1; 1378 1379 if (!o || (PL_parser && PL_parser->error_count)) 1380 return o; 1381 1382 if ((o->op_private & OPpTARGET_MY) 1383 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */ 1384 { 1385 return o; 1386 } 1387 1388 switch (o->op_type) { 1389 case OP_UNDEF: 1390 localize = 0; 1391 PL_modcount++; 1392 return o; 1393 case OP_CONST: 1394 if (!(o->op_private & OPpCONST_ARYBASE)) 1395 goto nomod; 1396 localize = 0; 1397 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) { 1398 CopARYBASE_set(&PL_compiling, 1399 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv)); 1400 PL_eval_start = 0; 1401 } 1402 else if (!type) { 1403 SAVECOPARYBASE(&PL_compiling); 1404 CopARYBASE_set(&PL_compiling, 0); 1405 } 1406 else if (type == OP_REFGEN) 1407 goto nomod; 1408 else 1409 Perl_croak(aTHX_ "That use of $[ is unsupported"); 1410 break; 1411 case OP_STUB: 1412 if ((o->op_flags & OPf_PARENS) || PL_madskills) 1413 break; 1414 goto nomod; 1415 case OP_ENTERSUB: 1416 if ((type == OP_UNDEF || type == OP_REFGEN) && 1417 !(o->op_flags & OPf_STACKED)) { 1418 o->op_type = OP_RV2CV; /* entersub => rv2cv */ 1419 /* The default is to set op_private to the number of children, 1420 which for a UNOP such as RV2CV is always 1. And w're using 1421 the bit for a flag in RV2CV, so we need it clear. */ 1422 o->op_private &= ~1; 1423 o->op_ppaddr = PL_ppaddr[OP_RV2CV]; 1424 assert(cUNOPo->op_first->op_type == OP_NULL); 1425 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */ 1426 break; 1427 } 1428 else if (o->op_private & OPpENTERSUB_NOMOD) 1429 return o; 1430 else { /* lvalue subroutine call */ 1431 o->op_private |= OPpLVAL_INTRO; 1432 PL_modcount = RETURN_UNLIMITED_NUMBER; 1433 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) { 1434 /* Backward compatibility mode: */ 1435 o->op_private |= OPpENTERSUB_INARGS; 1436 break; 1437 } 1438 else { /* Compile-time error message: */ 1439 OP *kid = cUNOPo->op_first; 1440 CV *cv; 1441 OP *okid; 1442 1443 if (kid->op_type != OP_PUSHMARK) { 1444 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST) 1445 Perl_croak(aTHX_ 1446 "panic: unexpected lvalue entersub " 1447 "args: type/targ %ld:%"UVuf, 1448 (long)kid->op_type, (UV)kid->op_targ); 1449 kid = kLISTOP->op_first; 1450 } 1451 while (kid->op_sibling) 1452 kid = kid->op_sibling; 1453 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) { 1454 /* Indirect call */ 1455 if (kid->op_type == OP_METHOD_NAMED 1456 || kid->op_type == OP_METHOD) 1457 { 1458 UNOP *newop; 1459 1460 NewOp(1101, newop, 1, UNOP); 1461 newop->op_type = OP_RV2CV; 1462 newop->op_ppaddr = PL_ppaddr[OP_RV2CV]; 1463 newop->op_first = NULL; 1464 newop->op_next = (OP*)newop; 1465 kid->op_sibling = (OP*)newop; 1466 newop->op_private |= OPpLVAL_INTRO; 1467 newop->op_private &= ~1; 1468 break; 1469 } 1470 1471 if (kid->op_type != OP_RV2CV) 1472 Perl_croak(aTHX_ 1473 "panic: unexpected lvalue entersub " 1474 "entry via type/targ %ld:%"UVuf, 1475 (long)kid->op_type, (UV)kid->op_targ); 1476 kid->op_private |= OPpLVAL_INTRO; 1477 break; /* Postpone until runtime */ 1478 } 1479 1480 okid = kid; 1481 kid = kUNOP->op_first; 1482 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV) 1483 kid = kUNOP->op_first; 1484 if (kid->op_type == OP_NULL) 1485 Perl_croak(aTHX_ 1486 "Unexpected constant lvalue entersub " 1487 "entry via type/targ %ld:%"UVuf, 1488 (long)kid->op_type, (UV)kid->op_targ); 1489 if (kid->op_type != OP_GV) { 1490 /* Restore RV2CV to check lvalueness */ 1491 restore_2cv: 1492 if (kid->op_next && kid->op_next != kid) { /* Happens? */ 1493 okid->op_next = kid->op_next; 1494 kid->op_next = okid; 1495 } 1496 else 1497 okid->op_next = NULL; 1498 okid->op_type = OP_RV2CV; 1499 okid->op_targ = 0; 1500 okid->op_ppaddr = PL_ppaddr[OP_RV2CV]; 1501 okid->op_private |= OPpLVAL_INTRO; 1502 okid->op_private &= ~1; 1503 break; 1504 } 1505 1506 cv = GvCV(kGVOP_gv); 1507 if (!cv) 1508 goto restore_2cv; 1509 if (CvLVALUE(cv)) 1510 break; 1511 } 1512 } 1513 /* FALL THROUGH */ 1514 default: 1515 nomod: 1516 /* grep, foreach, subcalls, refgen */ 1517 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) 1518 break; 1519 yyerror(Perl_form(aTHX_ "Can't modify %s in %s", 1520 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL) 1521 ? "do block" 1522 : (o->op_type == OP_ENTERSUB 1523 ? "non-lvalue subroutine call" 1524 : OP_DESC(o))), 1525 type ? PL_op_desc[type] : "local")); 1526 return o; 1527 1528 case OP_PREINC: 1529 case OP_PREDEC: 1530 case OP_POW: 1531 case OP_MULTIPLY: 1532 case OP_DIVIDE: 1533 case OP_MODULO: 1534 case OP_REPEAT: 1535 case OP_ADD: 1536 case OP_SUBTRACT: 1537 case OP_CONCAT: 1538 case OP_LEFT_SHIFT: 1539 case OP_RIGHT_SHIFT: 1540 case OP_BIT_AND: 1541 case OP_BIT_XOR: 1542 case OP_BIT_OR: 1543 case OP_I_MULTIPLY: 1544 case OP_I_DIVIDE: 1545 case OP_I_MODULO: 1546 case OP_I_ADD: 1547 case OP_I_SUBTRACT: 1548 if (!(o->op_flags & OPf_STACKED)) 1549 goto nomod; 1550 PL_modcount++; 1551 break; 1552 1553 case OP_COND_EXPR: 1554 localize = 1; 1555 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) 1556 mod(kid, type); 1557 break; 1558 1559 case OP_RV2AV: 1560 case OP_RV2HV: 1561 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) { 1562 PL_modcount = RETURN_UNLIMITED_NUMBER; 1563 return o; /* Treat \(@foo) like ordinary list. */ 1564 } 1565 /* FALL THROUGH */ 1566 case OP_RV2GV: 1567 if (scalar_mod_type(o, type)) 1568 goto nomod; 1569 ref(cUNOPo->op_first, o->op_type); 1570 /* FALL THROUGH */ 1571 case OP_ASLICE: 1572 case OP_HSLICE: 1573 if (type == OP_LEAVESUBLV) 1574 o->op_private |= OPpMAYBE_LVSUB; 1575 localize = 1; 1576 /* FALL THROUGH */ 1577 case OP_AASSIGN: 1578 case OP_NEXTSTATE: 1579 case OP_DBSTATE: 1580 PL_modcount = RETURN_UNLIMITED_NUMBER; 1581 break; 1582 case OP_AV2ARYLEN: 1583 PL_hints |= HINT_BLOCK_SCOPE; 1584 if (type == OP_LEAVESUBLV) 1585 o->op_private |= OPpMAYBE_LVSUB; 1586 PL_modcount++; 1587 break; 1588 case OP_RV2SV: 1589 ref(cUNOPo->op_first, o->op_type); 1590 localize = 1; 1591 /* FALL THROUGH */ 1592 case OP_GV: 1593 PL_hints |= HINT_BLOCK_SCOPE; 1594 case OP_SASSIGN: 1595 case OP_ANDASSIGN: 1596 case OP_ORASSIGN: 1597 case OP_DORASSIGN: 1598 PL_modcount++; 1599 break; 1600 1601 case OP_AELEMFAST: 1602 localize = -1; 1603 PL_modcount++; 1604 break; 1605 1606 case OP_PADAV: 1607 case OP_PADHV: 1608 PL_modcount = RETURN_UNLIMITED_NUMBER; 1609 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) 1610 return o; /* Treat \(@foo) like ordinary list. */ 1611 if (scalar_mod_type(o, type)) 1612 goto nomod; 1613 if (type == OP_LEAVESUBLV) 1614 o->op_private |= OPpMAYBE_LVSUB; 1615 /* FALL THROUGH */ 1616 case OP_PADSV: 1617 PL_modcount++; 1618 if (!type) /* local() */ 1619 Perl_croak(aTHX_ "Can't localize lexical variable %s", 1620 PAD_COMPNAME_PV(o->op_targ)); 1621 break; 1622 1623 case OP_PUSHMARK: 1624 localize = 0; 1625 break; 1626 1627 case OP_KEYS: 1628 if (type != OP_SASSIGN) 1629 goto nomod; 1630 goto lvalue_func; 1631 case OP_SUBSTR: 1632 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */ 1633 goto nomod; 1634 /* FALL THROUGH */ 1635 case OP_POS: 1636 case OP_VEC: 1637 if (type == OP_LEAVESUBLV) 1638 o->op_private |= OPpMAYBE_LVSUB; 1639 lvalue_func: 1640 pad_free(o->op_targ); 1641 o->op_targ = pad_alloc(o->op_type, SVs_PADMY); 1642 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL); 1643 if (o->op_flags & OPf_KIDS) 1644 mod(cBINOPo->op_first->op_sibling, type); 1645 break; 1646 1647 case OP_AELEM: 1648 case OP_HELEM: 1649 ref(cBINOPo->op_first, o->op_type); 1650 if (type == OP_ENTERSUB && 1651 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF))) 1652 o->op_private |= OPpLVAL_DEFER; 1653 if (type == OP_LEAVESUBLV) 1654 o->op_private |= OPpMAYBE_LVSUB; 1655 localize = 1; 1656 PL_modcount++; 1657 break; 1658 1659 case OP_SCOPE: 1660 case OP_LEAVE: 1661 case OP_ENTER: 1662 case OP_LINESEQ: 1663 localize = 0; 1664 if (o->op_flags & OPf_KIDS) 1665 mod(cLISTOPo->op_last, type); 1666 break; 1667 1668 case OP_NULL: 1669 localize = 0; 1670 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */ 1671 goto nomod; 1672 else if (!(o->op_flags & OPf_KIDS)) 1673 break; 1674 if (o->op_targ != OP_LIST) { 1675 mod(cBINOPo->op_first, type); 1676 break; 1677 } 1678 /* FALL THROUGH */ 1679 case OP_LIST: 1680 localize = 0; 1681 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 1682 mod(kid, type); 1683 break; 1684 1685 case OP_RETURN: 1686 if (type != OP_LEAVESUBLV) 1687 goto nomod; 1688 break; /* mod()ing was handled by ck_return() */ 1689 } 1690 1691 /* [20011101.069] File test operators interpret OPf_REF to mean that 1692 their argument is a filehandle; thus \stat(".") should not set 1693 it. AMS 20011102 */ 1694 if (type == OP_REFGEN && 1695 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)) 1696 return o; 1697 1698 if (type != OP_LEAVESUBLV) 1699 o->op_flags |= OPf_MOD; 1700 1701 if (type == OP_AASSIGN || type == OP_SASSIGN) 1702 o->op_flags |= OPf_SPECIAL|OPf_REF; 1703 else if (!type) { /* local() */ 1704 switch (localize) { 1705 case 1: 1706 o->op_private |= OPpLVAL_INTRO; 1707 o->op_flags &= ~OPf_SPECIAL; 1708 PL_hints |= HINT_BLOCK_SCOPE; 1709 break; 1710 case 0: 1711 break; 1712 case -1: 1713 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), 1714 "Useless localization of %s", OP_DESC(o)); 1715 } 1716 } 1717 else if (type != OP_GREPSTART && type != OP_ENTERSUB 1718 && type != OP_LEAVESUBLV) 1719 o->op_flags |= OPf_REF; 1720 return o; 1721 } 1722 1723 STATIC bool 1724 S_scalar_mod_type(const OP *o, I32 type) 1725 { 1726 PERL_ARGS_ASSERT_SCALAR_MOD_TYPE; 1727 1728 switch (type) { 1729 case OP_SASSIGN: 1730 if (o->op_type == OP_RV2GV) 1731 return FALSE; 1732 /* FALL THROUGH */ 1733 case OP_PREINC: 1734 case OP_PREDEC: 1735 case OP_POSTINC: 1736 case OP_POSTDEC: 1737 case OP_I_PREINC: 1738 case OP_I_PREDEC: 1739 case OP_I_POSTINC: 1740 case OP_I_POSTDEC: 1741 case OP_POW: 1742 case OP_MULTIPLY: 1743 case OP_DIVIDE: 1744 case OP_MODULO: 1745 case OP_REPEAT: 1746 case OP_ADD: 1747 case OP_SUBTRACT: 1748 case OP_I_MULTIPLY: 1749 case OP_I_DIVIDE: 1750 case OP_I_MODULO: 1751 case OP_I_ADD: 1752 case OP_I_SUBTRACT: 1753 case OP_LEFT_SHIFT: 1754 case OP_RIGHT_SHIFT: 1755 case OP_BIT_AND: 1756 case OP_BIT_XOR: 1757 case OP_BIT_OR: 1758 case OP_CONCAT: 1759 case OP_SUBST: 1760 case OP_TRANS: 1761 case OP_READ: 1762 case OP_SYSREAD: 1763 case OP_RECV: 1764 case OP_ANDASSIGN: 1765 case OP_ORASSIGN: 1766 case OP_DORASSIGN: 1767 return TRUE; 1768 default: 1769 return FALSE; 1770 } 1771 } 1772 1773 STATIC bool 1774 S_is_handle_constructor(const OP *o, I32 numargs) 1775 { 1776 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR; 1777 1778 switch (o->op_type) { 1779 case OP_PIPE_OP: 1780 case OP_SOCKPAIR: 1781 if (numargs == 2) 1782 return TRUE; 1783 /* FALL THROUGH */ 1784 case OP_SYSOPEN: 1785 case OP_OPEN: 1786 case OP_SELECT: /* XXX c.f. SelectSaver.pm */ 1787 case OP_SOCKET: 1788 case OP_OPEN_DIR: 1789 case OP_ACCEPT: 1790 if (numargs == 1) 1791 return TRUE; 1792 /* FALLTHROUGH */ 1793 default: 1794 return FALSE; 1795 } 1796 } 1797 1798 static OP * 1799 S_refkids(pTHX_ OP *o, I32 type) 1800 { 1801 if (o && o->op_flags & OPf_KIDS) { 1802 OP *kid; 1803 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 1804 ref(kid, type); 1805 } 1806 return o; 1807 } 1808 1809 OP * 1810 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref) 1811 { 1812 dVAR; 1813 OP *kid; 1814 1815 PERL_ARGS_ASSERT_DOREF; 1816 1817 if (!o || (PL_parser && PL_parser->error_count)) 1818 return o; 1819 1820 switch (o->op_type) { 1821 case OP_ENTERSUB: 1822 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) && 1823 !(o->op_flags & OPf_STACKED)) { 1824 o->op_type = OP_RV2CV; /* entersub => rv2cv */ 1825 o->op_ppaddr = PL_ppaddr[OP_RV2CV]; 1826 assert(cUNOPo->op_first->op_type == OP_NULL); 1827 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */ 1828 o->op_flags |= OPf_SPECIAL; 1829 o->op_private &= ~1; 1830 } 1831 break; 1832 1833 case OP_COND_EXPR: 1834 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) 1835 doref(kid, type, set_op_ref); 1836 break; 1837 case OP_RV2SV: 1838 if (type == OP_DEFINED) 1839 o->op_flags |= OPf_SPECIAL; /* don't create GV */ 1840 doref(cUNOPo->op_first, o->op_type, set_op_ref); 1841 /* FALL THROUGH */ 1842 case OP_PADSV: 1843 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) { 1844 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV 1845 : type == OP_RV2HV ? OPpDEREF_HV 1846 : OPpDEREF_SV); 1847 o->op_flags |= OPf_MOD; 1848 } 1849 break; 1850 1851 case OP_RV2AV: 1852 case OP_RV2HV: 1853 if (set_op_ref) 1854 o->op_flags |= OPf_REF; 1855 /* FALL THROUGH */ 1856 case OP_RV2GV: 1857 if (type == OP_DEFINED) 1858 o->op_flags |= OPf_SPECIAL; /* don't create GV */ 1859 doref(cUNOPo->op_first, o->op_type, set_op_ref); 1860 break; 1861 1862 case OP_PADAV: 1863 case OP_PADHV: 1864 if (set_op_ref) 1865 o->op_flags |= OPf_REF; 1866 break; 1867 1868 case OP_SCALAR: 1869 case OP_NULL: 1870 if (!(o->op_flags & OPf_KIDS)) 1871 break; 1872 doref(cBINOPo->op_first, type, set_op_ref); 1873 break; 1874 case OP_AELEM: 1875 case OP_HELEM: 1876 doref(cBINOPo->op_first, o->op_type, set_op_ref); 1877 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) { 1878 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV 1879 : type == OP_RV2HV ? OPpDEREF_HV 1880 : OPpDEREF_SV); 1881 o->op_flags |= OPf_MOD; 1882 } 1883 break; 1884 1885 case OP_SCOPE: 1886 case OP_LEAVE: 1887 set_op_ref = FALSE; 1888 /* FALL THROUGH */ 1889 case OP_ENTER: 1890 case OP_LIST: 1891 if (!(o->op_flags & OPf_KIDS)) 1892 break; 1893 doref(cLISTOPo->op_last, type, set_op_ref); 1894 break; 1895 default: 1896 break; 1897 } 1898 return scalar(o); 1899 1900 } 1901 1902 STATIC OP * 1903 S_dup_attrlist(pTHX_ OP *o) 1904 { 1905 dVAR; 1906 OP *rop; 1907 1908 PERL_ARGS_ASSERT_DUP_ATTRLIST; 1909 1910 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids, 1911 * where the first kid is OP_PUSHMARK and the remaining ones 1912 * are OP_CONST. We need to push the OP_CONST values. 1913 */ 1914 if (o->op_type == OP_CONST) 1915 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv)); 1916 #ifdef PERL_MAD 1917 else if (o->op_type == OP_NULL) 1918 rop = NULL; 1919 #endif 1920 else { 1921 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS)); 1922 rop = NULL; 1923 for (o = cLISTOPo->op_first; o; o=o->op_sibling) { 1924 if (o->op_type == OP_CONST) 1925 rop = append_elem(OP_LIST, rop, 1926 newSVOP(OP_CONST, o->op_flags, 1927 SvREFCNT_inc_NN(cSVOPo->op_sv))); 1928 } 1929 } 1930 return rop; 1931 } 1932 1933 STATIC void 1934 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my) 1935 { 1936 dVAR; 1937 SV *stashsv; 1938 1939 PERL_ARGS_ASSERT_APPLY_ATTRS; 1940 1941 /* fake up C<use attributes $pkg,$rv,@attrs> */ 1942 ENTER; /* need to protect against side-effects of 'use' */ 1943 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no; 1944 1945 #define ATTRSMODULE "attributes" 1946 #define ATTRSMODULE_PM "attributes.pm" 1947 1948 if (for_my) { 1949 /* Don't force the C<use> if we don't need it. */ 1950 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE); 1951 if (svp && *svp != &PL_sv_undef) 1952 NOOP; /* already in %INC */ 1953 else 1954 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, 1955 newSVpvs(ATTRSMODULE), NULL); 1956 } 1957 else { 1958 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS, 1959 newSVpvs(ATTRSMODULE), 1960 NULL, 1961 prepend_elem(OP_LIST, 1962 newSVOP(OP_CONST, 0, stashsv), 1963 prepend_elem(OP_LIST, 1964 newSVOP(OP_CONST, 0, 1965 newRV(target)), 1966 dup_attrlist(attrs)))); 1967 } 1968 LEAVE; 1969 } 1970 1971 STATIC void 1972 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) 1973 { 1974 dVAR; 1975 OP *pack, *imop, *arg; 1976 SV *meth, *stashsv; 1977 1978 PERL_ARGS_ASSERT_APPLY_ATTRS_MY; 1979 1980 if (!attrs) 1981 return; 1982 1983 assert(target->op_type == OP_PADSV || 1984 target->op_type == OP_PADHV || 1985 target->op_type == OP_PADAV); 1986 1987 /* Ensure that attributes.pm is loaded. */ 1988 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE); 1989 1990 /* Need package name for method call. */ 1991 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE)); 1992 1993 /* Build up the real arg-list. */ 1994 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no; 1995 1996 arg = newOP(OP_PADSV, 0); 1997 arg->op_targ = target->op_targ; 1998 arg = prepend_elem(OP_LIST, 1999 newSVOP(OP_CONST, 0, stashsv), 2000 prepend_elem(OP_LIST, 2001 newUNOP(OP_REFGEN, 0, 2002 mod(arg, OP_REFGEN)), 2003 dup_attrlist(attrs))); 2004 2005 /* Fake up a method call to import */ 2006 meth = newSVpvs_share("import"); 2007 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID, 2008 append_elem(OP_LIST, 2009 prepend_elem(OP_LIST, pack, list(arg)), 2010 newSVOP(OP_METHOD_NAMED, 0, meth))); 2011 imop->op_private |= OPpENTERSUB_NOMOD; 2012 2013 /* Combine the ops. */ 2014 *imopsp = append_elem(OP_LIST, *imopsp, imop); 2015 } 2016 2017 /* 2018 =notfor apidoc apply_attrs_string 2019 2020 Attempts to apply a list of attributes specified by the C<attrstr> and 2021 C<len> arguments to the subroutine identified by the C<cv> argument which 2022 is expected to be associated with the package identified by the C<stashpv> 2023 argument (see L<attributes>). It gets this wrong, though, in that it 2024 does not correctly identify the boundaries of the individual attribute 2025 specifications within C<attrstr>. This is not really intended for the 2026 public API, but has to be listed here for systems such as AIX which 2027 need an explicit export list for symbols. (It's called from XS code 2028 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it 2029 to respect attribute syntax properly would be welcome. 2030 2031 =cut 2032 */ 2033 2034 void 2035 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv, 2036 const char *attrstr, STRLEN len) 2037 { 2038 OP *attrs = NULL; 2039 2040 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING; 2041 2042 if (!len) { 2043 len = strlen(attrstr); 2044 } 2045 2046 while (len) { 2047 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ; 2048 if (len) { 2049 const char * const sstr = attrstr; 2050 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ; 2051 attrs = append_elem(OP_LIST, attrs, 2052 newSVOP(OP_CONST, 0, 2053 newSVpvn(sstr, attrstr-sstr))); 2054 } 2055 } 2056 2057 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS, 2058 newSVpvs(ATTRSMODULE), 2059 NULL, prepend_elem(OP_LIST, 2060 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)), 2061 prepend_elem(OP_LIST, 2062 newSVOP(OP_CONST, 0, 2063 newRV(MUTABLE_SV(cv))), 2064 attrs))); 2065 } 2066 2067 STATIC OP * 2068 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) 2069 { 2070 dVAR; 2071 I32 type; 2072 2073 PERL_ARGS_ASSERT_MY_KID; 2074 2075 if (!o || (PL_parser && PL_parser->error_count)) 2076 return o; 2077 2078 type = o->op_type; 2079 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) { 2080 (void)my_kid(cUNOPo->op_first, attrs, imopsp); 2081 return o; 2082 } 2083 2084 if (type == OP_LIST) { 2085 OP *kid; 2086 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 2087 my_kid(kid, attrs, imopsp); 2088 } else if (type == OP_UNDEF 2089 #ifdef PERL_MAD 2090 || type == OP_STUB 2091 #endif 2092 ) { 2093 return o; 2094 } else if (type == OP_RV2SV || /* "our" declaration */ 2095 type == OP_RV2AV || 2096 type == OP_RV2HV) { /* XXX does this let anything illegal in? */ 2097 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */ 2098 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"", 2099 OP_DESC(o), 2100 PL_parser->in_my == KEY_our 2101 ? "our" 2102 : PL_parser->in_my == KEY_state ? "state" : "my")); 2103 } else if (attrs) { 2104 GV * const gv = cGVOPx_gv(cUNOPo->op_first); 2105 PL_parser->in_my = FALSE; 2106 PL_parser->in_my_stash = NULL; 2107 apply_attrs(GvSTASH(gv), 2108 (type == OP_RV2SV ? GvSV(gv) : 2109 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) : 2110 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)), 2111 attrs, FALSE); 2112 } 2113 o->op_private |= OPpOUR_INTRO; 2114 return o; 2115 } 2116 else if (type != OP_PADSV && 2117 type != OP_PADAV && 2118 type != OP_PADHV && 2119 type != OP_PUSHMARK) 2120 { 2121 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"", 2122 OP_DESC(o), 2123 PL_parser->in_my == KEY_our 2124 ? "our" 2125 : PL_parser->in_my == KEY_state ? "state" : "my")); 2126 return o; 2127 } 2128 else if (attrs && type != OP_PUSHMARK) { 2129 HV *stash; 2130 2131 PL_parser->in_my = FALSE; 2132 PL_parser->in_my_stash = NULL; 2133 2134 /* check for C<my Dog $spot> when deciding package */ 2135 stash = PAD_COMPNAME_TYPE(o->op_targ); 2136 if (!stash) 2137 stash = PL_curstash; 2138 apply_attrs_my(stash, o, attrs, imopsp); 2139 } 2140 o->op_flags |= OPf_MOD; 2141 o->op_private |= OPpLVAL_INTRO; 2142 if (PL_parser->in_my == KEY_state) 2143 o->op_private |= OPpPAD_STATE; 2144 return o; 2145 } 2146 2147 OP * 2148 Perl_my_attrs(pTHX_ OP *o, OP *attrs) 2149 { 2150 dVAR; 2151 OP *rops; 2152 int maybe_scalar = 0; 2153 2154 PERL_ARGS_ASSERT_MY_ATTRS; 2155 2156 /* [perl #17376]: this appears to be premature, and results in code such as 2157 C< our(%x); > executing in list mode rather than void mode */ 2158 #if 0 2159 if (o->op_flags & OPf_PARENS) 2160 list(o); 2161 else 2162 maybe_scalar = 1; 2163 #else 2164 maybe_scalar = 1; 2165 #endif 2166 if (attrs) 2167 SAVEFREEOP(attrs); 2168 rops = NULL; 2169 o = my_kid(o, attrs, &rops); 2170 if (rops) { 2171 if (maybe_scalar && o->op_type == OP_PADSV) { 2172 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o)); 2173 o->op_private |= OPpLVAL_INTRO; 2174 } 2175 else 2176 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops); 2177 } 2178 PL_parser->in_my = FALSE; 2179 PL_parser->in_my_stash = NULL; 2180 return o; 2181 } 2182 2183 OP * 2184 Perl_sawparens(pTHX_ OP *o) 2185 { 2186 PERL_UNUSED_CONTEXT; 2187 if (o) 2188 o->op_flags |= OPf_PARENS; 2189 return o; 2190 } 2191 2192 OP * 2193 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) 2194 { 2195 OP *o; 2196 bool ismatchop = 0; 2197 const OPCODE ltype = left->op_type; 2198 const OPCODE rtype = right->op_type; 2199 2200 PERL_ARGS_ASSERT_BIND_MATCH; 2201 2202 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV 2203 || ltype == OP_PADHV) && ckWARN(WARN_MISC)) 2204 { 2205 const char * const desc 2206 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS) 2207 ? (int)rtype : OP_MATCH]; 2208 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV) 2209 ? "@array" : "%hash"); 2210 Perl_warner(aTHX_ packWARN(WARN_MISC), 2211 "Applying %s to %s will act on scalar(%s)", 2212 desc, sample, sample); 2213 } 2214 2215 if (rtype == OP_CONST && 2216 cSVOPx(right)->op_private & OPpCONST_BARE && 2217 cSVOPx(right)->op_private & OPpCONST_STRICT) 2218 { 2219 no_bareword_allowed(right); 2220 } 2221 2222 ismatchop = rtype == OP_MATCH || 2223 rtype == OP_SUBST || 2224 rtype == OP_TRANS; 2225 if (ismatchop && right->op_private & OPpTARGET_MY) { 2226 right->op_targ = 0; 2227 right->op_private &= ~OPpTARGET_MY; 2228 } 2229 if (!(right->op_flags & OPf_STACKED) && ismatchop) { 2230 OP *newleft; 2231 2232 right->op_flags |= OPf_STACKED; 2233 if (rtype != OP_MATCH && 2234 ! (rtype == OP_TRANS && 2235 right->op_private & OPpTRANS_IDENTICAL)) 2236 newleft = mod(left, rtype); 2237 else 2238 newleft = left; 2239 if (right->op_type == OP_TRANS) 2240 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right); 2241 else 2242 o = prepend_elem(rtype, scalar(newleft), right); 2243 if (type == OP_NOT) 2244 return newUNOP(OP_NOT, 0, scalar(o)); 2245 return o; 2246 } 2247 else 2248 return bind_match(type, left, 2249 pmruntime(newPMOP(OP_MATCH, 0), right, 0)); 2250 } 2251 2252 OP * 2253 Perl_invert(pTHX_ OP *o) 2254 { 2255 if (!o) 2256 return NULL; 2257 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o)); 2258 } 2259 2260 OP * 2261 Perl_scope(pTHX_ OP *o) 2262 { 2263 dVAR; 2264 if (o) { 2265 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) { 2266 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o); 2267 o->op_type = OP_LEAVE; 2268 o->op_ppaddr = PL_ppaddr[OP_LEAVE]; 2269 } 2270 else if (o->op_type == OP_LINESEQ) { 2271 OP *kid; 2272 o->op_type = OP_SCOPE; 2273 o->op_ppaddr = PL_ppaddr[OP_SCOPE]; 2274 kid = ((LISTOP*)o)->op_first; 2275 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) { 2276 op_null(kid); 2277 2278 /* The following deals with things like 'do {1 for 1}' */ 2279 kid = kid->op_sibling; 2280 if (kid && 2281 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)) 2282 op_null(kid); 2283 } 2284 } 2285 else 2286 o = newLISTOP(OP_SCOPE, 0, o, NULL); 2287 } 2288 return o; 2289 } 2290 2291 int 2292 Perl_block_start(pTHX_ int full) 2293 { 2294 dVAR; 2295 const int retval = PL_savestack_ix; 2296 pad_block_start(full); 2297 SAVEHINTS(); 2298 PL_hints &= ~HINT_BLOCK_SCOPE; 2299 SAVECOMPILEWARNINGS(); 2300 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings); 2301 return retval; 2302 } 2303 2304 OP* 2305 Perl_block_end(pTHX_ I32 floor, OP *seq) 2306 { 2307 dVAR; 2308 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE; 2309 OP* const retval = scalarseq(seq); 2310 LEAVE_SCOPE(floor); 2311 CopHINTS_set(&PL_compiling, PL_hints); 2312 if (needblockscope) 2313 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */ 2314 pad_leavemy(); 2315 return retval; 2316 } 2317 2318 STATIC OP * 2319 S_newDEFSVOP(pTHX) 2320 { 2321 dVAR; 2322 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0); 2323 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) { 2324 return newSVREF(newGVOP(OP_GV, 0, PL_defgv)); 2325 } 2326 else { 2327 OP * const o = newOP(OP_PADSV, 0); 2328 o->op_targ = offset; 2329 return o; 2330 } 2331 } 2332 2333 void 2334 Perl_newPROG(pTHX_ OP *o) 2335 { 2336 dVAR; 2337 2338 PERL_ARGS_ASSERT_NEWPROG; 2339 2340 if (PL_in_eval) { 2341 if (PL_eval_root) 2342 return; 2343 PL_eval_root = newUNOP(OP_LEAVEEVAL, 2344 ((PL_in_eval & EVAL_KEEPERR) 2345 ? OPf_SPECIAL : 0), o); 2346 PL_eval_start = linklist(PL_eval_root); 2347 PL_eval_root->op_private |= OPpREFCOUNTED; 2348 OpREFCNT_set(PL_eval_root, 1); 2349 PL_eval_root->op_next = 0; 2350 CALL_PEEP(PL_eval_start); 2351 } 2352 else { 2353 if (o->op_type == OP_STUB) { 2354 PL_comppad_name = 0; 2355 PL_compcv = 0; 2356 S_op_destroy(aTHX_ o); 2357 return; 2358 } 2359 PL_main_root = scope(sawparens(scalarvoid(o))); 2360 PL_curcop = &PL_compiling; 2361 PL_main_start = LINKLIST(PL_main_root); 2362 PL_main_root->op_private |= OPpREFCOUNTED; 2363 OpREFCNT_set(PL_main_root, 1); 2364 PL_main_root->op_next = 0; 2365 CALL_PEEP(PL_main_start); 2366 PL_compcv = 0; 2367 2368 /* Register with debugger */ 2369 if (PERLDB_INTER) { 2370 CV * const cv = get_cvs("DB::postponed", 0); 2371 if (cv) { 2372 dSP; 2373 PUSHMARK(SP); 2374 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling))); 2375 PUTBACK; 2376 call_sv(MUTABLE_SV(cv), G_DISCARD); 2377 } 2378 } 2379 } 2380 } 2381 2382 OP * 2383 Perl_localize(pTHX_ OP *o, I32 lex) 2384 { 2385 dVAR; 2386 2387 PERL_ARGS_ASSERT_LOCALIZE; 2388 2389 if (o->op_flags & OPf_PARENS) 2390 /* [perl #17376]: this appears to be premature, and results in code such as 2391 C< our(%x); > executing in list mode rather than void mode */ 2392 #if 0 2393 list(o); 2394 #else 2395 NOOP; 2396 #endif 2397 else { 2398 if ( PL_parser->bufptr > PL_parser->oldbufptr 2399 && PL_parser->bufptr[-1] == ',' 2400 && ckWARN(WARN_PARENTHESIS)) 2401 { 2402 char *s = PL_parser->bufptr; 2403 bool sigil = FALSE; 2404 2405 /* some heuristics to detect a potential error */ 2406 while (*s && (strchr(", \t\n", *s))) 2407 s++; 2408 2409 while (1) { 2410 if (*s && strchr("@$%*", *s) && *++s 2411 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) { 2412 s++; 2413 sigil = TRUE; 2414 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) 2415 s++; 2416 while (*s && (strchr(", \t\n", *s))) 2417 s++; 2418 } 2419 else 2420 break; 2421 } 2422 if (sigil && (*s == ';' || *s == '=')) { 2423 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS), 2424 "Parentheses missing around \"%s\" list", 2425 lex 2426 ? (PL_parser->in_my == KEY_our 2427 ? "our" 2428 : PL_parser->in_my == KEY_state 2429 ? "state" 2430 : "my") 2431 : "local"); 2432 } 2433 } 2434 } 2435 if (lex) 2436 o = my(o); 2437 else 2438 o = mod(o, OP_NULL); /* a bit kludgey */ 2439 PL_parser->in_my = FALSE; 2440 PL_parser->in_my_stash = NULL; 2441 return o; 2442 } 2443 2444 OP * 2445 Perl_jmaybe(pTHX_ OP *o) 2446 { 2447 PERL_ARGS_ASSERT_JMAYBE; 2448 2449 if (o->op_type == OP_LIST) { 2450 OP * const o2 2451 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV))); 2452 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o)); 2453 } 2454 return o; 2455 } 2456 2457 static OP * 2458 S_fold_constants(pTHX_ register OP *o) 2459 { 2460 dVAR; 2461 register OP * VOL curop; 2462 OP *newop; 2463 VOL I32 type = o->op_type; 2464 SV * VOL sv = NULL; 2465 int ret = 0; 2466 I32 oldscope; 2467 OP *old_next; 2468 SV * const oldwarnhook = PL_warnhook; 2469 SV * const olddiehook = PL_diehook; 2470 COP not_compiling; 2471 dJMPENV; 2472 2473 PERL_ARGS_ASSERT_FOLD_CONSTANTS; 2474 2475 if (PL_opargs[type] & OA_RETSCALAR) 2476 scalar(o); 2477 if (PL_opargs[type] & OA_TARGET && !o->op_targ) 2478 o->op_targ = pad_alloc(type, SVs_PADTMP); 2479 2480 /* integerize op, unless it happens to be C<-foo>. 2481 * XXX should pp_i_negate() do magic string negation instead? */ 2482 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER) 2483 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST 2484 && (cUNOPo->op_first->op_private & OPpCONST_BARE))) 2485 { 2486 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)]; 2487 } 2488 2489 if (!(PL_opargs[type] & OA_FOLDCONST)) 2490 goto nope; 2491 2492 switch (type) { 2493 case OP_NEGATE: 2494 /* XXX might want a ck_negate() for this */ 2495 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT; 2496 break; 2497 case OP_UCFIRST: 2498 case OP_LCFIRST: 2499 case OP_UC: 2500 case OP_LC: 2501 case OP_SLT: 2502 case OP_SGT: 2503 case OP_SLE: 2504 case OP_SGE: 2505 case OP_SCMP: 2506 /* XXX what about the numeric ops? */ 2507 if (PL_hints & HINT_LOCALE) 2508 goto nope; 2509 break; 2510 } 2511 2512 if (PL_parser && PL_parser->error_count) 2513 goto nope; /* Don't try to run w/ errors */ 2514 2515 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) { 2516 const OPCODE type = curop->op_type; 2517 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) && 2518 type != OP_LIST && 2519 type != OP_SCALAR && 2520 type != OP_NULL && 2521 type != OP_PUSHMARK) 2522 { 2523 goto nope; 2524 } 2525 } 2526 2527 curop = LINKLIST(o); 2528 old_next = o->op_next; 2529 o->op_next = 0; 2530 PL_op = curop; 2531 2532 oldscope = PL_scopestack_ix; 2533 create_eval_scope(G_FAKINGEVAL); 2534 2535 /* Verify that we don't need to save it: */ 2536 assert(PL_curcop == &PL_compiling); 2537 StructCopy(&PL_compiling, ¬_compiling, COP); 2538 PL_curcop = ¬_compiling; 2539 /* The above ensures that we run with all the correct hints of the 2540 currently compiling COP, but that IN_PERL_RUNTIME is not true. */ 2541 assert(IN_PERL_RUNTIME); 2542 PL_warnhook = PERL_WARNHOOK_FATAL; 2543 PL_diehook = NULL; 2544 JMPENV_PUSH(ret); 2545 2546 switch (ret) { 2547 case 0: 2548 CALLRUNOPS(aTHX); 2549 sv = *(PL_stack_sp--); 2550 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */ 2551 pad_swipe(o->op_targ, FALSE); 2552 else if (SvTEMP(sv)) { /* grab mortal temp? */ 2553 SvREFCNT_inc_simple_void(sv); 2554 SvTEMP_off(sv); 2555 } 2556 break; 2557 case 3: 2558 /* Something tried to die. Abandon constant folding. */ 2559 /* Pretend the error never happened. */ 2560 CLEAR_ERRSV(); 2561 o->op_next = old_next; 2562 break; 2563 default: 2564 JMPENV_POP; 2565 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */ 2566 PL_warnhook = oldwarnhook; 2567 PL_diehook = olddiehook; 2568 /* XXX note that this croak may fail as we've already blown away 2569 * the stack - eg any nested evals */ 2570 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret); 2571 } 2572 JMPENV_POP; 2573 PL_warnhook = oldwarnhook; 2574 PL_diehook = olddiehook; 2575 PL_curcop = &PL_compiling; 2576 2577 if (PL_scopestack_ix > oldscope) 2578 delete_eval_scope(); 2579 2580 if (ret) 2581 goto nope; 2582 2583 #ifndef PERL_MAD 2584 op_free(o); 2585 #endif 2586 assert(sv); 2587 if (type == OP_RV2GV) 2588 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv)); 2589 else 2590 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv)); 2591 op_getmad(o,newop,'f'); 2592 return newop; 2593 2594 nope: 2595 return o; 2596 } 2597 2598 static OP * 2599 S_gen_constant_list(pTHX_ register OP *o) 2600 { 2601 dVAR; 2602 register OP *curop; 2603 const I32 oldtmps_floor = PL_tmps_floor; 2604 2605 list(o); 2606 if (PL_parser && PL_parser->error_count) 2607 return o; /* Don't attempt to run with errors */ 2608 2609 PL_op = curop = LINKLIST(o); 2610 o->op_next = 0; 2611 CALL_PEEP(curop); 2612 pp_pushmark(); 2613 CALLRUNOPS(aTHX); 2614 PL_op = curop; 2615 assert (!(curop->op_flags & OPf_SPECIAL)); 2616 assert(curop->op_type == OP_RANGE); 2617 pp_anonlist(); 2618 PL_tmps_floor = oldtmps_floor; 2619 2620 o->op_type = OP_RV2AV; 2621 o->op_ppaddr = PL_ppaddr[OP_RV2AV]; 2622 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */ 2623 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */ 2624 o->op_opt = 0; /* needs to be revisited in peep() */ 2625 curop = ((UNOP*)o)->op_first; 2626 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--)); 2627 #ifdef PERL_MAD 2628 op_getmad(curop,o,'O'); 2629 #else 2630 op_free(curop); 2631 #endif 2632 linklist(o); 2633 return list(o); 2634 } 2635 2636 OP * 2637 Perl_convert(pTHX_ I32 type, I32 flags, OP *o) 2638 { 2639 dVAR; 2640 if (!o || o->op_type != OP_LIST) 2641 o = newLISTOP(OP_LIST, 0, o, NULL); 2642 else 2643 o->op_flags &= ~OPf_WANT; 2644 2645 if (!(PL_opargs[type] & OA_MARK)) 2646 op_null(cLISTOPo->op_first); 2647 2648 o->op_type = (OPCODE)type; 2649 o->op_ppaddr = PL_ppaddr[type]; 2650 o->op_flags |= flags; 2651 2652 o = CHECKOP(type, o); 2653 if (o->op_type != (unsigned)type) 2654 return o; 2655 2656 return fold_constants(o); 2657 } 2658 2659 /* List constructors */ 2660 2661 OP * 2662 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last) 2663 { 2664 if (!first) 2665 return last; 2666 2667 if (!last) 2668 return first; 2669 2670 if (first->op_type != (unsigned)type 2671 || (type == OP_LIST && (first->op_flags & OPf_PARENS))) 2672 { 2673 return newLISTOP(type, 0, first, last); 2674 } 2675 2676 if (first->op_flags & OPf_KIDS) 2677 ((LISTOP*)first)->op_last->op_sibling = last; 2678 else { 2679 first->op_flags |= OPf_KIDS; 2680 ((LISTOP*)first)->op_first = last; 2681 } 2682 ((LISTOP*)first)->op_last = last; 2683 return first; 2684 } 2685 2686 OP * 2687 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last) 2688 { 2689 if (!first) 2690 return (OP*)last; 2691 2692 if (!last) 2693 return (OP*)first; 2694 2695 if (first->op_type != (unsigned)type) 2696 return prepend_elem(type, (OP*)first, (OP*)last); 2697 2698 if (last->op_type != (unsigned)type) 2699 return append_elem(type, (OP*)first, (OP*)last); 2700 2701 first->op_last->op_sibling = last->op_first; 2702 first->op_last = last->op_last; 2703 first->op_flags |= (last->op_flags & OPf_KIDS); 2704 2705 #ifdef PERL_MAD 2706 if (last->op_first && first->op_madprop) { 2707 MADPROP *mp = last->op_first->op_madprop; 2708 if (mp) { 2709 while (mp->mad_next) 2710 mp = mp->mad_next; 2711 mp->mad_next = first->op_madprop; 2712 } 2713 else { 2714 last->op_first->op_madprop = first->op_madprop; 2715 } 2716 } 2717 first->op_madprop = last->op_madprop; 2718 last->op_madprop = 0; 2719 #endif 2720 2721 S_op_destroy(aTHX_ (OP*)last); 2722 2723 return (OP*)first; 2724 } 2725 2726 OP * 2727 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last) 2728 { 2729 if (!first) 2730 return last; 2731 2732 if (!last) 2733 return first; 2734 2735 if (last->op_type == (unsigned)type) { 2736 if (type == OP_LIST) { /* already a PUSHMARK there */ 2737 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling; 2738 ((LISTOP*)last)->op_first->op_sibling = first; 2739 if (!(first->op_flags & OPf_PARENS)) 2740 last->op_flags &= ~OPf_PARENS; 2741 } 2742 else { 2743 if (!(last->op_flags & OPf_KIDS)) { 2744 ((LISTOP*)last)->op_last = first; 2745 last->op_flags |= OPf_KIDS; 2746 } 2747 first->op_sibling = ((LISTOP*)last)->op_first; 2748 ((LISTOP*)last)->op_first = first; 2749 } 2750 last->op_flags |= OPf_KIDS; 2751 return last; 2752 } 2753 2754 return newLISTOP(type, 0, first, last); 2755 } 2756 2757 /* Constructors */ 2758 2759 #ifdef PERL_MAD 2760 2761 TOKEN * 2762 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop) 2763 { 2764 TOKEN *tk; 2765 Newxz(tk, 1, TOKEN); 2766 tk->tk_type = (OPCODE)optype; 2767 tk->tk_type = 12345; 2768 tk->tk_lval = lval; 2769 tk->tk_mad = madprop; 2770 return tk; 2771 } 2772 2773 void 2774 Perl_token_free(pTHX_ TOKEN* tk) 2775 { 2776 PERL_ARGS_ASSERT_TOKEN_FREE; 2777 2778 if (tk->tk_type != 12345) 2779 return; 2780 mad_free(tk->tk_mad); 2781 Safefree(tk); 2782 } 2783 2784 void 2785 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot) 2786 { 2787 MADPROP* mp; 2788 MADPROP* tm; 2789 2790 PERL_ARGS_ASSERT_TOKEN_GETMAD; 2791 2792 if (tk->tk_type != 12345) { 2793 Perl_warner(aTHX_ packWARN(WARN_MISC), 2794 "Invalid TOKEN object ignored"); 2795 return; 2796 } 2797 tm = tk->tk_mad; 2798 if (!tm) 2799 return; 2800 2801 /* faked up qw list? */ 2802 if (slot == '(' && 2803 tm->mad_type == MAD_SV && 2804 SvPVX((SV *)tm->mad_val)[0] == 'q') 2805 slot = 'x'; 2806 2807 if (o) { 2808 mp = o->op_madprop; 2809 if (mp) { 2810 for (;;) { 2811 /* pretend constant fold didn't happen? */ 2812 if (mp->mad_key == 'f' && 2813 (o->op_type == OP_CONST || 2814 o->op_type == OP_GV) ) 2815 { 2816 token_getmad(tk,(OP*)mp->mad_val,slot); 2817 return; 2818 } 2819 if (!mp->mad_next) 2820 break; 2821 mp = mp->mad_next; 2822 } 2823 mp->mad_next = tm; 2824 mp = mp->mad_next; 2825 } 2826 else { 2827 o->op_madprop = tm; 2828 mp = o->op_madprop; 2829 } 2830 if (mp->mad_key == 'X') 2831 mp->mad_key = slot; /* just change the first one */ 2832 2833 tk->tk_mad = 0; 2834 } 2835 else 2836 mad_free(tm); 2837 Safefree(tk); 2838 } 2839 2840 void 2841 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot) 2842 { 2843 MADPROP* mp; 2844 if (!from) 2845 return; 2846 if (o) { 2847 mp = o->op_madprop; 2848 if (mp) { 2849 for (;;) { 2850 /* pretend constant fold didn't happen? */ 2851 if (mp->mad_key == 'f' && 2852 (o->op_type == OP_CONST || 2853 o->op_type == OP_GV) ) 2854 { 2855 op_getmad(from,(OP*)mp->mad_val,slot); 2856 return; 2857 } 2858 if (!mp->mad_next) 2859 break; 2860 mp = mp->mad_next; 2861 } 2862 mp->mad_next = newMADPROP(slot,MAD_OP,from,0); 2863 } 2864 else { 2865 o->op_madprop = newMADPROP(slot,MAD_OP,from,0); 2866 } 2867 } 2868 } 2869 2870 void 2871 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot) 2872 { 2873 MADPROP* mp; 2874 if (!from) 2875 return; 2876 if (o) { 2877 mp = o->op_madprop; 2878 if (mp) { 2879 for (;;) { 2880 /* pretend constant fold didn't happen? */ 2881 if (mp->mad_key == 'f' && 2882 (o->op_type == OP_CONST || 2883 o->op_type == OP_GV) ) 2884 { 2885 op_getmad(from,(OP*)mp->mad_val,slot); 2886 return; 2887 } 2888 if (!mp->mad_next) 2889 break; 2890 mp = mp->mad_next; 2891 } 2892 mp->mad_next = newMADPROP(slot,MAD_OP,from,1); 2893 } 2894 else { 2895 o->op_madprop = newMADPROP(slot,MAD_OP,from,1); 2896 } 2897 } 2898 else { 2899 PerlIO_printf(PerlIO_stderr(), 2900 "DESTROYING op = %0"UVxf"\n", PTR2UV(from)); 2901 op_free(from); 2902 } 2903 } 2904 2905 void 2906 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot) 2907 { 2908 MADPROP* tm; 2909 if (!mp || !o) 2910 return; 2911 if (slot) 2912 mp->mad_key = slot; 2913 tm = o->op_madprop; 2914 o->op_madprop = mp; 2915 for (;;) { 2916 if (!mp->mad_next) 2917 break; 2918 mp = mp->mad_next; 2919 } 2920 mp->mad_next = tm; 2921 } 2922 2923 void 2924 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot) 2925 { 2926 if (!o) 2927 return; 2928 addmad(tm, &(o->op_madprop), slot); 2929 } 2930 2931 void 2932 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot) 2933 { 2934 MADPROP* mp; 2935 if (!tm || !root) 2936 return; 2937 if (slot) 2938 tm->mad_key = slot; 2939 mp = *root; 2940 if (!mp) { 2941 *root = tm; 2942 return; 2943 } 2944 for (;;) { 2945 if (!mp->mad_next) 2946 break; 2947 mp = mp->mad_next; 2948 } 2949 mp->mad_next = tm; 2950 } 2951 2952 MADPROP * 2953 Perl_newMADsv(pTHX_ char key, SV* sv) 2954 { 2955 PERL_ARGS_ASSERT_NEWMADSV; 2956 2957 return newMADPROP(key, MAD_SV, sv, 0); 2958 } 2959 2960 MADPROP * 2961 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen) 2962 { 2963 MADPROP *mp; 2964 Newxz(mp, 1, MADPROP); 2965 mp->mad_next = 0; 2966 mp->mad_key = key; 2967 mp->mad_vlen = vlen; 2968 mp->mad_type = type; 2969 mp->mad_val = val; 2970 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */ 2971 return mp; 2972 } 2973 2974 void 2975 Perl_mad_free(pTHX_ MADPROP* mp) 2976 { 2977 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */ 2978 if (!mp) 2979 return; 2980 if (mp->mad_next) 2981 mad_free(mp->mad_next); 2982 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen) 2983 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */ 2984 switch (mp->mad_type) { 2985 case MAD_NULL: 2986 break; 2987 case MAD_PV: 2988 Safefree((char*)mp->mad_val); 2989 break; 2990 case MAD_OP: 2991 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */ 2992 op_free((OP*)mp->mad_val); 2993 break; 2994 case MAD_SV: 2995 sv_free(MUTABLE_SV(mp->mad_val)); 2996 break; 2997 default: 2998 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n"); 2999 break; 3000 } 3001 Safefree(mp); 3002 } 3003 3004 #endif 3005 3006 OP * 3007 Perl_newNULLLIST(pTHX) 3008 { 3009 return newOP(OP_STUB, 0); 3010 } 3011 3012 static OP * 3013 S_force_list(pTHX_ OP *o) 3014 { 3015 if (!o || o->op_type != OP_LIST) 3016 o = newLISTOP(OP_LIST, 0, o, NULL); 3017 op_null(o); 3018 return o; 3019 } 3020 3021 OP * 3022 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) 3023 { 3024 dVAR; 3025 LISTOP *listop; 3026 3027 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP); 3028 3029 NewOp(1101, listop, 1, LISTOP); 3030 3031 listop->op_type = (OPCODE)type; 3032 listop->op_ppaddr = PL_ppaddr[type]; 3033 if (first || last) 3034 flags |= OPf_KIDS; 3035 listop->op_flags = (U8)flags; 3036 3037 if (!last && first) 3038 last = first; 3039 else if (!first && last) 3040 first = last; 3041 else if (first) 3042 first->op_sibling = last; 3043 listop->op_first = first; 3044 listop->op_last = last; 3045 if (type == OP_LIST) { 3046 OP* const pushop = newOP(OP_PUSHMARK, 0); 3047 pushop->op_sibling = first; 3048 listop->op_first = pushop; 3049 listop->op_flags |= OPf_KIDS; 3050 if (!last) 3051 listop->op_last = pushop; 3052 } 3053 3054 return CHECKOP(type, listop); 3055 } 3056 3057 OP * 3058 Perl_newOP(pTHX_ I32 type, I32 flags) 3059 { 3060 dVAR; 3061 OP *o; 3062 3063 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP 3064 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP 3065 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP 3066 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP); 3067 3068 NewOp(1101, o, 1, OP); 3069 o->op_type = (OPCODE)type; 3070 o->op_ppaddr = PL_ppaddr[type]; 3071 o->op_flags = (U8)flags; 3072 o->op_latefree = 0; 3073 o->op_latefreed = 0; 3074 o->op_attached = 0; 3075 3076 o->op_next = o; 3077 o->op_private = (U8)(0 | (flags >> 8)); 3078 if (PL_opargs[type] & OA_RETSCALAR) 3079 scalar(o); 3080 if (PL_opargs[type] & OA_TARGET) 3081 o->op_targ = pad_alloc(type, SVs_PADTMP); 3082 return CHECKOP(type, o); 3083 } 3084 3085 OP * 3086 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) 3087 { 3088 dVAR; 3089 UNOP *unop; 3090 3091 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP 3092 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP 3093 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP 3094 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP 3095 || type == OP_SASSIGN 3096 || type == OP_ENTERTRY 3097 || type == OP_NULL ); 3098 3099 if (!first) 3100 first = newOP(OP_STUB, 0); 3101 if (PL_opargs[type] & OA_MARK) 3102 first = force_list(first); 3103 3104 NewOp(1101, unop, 1, UNOP); 3105 unop->op_type = (OPCODE)type; 3106 unop->op_ppaddr = PL_ppaddr[type]; 3107 unop->op_first = first; 3108 unop->op_flags = (U8)(flags | OPf_KIDS); 3109 unop->op_private = (U8)(1 | (flags >> 8)); 3110 unop = (UNOP*) CHECKOP(type, unop); 3111 if (unop->op_next) 3112 return (OP*)unop; 3113 3114 return fold_constants((OP *) unop); 3115 } 3116 3117 OP * 3118 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) 3119 { 3120 dVAR; 3121 BINOP *binop; 3122 3123 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP 3124 || type == OP_SASSIGN || type == OP_NULL ); 3125 3126 NewOp(1101, binop, 1, BINOP); 3127 3128 if (!first) 3129 first = newOP(OP_NULL, 0); 3130 3131 binop->op_type = (OPCODE)type; 3132 binop->op_ppaddr = PL_ppaddr[type]; 3133 binop->op_first = first; 3134 binop->op_flags = (U8)(flags | OPf_KIDS); 3135 if (!last) { 3136 last = first; 3137 binop->op_private = (U8)(1 | (flags >> 8)); 3138 } 3139 else { 3140 binop->op_private = (U8)(2 | (flags >> 8)); 3141 first->op_sibling = last; 3142 } 3143 3144 binop = (BINOP*)CHECKOP(type, binop); 3145 if (binop->op_next || binop->op_type != (OPCODE)type) 3146 return (OP*)binop; 3147 3148 binop->op_last = binop->op_first->op_sibling; 3149 3150 return fold_constants((OP *)binop); 3151 } 3152 3153 static int uvcompare(const void *a, const void *b) 3154 __attribute__nonnull__(1) 3155 __attribute__nonnull__(2) 3156 __attribute__pure__; 3157 static int uvcompare(const void *a, const void *b) 3158 { 3159 if (*((const UV *)a) < (*(const UV *)b)) 3160 return -1; 3161 if (*((const UV *)a) > (*(const UV *)b)) 3162 return 1; 3163 if (*((const UV *)a+1) < (*(const UV *)b+1)) 3164 return -1; 3165 if (*((const UV *)a+1) > (*(const UV *)b+1)) 3166 return 1; 3167 return 0; 3168 } 3169 3170 static OP * 3171 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) 3172 { 3173 dVAR; 3174 SV * const tstr = ((SVOP*)expr)->op_sv; 3175 SV * const rstr = 3176 #ifdef PERL_MAD 3177 (repl->op_type == OP_NULL) 3178 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv : 3179 #endif 3180 ((SVOP*)repl)->op_sv; 3181 STRLEN tlen; 3182 STRLEN rlen; 3183 const U8 *t = (U8*)SvPV_const(tstr, tlen); 3184 const U8 *r = (U8*)SvPV_const(rstr, rlen); 3185 register I32 i; 3186 register I32 j; 3187 I32 grows = 0; 3188 register short *tbl; 3189 3190 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT; 3191 const I32 squash = o->op_private & OPpTRANS_SQUASH; 3192 I32 del = o->op_private & OPpTRANS_DELETE; 3193 SV* swash; 3194 3195 PERL_ARGS_ASSERT_PMTRANS; 3196 3197 PL_hints |= HINT_BLOCK_SCOPE; 3198 3199 if (SvUTF8(tstr)) 3200 o->op_private |= OPpTRANS_FROM_UTF; 3201 3202 if (SvUTF8(rstr)) 3203 o->op_private |= OPpTRANS_TO_UTF; 3204 3205 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) { 3206 SV* const listsv = newSVpvs("# comment\n"); 3207 SV* transv = NULL; 3208 const U8* tend = t + tlen; 3209 const U8* rend = r + rlen; 3210 STRLEN ulen; 3211 UV tfirst = 1; 3212 UV tlast = 0; 3213 IV tdiff; 3214 UV rfirst = 1; 3215 UV rlast = 0; 3216 IV rdiff; 3217 IV diff; 3218 I32 none = 0; 3219 U32 max = 0; 3220 I32 bits; 3221 I32 havefinal = 0; 3222 U32 final = 0; 3223 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF; 3224 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF; 3225 U8* tsave = NULL; 3226 U8* rsave = NULL; 3227 const U32 flags = UTF8_ALLOW_DEFAULT; 3228 3229 if (!from_utf) { 3230 STRLEN len = tlen; 3231 t = tsave = bytes_to_utf8(t, &len); 3232 tend = t + len; 3233 } 3234 if (!to_utf && rlen) { 3235 STRLEN len = rlen; 3236 r = rsave = bytes_to_utf8(r, &len); 3237 rend = r + len; 3238 } 3239 3240 /* There are several snags with this code on EBCDIC: 3241 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes). 3242 2. scan_const() in toke.c has encoded chars in native encoding which makes 3243 ranges at least in EBCDIC 0..255 range the bottom odd. 3244 */ 3245 3246 if (complement) { 3247 U8 tmpbuf[UTF8_MAXBYTES+1]; 3248 UV *cp; 3249 UV nextmin = 0; 3250 Newx(cp, 2*tlen, UV); 3251 i = 0; 3252 transv = newSVpvs(""); 3253 while (t < tend) { 3254 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags); 3255 t += ulen; 3256 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { 3257 t++; 3258 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags); 3259 t += ulen; 3260 } 3261 else { 3262 cp[2*i+1] = cp[2*i]; 3263 } 3264 i++; 3265 } 3266 qsort(cp, i, 2*sizeof(UV), uvcompare); 3267 for (j = 0; j < i; j++) { 3268 UV val = cp[2*j]; 3269 diff = val - nextmin; 3270 if (diff > 0) { 3271 t = uvuni_to_utf8(tmpbuf,nextmin); 3272 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); 3273 if (diff > 1) { 3274 U8 range_mark = UTF_TO_NATIVE(0xff); 3275 t = uvuni_to_utf8(tmpbuf, val - 1); 3276 sv_catpvn(transv, (char *)&range_mark, 1); 3277 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); 3278 } 3279 } 3280 val = cp[2*j+1]; 3281 if (val >= nextmin) 3282 nextmin = val + 1; 3283 } 3284 t = uvuni_to_utf8(tmpbuf,nextmin); 3285 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); 3286 { 3287 U8 range_mark = UTF_TO_NATIVE(0xff); 3288 sv_catpvn(transv, (char *)&range_mark, 1); 3289 } 3290 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff, 3291 UNICODE_ALLOW_SUPER); 3292 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); 3293 t = (const U8*)SvPVX_const(transv); 3294 tlen = SvCUR(transv); 3295 tend = t + tlen; 3296 Safefree(cp); 3297 } 3298 else if (!rlen && !del) { 3299 r = t; rlen = tlen; rend = tend; 3300 } 3301 if (!squash) { 3302 if ((!rlen && !del) || t == r || 3303 (tlen == rlen && memEQ((char *)t, (char *)r, tlen))) 3304 { 3305 o->op_private |= OPpTRANS_IDENTICAL; 3306 } 3307 } 3308 3309 while (t < tend || tfirst <= tlast) { 3310 /* see if we need more "t" chars */ 3311 if (tfirst > tlast) { 3312 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags); 3313 t += ulen; 3314 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */ 3315 t++; 3316 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags); 3317 t += ulen; 3318 } 3319 else 3320 tlast = tfirst; 3321 } 3322 3323 /* now see if we need more "r" chars */ 3324 if (rfirst > rlast) { 3325 if (r < rend) { 3326 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags); 3327 r += ulen; 3328 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */ 3329 r++; 3330 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags); 3331 r += ulen; 3332 } 3333 else 3334 rlast = rfirst; 3335 } 3336 else { 3337 if (!havefinal++) 3338 final = rlast; 3339 rfirst = rlast = 0xffffffff; 3340 } 3341 } 3342 3343 /* now see which range will peter our first, if either. */ 3344 tdiff = tlast - tfirst; 3345 rdiff = rlast - rfirst; 3346 3347 if (tdiff <= rdiff) 3348 diff = tdiff; 3349 else 3350 diff = rdiff; 3351 3352 if (rfirst == 0xffffffff) { 3353 diff = tdiff; /* oops, pretend rdiff is infinite */ 3354 if (diff > 0) 3355 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n", 3356 (long)tfirst, (long)tlast); 3357 else 3358 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst); 3359 } 3360 else { 3361 if (diff > 0) 3362 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n", 3363 (long)tfirst, (long)(tfirst + diff), 3364 (long)rfirst); 3365 else 3366 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n", 3367 (long)tfirst, (long)rfirst); 3368 3369 if (rfirst + diff > max) 3370 max = rfirst + diff; 3371 if (!grows) 3372 grows = (tfirst < rfirst && 3373 UNISKIP(tfirst) < UNISKIP(rfirst + diff)); 3374 rfirst += diff + 1; 3375 } 3376 tfirst += diff + 1; 3377 } 3378 3379 none = ++max; 3380 if (del) 3381 del = ++max; 3382 3383 if (max > 0xffff) 3384 bits = 32; 3385 else if (max > 0xff) 3386 bits = 16; 3387 else 3388 bits = 8; 3389 3390 PerlMemShared_free(cPVOPo->op_pv); 3391 cPVOPo->op_pv = NULL; 3392 3393 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none)); 3394 #ifdef USE_ITHREADS 3395 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP); 3396 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix)); 3397 PAD_SETSV(cPADOPo->op_padix, swash); 3398 SvPADTMP_on(swash); 3399 SvREADONLY_on(swash); 3400 #else 3401 cSVOPo->op_sv = swash; 3402 #endif 3403 SvREFCNT_dec(listsv); 3404 SvREFCNT_dec(transv); 3405 3406 if (!del && havefinal && rlen) 3407 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5, 3408 newSVuv((UV)final), 0); 3409 3410 if (grows) 3411 o->op_private |= OPpTRANS_GROWS; 3412 3413 Safefree(tsave); 3414 Safefree(rsave); 3415 3416 #ifdef PERL_MAD 3417 op_getmad(expr,o,'e'); 3418 op_getmad(repl,o,'r'); 3419 #else 3420 op_free(expr); 3421 op_free(repl); 3422 #endif 3423 return o; 3424 } 3425 3426 tbl = (short*)cPVOPo->op_pv; 3427 if (complement) { 3428 Zero(tbl, 256, short); 3429 for (i = 0; i < (I32)tlen; i++) 3430 tbl[t[i]] = -1; 3431 for (i = 0, j = 0; i < 256; i++) { 3432 if (!tbl[i]) { 3433 if (j >= (I32)rlen) { 3434 if (del) 3435 tbl[i] = -2; 3436 else if (rlen) 3437 tbl[i] = r[j-1]; 3438 else 3439 tbl[i] = (short)i; 3440 } 3441 else { 3442 if (i < 128 && r[j] >= 128) 3443 grows = 1; 3444 tbl[i] = r[j++]; 3445 } 3446 } 3447 } 3448 if (!del) { 3449 if (!rlen) { 3450 j = rlen; 3451 if (!squash) 3452 o->op_private |= OPpTRANS_IDENTICAL; 3453 } 3454 else if (j >= (I32)rlen) 3455 j = rlen - 1; 3456 else { 3457 tbl = 3458 (short *) 3459 PerlMemShared_realloc(tbl, 3460 (0x101+rlen-j) * sizeof(short)); 3461 cPVOPo->op_pv = (char*)tbl; 3462 } 3463 tbl[0x100] = (short)(rlen - j); 3464 for (i=0; i < (I32)rlen - j; i++) 3465 tbl[0x101+i] = r[j+i]; 3466 } 3467 } 3468 else { 3469 if (!rlen && !del) { 3470 r = t; rlen = tlen; 3471 if (!squash) 3472 o->op_private |= OPpTRANS_IDENTICAL; 3473 } 3474 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) { 3475 o->op_private |= OPpTRANS_IDENTICAL; 3476 } 3477 for (i = 0; i < 256; i++) 3478 tbl[i] = -1; 3479 for (i = 0, j = 0; i < (I32)tlen; i++,j++) { 3480 if (j >= (I32)rlen) { 3481 if (del) { 3482 if (tbl[t[i]] == -1) 3483 tbl[t[i]] = -2; 3484 continue; 3485 } 3486 --j; 3487 } 3488 if (tbl[t[i]] == -1) { 3489 if (t[i] < 128 && r[j] >= 128) 3490 grows = 1; 3491 tbl[t[i]] = r[j]; 3492 } 3493 } 3494 } 3495 3496 if(del && rlen == tlen) { 3497 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator"); 3498 } else if(rlen > tlen) { 3499 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list"); 3500 } 3501 3502 if (grows) 3503 o->op_private |= OPpTRANS_GROWS; 3504 #ifdef PERL_MAD 3505 op_getmad(expr,o,'e'); 3506 op_getmad(repl,o,'r'); 3507 #else 3508 op_free(expr); 3509 op_free(repl); 3510 #endif 3511 3512 return o; 3513 } 3514 3515 OP * 3516 Perl_newPMOP(pTHX_ I32 type, I32 flags) 3517 { 3518 dVAR; 3519 PMOP *pmop; 3520 3521 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP); 3522 3523 NewOp(1101, pmop, 1, PMOP); 3524 pmop->op_type = (OPCODE)type; 3525 pmop->op_ppaddr = PL_ppaddr[type]; 3526 pmop->op_flags = (U8)flags; 3527 pmop->op_private = (U8)(0 | (flags >> 8)); 3528 3529 if (PL_hints & HINT_RE_TAINT) 3530 pmop->op_pmflags |= PMf_RETAINT; 3531 if (PL_hints & HINT_LOCALE) 3532 pmop->op_pmflags |= PMf_LOCALE; 3533 3534 3535 #ifdef USE_ITHREADS 3536 assert(SvPOK(PL_regex_pad[0])); 3537 if (SvCUR(PL_regex_pad[0])) { 3538 /* Pop off the "packed" IV from the end. */ 3539 SV *const repointer_list = PL_regex_pad[0]; 3540 const char *p = SvEND(repointer_list) - sizeof(IV); 3541 const IV offset = *((IV*)p); 3542 3543 assert(SvCUR(repointer_list) % sizeof(IV) == 0); 3544 3545 SvEND_set(repointer_list, p); 3546 3547 pmop->op_pmoffset = offset; 3548 /* This slot should be free, so assert this: */ 3549 assert(PL_regex_pad[offset] == &PL_sv_undef); 3550 } else { 3551 SV * const repointer = &PL_sv_undef; 3552 av_push(PL_regex_padav, repointer); 3553 pmop->op_pmoffset = av_len(PL_regex_padav); 3554 PL_regex_pad = AvARRAY(PL_regex_padav); 3555 } 3556 #endif 3557 3558 return CHECKOP(type, pmop); 3559 } 3560 3561 /* Given some sort of match op o, and an expression expr containing a 3562 * pattern, either compile expr into a regex and attach it to o (if it's 3563 * constant), or convert expr into a runtime regcomp op sequence (if it's 3564 * not) 3565 * 3566 * isreg indicates that the pattern is part of a regex construct, eg 3567 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or 3568 * split "pattern", which aren't. In the former case, expr will be a list 3569 * if the pattern contains more than one term (eg /a$b/) or if it contains 3570 * a replacement, ie s/// or tr///. 3571 */ 3572 3573 OP * 3574 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) 3575 { 3576 dVAR; 3577 PMOP *pm; 3578 LOGOP *rcop; 3579 I32 repl_has_vars = 0; 3580 OP* repl = NULL; 3581 bool reglist; 3582 3583 PERL_ARGS_ASSERT_PMRUNTIME; 3584 3585 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) { 3586 /* last element in list is the replacement; pop it */ 3587 OP* kid; 3588 repl = cLISTOPx(expr)->op_last; 3589 kid = cLISTOPx(expr)->op_first; 3590 while (kid->op_sibling != repl) 3591 kid = kid->op_sibling; 3592 kid->op_sibling = NULL; 3593 cLISTOPx(expr)->op_last = kid; 3594 } 3595 3596 if (isreg && expr->op_type == OP_LIST && 3597 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last) 3598 { 3599 /* convert single element list to element */ 3600 OP* const oe = expr; 3601 expr = cLISTOPx(oe)->op_first->op_sibling; 3602 cLISTOPx(oe)->op_first->op_sibling = NULL; 3603 cLISTOPx(oe)->op_last = NULL; 3604 op_free(oe); 3605 } 3606 3607 if (o->op_type == OP_TRANS) { 3608 return pmtrans(o, expr, repl); 3609 } 3610 3611 reglist = isreg && expr->op_type == OP_LIST; 3612 if (reglist) 3613 op_null(expr); 3614 3615 PL_hints |= HINT_BLOCK_SCOPE; 3616 pm = (PMOP*)o; 3617 3618 if (expr->op_type == OP_CONST) { 3619 SV *pat = ((SVOP*)expr)->op_sv; 3620 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME; 3621 3622 if (o->op_flags & OPf_SPECIAL) 3623 pm_flags |= RXf_SPLIT; 3624 3625 if (DO_UTF8(pat)) { 3626 assert (SvUTF8(pat)); 3627 } else if (SvUTF8(pat)) { 3628 /* Not doing UTF-8, despite what the SV says. Is this only if we're 3629 trapped in use 'bytes'? */ 3630 /* Make a copy of the octet sequence, but without the flag on, as 3631 the compiler now honours the SvUTF8 flag on pat. */ 3632 STRLEN len; 3633 const char *const p = SvPV(pat, len); 3634 pat = newSVpvn_flags(p, len, SVs_TEMP); 3635 } 3636 3637 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags)); 3638 3639 #ifdef PERL_MAD 3640 op_getmad(expr,(OP*)pm,'e'); 3641 #else 3642 op_free(expr); 3643 #endif 3644 } 3645 else { 3646 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) 3647 expr = newUNOP((!(PL_hints & HINT_RE_EVAL) 3648 ? OP_REGCRESET 3649 : OP_REGCMAYBE),0,expr); 3650 3651 NewOp(1101, rcop, 1, LOGOP); 3652 rcop->op_type = OP_REGCOMP; 3653 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP]; 3654 rcop->op_first = scalar(expr); 3655 rcop->op_flags |= OPf_KIDS 3656 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0) 3657 | (reglist ? OPf_STACKED : 0); 3658 rcop->op_private = 1; 3659 rcop->op_other = o; 3660 if (reglist) 3661 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP); 3662 3663 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */ 3664 PL_cv_has_eval = 1; 3665 3666 /* establish postfix order */ 3667 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) { 3668 LINKLIST(expr); 3669 rcop->op_next = expr; 3670 ((UNOP*)expr)->op_first->op_next = (OP*)rcop; 3671 } 3672 else { 3673 rcop->op_next = LINKLIST(expr); 3674 expr->op_next = (OP*)rcop; 3675 } 3676 3677 prepend_elem(o->op_type, scalar((OP*)rcop), o); 3678 } 3679 3680 if (repl) { 3681 OP *curop; 3682 if (pm->op_pmflags & PMf_EVAL) { 3683 curop = NULL; 3684 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end) 3685 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end); 3686 } 3687 else if (repl->op_type == OP_CONST) 3688 curop = repl; 3689 else { 3690 OP *lastop = NULL; 3691 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) { 3692 if (curop->op_type == OP_SCOPE 3693 || curop->op_type == OP_LEAVE 3694 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) { 3695 if (curop->op_type == OP_GV) { 3696 GV * const gv = cGVOPx_gv(curop); 3697 repl_has_vars = 1; 3698 if (strchr("&`'123456789+-\016\022", *GvENAME(gv))) 3699 break; 3700 } 3701 else if (curop->op_type == OP_RV2CV) 3702 break; 3703 else if (curop->op_type == OP_RV2SV || 3704 curop->op_type == OP_RV2AV || 3705 curop->op_type == OP_RV2HV || 3706 curop->op_type == OP_RV2GV) { 3707 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/ 3708 break; 3709 } 3710 else if (curop->op_type == OP_PADSV || 3711 curop->op_type == OP_PADAV || 3712 curop->op_type == OP_PADHV || 3713 curop->op_type == OP_PADANY) 3714 { 3715 repl_has_vars = 1; 3716 } 3717 else if (curop->op_type == OP_PUSHRE) 3718 NOOP; /* Okay here, dangerous in newASSIGNOP */ 3719 else 3720 break; 3721 } 3722 lastop = curop; 3723 } 3724 } 3725 if (curop == repl 3726 && !(repl_has_vars 3727 && (!PM_GETRE(pm) 3728 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN))) 3729 { 3730 pm->op_pmflags |= PMf_CONST; /* const for long enough */ 3731 prepend_elem(o->op_type, scalar(repl), o); 3732 } 3733 else { 3734 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */ 3735 pm->op_pmflags |= PMf_MAYBE_CONST; 3736 } 3737 NewOp(1101, rcop, 1, LOGOP); 3738 rcop->op_type = OP_SUBSTCONT; 3739 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT]; 3740 rcop->op_first = scalar(repl); 3741 rcop->op_flags |= OPf_KIDS; 3742 rcop->op_private = 1; 3743 rcop->op_other = o; 3744 3745 /* establish postfix order */ 3746 rcop->op_next = LINKLIST(repl); 3747 repl->op_next = (OP*)rcop; 3748 3749 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop); 3750 assert(!(pm->op_pmflags & PMf_ONCE)); 3751 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop); 3752 rcop->op_next = 0; 3753 } 3754 } 3755 3756 return (OP*)pm; 3757 } 3758 3759 OP * 3760 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv) 3761 { 3762 dVAR; 3763 SVOP *svop; 3764 3765 PERL_ARGS_ASSERT_NEWSVOP; 3766 3767 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP 3768 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP 3769 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP); 3770 3771 NewOp(1101, svop, 1, SVOP); 3772 svop->op_type = (OPCODE)type; 3773 svop->op_ppaddr = PL_ppaddr[type]; 3774 svop->op_sv = sv; 3775 svop->op_next = (OP*)svop; 3776 svop->op_flags = (U8)flags; 3777 if (PL_opargs[type] & OA_RETSCALAR) 3778 scalar((OP*)svop); 3779 if (PL_opargs[type] & OA_TARGET) 3780 svop->op_targ = pad_alloc(type, SVs_PADTMP); 3781 return CHECKOP(type, svop); 3782 } 3783 3784 #ifdef USE_ITHREADS 3785 OP * 3786 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) 3787 { 3788 dVAR; 3789 PADOP *padop; 3790 3791 PERL_ARGS_ASSERT_NEWPADOP; 3792 3793 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP 3794 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP 3795 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP); 3796 3797 NewOp(1101, padop, 1, PADOP); 3798 padop->op_type = (OPCODE)type; 3799 padop->op_ppaddr = PL_ppaddr[type]; 3800 padop->op_padix = pad_alloc(type, SVs_PADTMP); 3801 SvREFCNT_dec(PAD_SVl(padop->op_padix)); 3802 PAD_SETSV(padop->op_padix, sv); 3803 assert(sv); 3804 SvPADTMP_on(sv); 3805 padop->op_next = (OP*)padop; 3806 padop->op_flags = (U8)flags; 3807 if (PL_opargs[type] & OA_RETSCALAR) 3808 scalar((OP*)padop); 3809 if (PL_opargs[type] & OA_TARGET) 3810 padop->op_targ = pad_alloc(type, SVs_PADTMP); 3811 return CHECKOP(type, padop); 3812 } 3813 #endif 3814 3815 OP * 3816 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv) 3817 { 3818 dVAR; 3819 3820 PERL_ARGS_ASSERT_NEWGVOP; 3821 3822 #ifdef USE_ITHREADS 3823 GvIN_PAD_on(gv); 3824 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv)); 3825 #else 3826 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv)); 3827 #endif 3828 } 3829 3830 OP * 3831 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv) 3832 { 3833 dVAR; 3834 PVOP *pvop; 3835 3836 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP 3837 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP); 3838 3839 NewOp(1101, pvop, 1, PVOP); 3840 pvop->op_type = (OPCODE)type; 3841 pvop->op_ppaddr = PL_ppaddr[type]; 3842 pvop->op_pv = pv; 3843 pvop->op_next = (OP*)pvop; 3844 pvop->op_flags = (U8)flags; 3845 if (PL_opargs[type] & OA_RETSCALAR) 3846 scalar((OP*)pvop); 3847 if (PL_opargs[type] & OA_TARGET) 3848 pvop->op_targ = pad_alloc(type, SVs_PADTMP); 3849 return CHECKOP(type, pvop); 3850 } 3851 3852 #ifdef PERL_MAD 3853 OP* 3854 #else 3855 void 3856 #endif 3857 Perl_package(pTHX_ OP *o) 3858 { 3859 dVAR; 3860 SV *const sv = cSVOPo->op_sv; 3861 #ifdef PERL_MAD 3862 OP *pegop; 3863 #endif 3864 3865 PERL_ARGS_ASSERT_PACKAGE; 3866 3867 save_hptr(&PL_curstash); 3868 save_item(PL_curstname); 3869 3870 PL_curstash = gv_stashsv(sv, GV_ADD); 3871 3872 sv_setsv(PL_curstname, sv); 3873 3874 PL_hints |= HINT_BLOCK_SCOPE; 3875 PL_parser->copline = NOLINE; 3876 PL_parser->expect = XSTATE; 3877 3878 #ifndef PERL_MAD 3879 op_free(o); 3880 #else 3881 if (!PL_madskills) { 3882 op_free(o); 3883 return NULL; 3884 } 3885 3886 pegop = newOP(OP_NULL,0); 3887 op_getmad(o,pegop,'P'); 3888 return pegop; 3889 #endif 3890 } 3891 3892 void 3893 Perl_package_version( pTHX_ OP *v ) 3894 { 3895 dVAR; 3896 U32 savehints = PL_hints; 3897 PERL_ARGS_ASSERT_PACKAGE_VERSION; 3898 PL_hints &= ~HINT_STRICT_VARS; 3899 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv ); 3900 PL_hints = savehints; 3901 op_free(v); 3902 } 3903 3904 #ifdef PERL_MAD 3905 OP* 3906 #else 3907 void 3908 #endif 3909 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) 3910 { 3911 dVAR; 3912 OP *pack; 3913 OP *imop; 3914 OP *veop; 3915 #ifdef PERL_MAD 3916 OP *pegop = newOP(OP_NULL,0); 3917 #endif 3918 3919 PERL_ARGS_ASSERT_UTILIZE; 3920 3921 if (idop->op_type != OP_CONST) 3922 Perl_croak(aTHX_ "Module name must be constant"); 3923 3924 if (PL_madskills) 3925 op_getmad(idop,pegop,'U'); 3926 3927 veop = NULL; 3928 3929 if (version) { 3930 SV * const vesv = ((SVOP*)version)->op_sv; 3931 3932 if (PL_madskills) 3933 op_getmad(version,pegop,'V'); 3934 if (!arg && !SvNIOKp(vesv)) { 3935 arg = version; 3936 } 3937 else { 3938 OP *pack; 3939 SV *meth; 3940 3941 if (version->op_type != OP_CONST || !SvNIOKp(vesv)) 3942 Perl_croak(aTHX_ "Version number must be a constant number"); 3943 3944 /* Make copy of idop so we don't free it twice */ 3945 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv)); 3946 3947 /* Fake up a method call to VERSION */ 3948 meth = newSVpvs_share("VERSION"); 3949 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, 3950 append_elem(OP_LIST, 3951 prepend_elem(OP_LIST, pack, list(version)), 3952 newSVOP(OP_METHOD_NAMED, 0, meth))); 3953 } 3954 } 3955 3956 /* Fake up an import/unimport */ 3957 if (arg && arg->op_type == OP_STUB) { 3958 if (PL_madskills) 3959 op_getmad(arg,pegop,'S'); 3960 imop = arg; /* no import on explicit () */ 3961 } 3962 else if (SvNIOKp(((SVOP*)idop)->op_sv)) { 3963 imop = NULL; /* use 5.0; */ 3964 if (!aver) 3965 idop->op_private |= OPpCONST_NOVER; 3966 } 3967 else { 3968 SV *meth; 3969 3970 if (PL_madskills) 3971 op_getmad(arg,pegop,'A'); 3972 3973 /* Make copy of idop so we don't free it twice */ 3974 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv)); 3975 3976 /* Fake up a method call to import/unimport */ 3977 meth = aver 3978 ? newSVpvs_share("import") : newSVpvs_share("unimport"); 3979 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, 3980 append_elem(OP_LIST, 3981 prepend_elem(OP_LIST, pack, list(arg)), 3982 newSVOP(OP_METHOD_NAMED, 0, meth))); 3983 } 3984 3985 /* Fake up the BEGIN {}, which does its thing immediately. */ 3986 newATTRSUB(floor, 3987 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")), 3988 NULL, 3989 NULL, 3990 append_elem(OP_LINESEQ, 3991 append_elem(OP_LINESEQ, 3992 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)), 3993 newSTATEOP(0, NULL, veop)), 3994 newSTATEOP(0, NULL, imop) )); 3995 3996 /* The "did you use incorrect case?" warning used to be here. 3997 * The problem is that on case-insensitive filesystems one 3998 * might get false positives for "use" (and "require"): 3999 * "use Strict" or "require CARP" will work. This causes 4000 * portability problems for the script: in case-strict 4001 * filesystems the script will stop working. 4002 * 4003 * The "incorrect case" warning checked whether "use Foo" 4004 * imported "Foo" to your namespace, but that is wrong, too: 4005 * there is no requirement nor promise in the language that 4006 * a Foo.pm should or would contain anything in package "Foo". 4007 * 4008 * There is very little Configure-wise that can be done, either: 4009 * the case-sensitivity of the build filesystem of Perl does not 4010 * help in guessing the case-sensitivity of the runtime environment. 4011 */ 4012 4013 PL_hints |= HINT_BLOCK_SCOPE; 4014 PL_parser->copline = NOLINE; 4015 PL_parser->expect = XSTATE; 4016 PL_cop_seqmax++; /* Purely for B::*'s benefit */ 4017 4018 #ifdef PERL_MAD 4019 if (!PL_madskills) { 4020 /* FIXME - don't allocate pegop if !PL_madskills */ 4021 op_free(pegop); 4022 return NULL; 4023 } 4024 return pegop; 4025 #endif 4026 } 4027 4028 /* 4029 =head1 Embedding Functions 4030 4031 =for apidoc load_module 4032 4033 Loads the module whose name is pointed to by the string part of name. 4034 Note that the actual module name, not its filename, should be given. 4035 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of 4036 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS 4037 (or 0 for no flags). ver, if specified, provides version semantics 4038 similar to C<use Foo::Bar VERSION>. The optional trailing SV* 4039 arguments can be used to specify arguments to the module's import() 4040 method, similar to C<use Foo::Bar VERSION LIST>. They must be 4041 terminated with a final NULL pointer. Note that this list can only 4042 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used. 4043 Otherwise at least a single NULL pointer to designate the default 4044 import list is required. 4045 4046 =cut */ 4047 4048 void 4049 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...) 4050 { 4051 va_list args; 4052 4053 PERL_ARGS_ASSERT_LOAD_MODULE; 4054 4055 va_start(args, ver); 4056 vload_module(flags, name, ver, &args); 4057 va_end(args); 4058 } 4059 4060 #ifdef PERL_IMPLICIT_CONTEXT 4061 void 4062 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...) 4063 { 4064 dTHX; 4065 va_list args; 4066 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT; 4067 va_start(args, ver); 4068 vload_module(flags, name, ver, &args); 4069 va_end(args); 4070 } 4071 #endif 4072 4073 void 4074 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args) 4075 { 4076 dVAR; 4077 OP *veop, *imop; 4078 OP * const modname = newSVOP(OP_CONST, 0, name); 4079 4080 PERL_ARGS_ASSERT_VLOAD_MODULE; 4081 4082 modname->op_private |= OPpCONST_BARE; 4083 if (ver) { 4084 veop = newSVOP(OP_CONST, 0, ver); 4085 } 4086 else 4087 veop = NULL; 4088 if (flags & PERL_LOADMOD_NOIMPORT) { 4089 imop = sawparens(newNULLLIST()); 4090 } 4091 else if (flags & PERL_LOADMOD_IMPORT_OPS) { 4092 imop = va_arg(*args, OP*); 4093 } 4094 else { 4095 SV *sv; 4096 imop = NULL; 4097 sv = va_arg(*args, SV*); 4098 while (sv) { 4099 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv)); 4100 sv = va_arg(*args, SV*); 4101 } 4102 } 4103 4104 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure 4105 * that it has a PL_parser to play with while doing that, and also 4106 * that it doesn't mess with any existing parser, by creating a tmp 4107 * new parser with lex_start(). This won't actually be used for much, 4108 * since pp_require() will create another parser for the real work. */ 4109 4110 ENTER; 4111 SAVEVPTR(PL_curcop); 4112 lex_start(NULL, NULL, FALSE); 4113 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), 4114 veop, modname, imop); 4115 LEAVE; 4116 } 4117 4118 OP * 4119 Perl_dofile(pTHX_ OP *term, I32 force_builtin) 4120 { 4121 dVAR; 4122 OP *doop; 4123 GV *gv = NULL; 4124 4125 PERL_ARGS_ASSERT_DOFILE; 4126 4127 if (!force_builtin) { 4128 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV); 4129 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) { 4130 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE); 4131 gv = gvp ? *gvp : NULL; 4132 } 4133 } 4134 4135 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) { 4136 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED, 4137 append_elem(OP_LIST, term, 4138 scalar(newUNOP(OP_RV2CV, 0, 4139 newGVOP(OP_GV, 0, gv)))))); 4140 } 4141 else { 4142 doop = newUNOP(OP_DOFILE, 0, scalar(term)); 4143 } 4144 return doop; 4145 } 4146 4147 OP * 4148 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval) 4149 { 4150 return newBINOP(OP_LSLICE, flags, 4151 list(force_list(subscript)), 4152 list(force_list(listval)) ); 4153 } 4154 4155 STATIC I32 4156 S_is_list_assignment(pTHX_ register const OP *o) 4157 { 4158 unsigned type; 4159 U8 flags; 4160 4161 if (!o) 4162 return TRUE; 4163 4164 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS)) 4165 o = cUNOPo->op_first; 4166 4167 flags = o->op_flags; 4168 type = o->op_type; 4169 if (type == OP_COND_EXPR) { 4170 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling); 4171 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling); 4172 4173 if (t && f) 4174 return TRUE; 4175 if (t || f) 4176 yyerror("Assignment to both a list and a scalar"); 4177 return FALSE; 4178 } 4179 4180 if (type == OP_LIST && 4181 (flags & OPf_WANT) == OPf_WANT_SCALAR && 4182 o->op_private & OPpLVAL_INTRO) 4183 return FALSE; 4184 4185 if (type == OP_LIST || flags & OPf_PARENS || 4186 type == OP_RV2AV || type == OP_RV2HV || 4187 type == OP_ASLICE || type == OP_HSLICE) 4188 return TRUE; 4189 4190 if (type == OP_PADAV || type == OP_PADHV) 4191 return TRUE; 4192 4193 if (type == OP_RV2SV) 4194 return FALSE; 4195 4196 return FALSE; 4197 } 4198 4199 OP * 4200 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) 4201 { 4202 dVAR; 4203 OP *o; 4204 4205 if (optype) { 4206 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) { 4207 return newLOGOP(optype, 0, 4208 mod(scalar(left), optype), 4209 newUNOP(OP_SASSIGN, 0, scalar(right))); 4210 } 4211 else { 4212 return newBINOP(optype, OPf_STACKED, 4213 mod(scalar(left), optype), scalar(right)); 4214 } 4215 } 4216 4217 if (is_list_assignment(left)) { 4218 static const char no_list_state[] = "Initialization of state variables" 4219 " in list context currently forbidden"; 4220 OP *curop; 4221 bool maybe_common_vars = TRUE; 4222 4223 PL_modcount = 0; 4224 /* Grandfathering $[ assignment here. Bletch.*/ 4225 /* Only simple assignments like C<< ($[) = 1 >> are allowed */ 4226 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL; 4227 left = mod(left, OP_AASSIGN); 4228 if (PL_eval_start) 4229 PL_eval_start = 0; 4230 else if (left->op_type == OP_CONST) { 4231 /* FIXME for MAD */ 4232 /* Result of assignment is always 1 (or we'd be dead already) */ 4233 return newSVOP(OP_CONST, 0, newSViv(1)); 4234 } 4235 curop = list(force_list(left)); 4236 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop); 4237 o->op_private = (U8)(0 | (flags >> 8)); 4238 4239 if ((left->op_type == OP_LIST 4240 || (left->op_type == OP_NULL && left->op_targ == OP_LIST))) 4241 { 4242 OP* lop = ((LISTOP*)left)->op_first; 4243 maybe_common_vars = FALSE; 4244 while (lop) { 4245 if (lop->op_type == OP_PADSV || 4246 lop->op_type == OP_PADAV || 4247 lop->op_type == OP_PADHV || 4248 lop->op_type == OP_PADANY) { 4249 if (!(lop->op_private & OPpLVAL_INTRO)) 4250 maybe_common_vars = TRUE; 4251 4252 if (lop->op_private & OPpPAD_STATE) { 4253 if (left->op_private & OPpLVAL_INTRO) { 4254 /* Each variable in state($a, $b, $c) = ... */ 4255 } 4256 else { 4257 /* Each state variable in 4258 (state $a, my $b, our $c, $d, undef) = ... */ 4259 } 4260 yyerror(no_list_state); 4261 } else { 4262 /* Each my variable in 4263 (state $a, my $b, our $c, $d, undef) = ... */ 4264 } 4265 } else if (lop->op_type == OP_UNDEF || 4266 lop->op_type == OP_PUSHMARK) { 4267 /* undef may be interesting in 4268 (state $a, undef, state $c) */ 4269 } else { 4270 /* Other ops in the list. */ 4271 maybe_common_vars = TRUE; 4272 } 4273 lop = lop->op_sibling; 4274 } 4275 } 4276 else if ((left->op_private & OPpLVAL_INTRO) 4277 && ( left->op_type == OP_PADSV 4278 || left->op_type == OP_PADAV 4279 || left->op_type == OP_PADHV 4280 || left->op_type == OP_PADANY)) 4281 { 4282 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE; 4283 if (left->op_private & OPpPAD_STATE) { 4284 /* All single variable list context state assignments, hence 4285 state ($a) = ... 4286 (state $a) = ... 4287 state @a = ... 4288 state (@a) = ... 4289 (state @a) = ... 4290 state %a = ... 4291 state (%a) = ... 4292 (state %a) = ... 4293 */ 4294 yyerror(no_list_state); 4295 } 4296 } 4297 4298 /* PL_generation sorcery: 4299 * an assignment like ($a,$b) = ($c,$d) is easier than 4300 * ($a,$b) = ($c,$a), since there is no need for temporary vars. 4301 * To detect whether there are common vars, the global var 4302 * PL_generation is incremented for each assign op we compile. 4303 * Then, while compiling the assign op, we run through all the 4304 * variables on both sides of the assignment, setting a spare slot 4305 * in each of them to PL_generation. If any of them already have 4306 * that value, we know we've got commonality. We could use a 4307 * single bit marker, but then we'd have to make 2 passes, first 4308 * to clear the flag, then to test and set it. To find somewhere 4309 * to store these values, evil chicanery is done with SvUVX(). 4310 */ 4311 4312 if (maybe_common_vars) { 4313 OP *lastop = o; 4314 PL_generation++; 4315 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) { 4316 if (PL_opargs[curop->op_type] & OA_DANGEROUS) { 4317 if (curop->op_type == OP_GV) { 4318 GV *gv = cGVOPx_gv(curop); 4319 if (gv == PL_defgv 4320 || (int)GvASSIGN_GENERATION(gv) == PL_generation) 4321 break; 4322 GvASSIGN_GENERATION_set(gv, PL_generation); 4323 } 4324 else if (curop->op_type == OP_PADSV || 4325 curop->op_type == OP_PADAV || 4326 curop->op_type == OP_PADHV || 4327 curop->op_type == OP_PADANY) 4328 { 4329 if (PAD_COMPNAME_GEN(curop->op_targ) 4330 == (STRLEN)PL_generation) 4331 break; 4332 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation); 4333 4334 } 4335 else if (curop->op_type == OP_RV2CV) 4336 break; 4337 else if (curop->op_type == OP_RV2SV || 4338 curop->op_type == OP_RV2AV || 4339 curop->op_type == OP_RV2HV || 4340 curop->op_type == OP_RV2GV) { 4341 if (lastop->op_type != OP_GV) /* funny deref? */ 4342 break; 4343 } 4344 else if (curop->op_type == OP_PUSHRE) { 4345 #ifdef USE_ITHREADS 4346 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) { 4347 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff)); 4348 if (gv == PL_defgv 4349 || (int)GvASSIGN_GENERATION(gv) == PL_generation) 4350 break; 4351 GvASSIGN_GENERATION_set(gv, PL_generation); 4352 } 4353 #else 4354 GV *const gv 4355 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv; 4356 if (gv) { 4357 if (gv == PL_defgv 4358 || (int)GvASSIGN_GENERATION(gv) == PL_generation) 4359 break; 4360 GvASSIGN_GENERATION_set(gv, PL_generation); 4361 } 4362 #endif 4363 } 4364 else 4365 break; 4366 } 4367 lastop = curop; 4368 } 4369 if (curop != o) 4370 o->op_private |= OPpASSIGN_COMMON; 4371 } 4372 4373 if (right && right->op_type == OP_SPLIT && !PL_madskills) { 4374 OP* tmpop = ((LISTOP*)right)->op_first; 4375 if (tmpop && (tmpop->op_type == OP_PUSHRE)) { 4376 PMOP * const pm = (PMOP*)tmpop; 4377 if (left->op_type == OP_RV2AV && 4378 !(left->op_private & OPpLVAL_INTRO) && 4379 !(o->op_private & OPpASSIGN_COMMON) ) 4380 { 4381 tmpop = ((UNOP*)left)->op_first; 4382 if (tmpop->op_type == OP_GV 4383 #ifdef USE_ITHREADS 4384 && !pm->op_pmreplrootu.op_pmtargetoff 4385 #else 4386 && !pm->op_pmreplrootu.op_pmtargetgv 4387 #endif 4388 ) { 4389 #ifdef USE_ITHREADS 4390 pm->op_pmreplrootu.op_pmtargetoff 4391 = cPADOPx(tmpop)->op_padix; 4392 cPADOPx(tmpop)->op_padix = 0; /* steal it */ 4393 #else 4394 pm->op_pmreplrootu.op_pmtargetgv 4395 = MUTABLE_GV(cSVOPx(tmpop)->op_sv); 4396 cSVOPx(tmpop)->op_sv = NULL; /* steal it */ 4397 #endif 4398 pm->op_pmflags |= PMf_ONCE; 4399 tmpop = cUNOPo->op_first; /* to list (nulled) */ 4400 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */ 4401 tmpop->op_sibling = NULL; /* don't free split */ 4402 right->op_next = tmpop->op_next; /* fix starting loc */ 4403 op_free(o); /* blow off assign */ 4404 right->op_flags &= ~OPf_WANT; 4405 /* "I don't know and I don't care." */ 4406 return right; 4407 } 4408 } 4409 else { 4410 if (PL_modcount < RETURN_UNLIMITED_NUMBER && 4411 ((LISTOP*)right)->op_last->op_type == OP_CONST) 4412 { 4413 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv; 4414 if (SvIOK(sv) && SvIVX(sv) == 0) 4415 sv_setiv(sv, PL_modcount+1); 4416 } 4417 } 4418 } 4419 } 4420 return o; 4421 } 4422 if (!right) 4423 right = newOP(OP_UNDEF, 0); 4424 if (right->op_type == OP_READLINE) { 4425 right->op_flags |= OPf_STACKED; 4426 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right)); 4427 } 4428 else { 4429 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/ 4430 o = newBINOP(OP_SASSIGN, flags, 4431 scalar(right), mod(scalar(left), OP_SASSIGN) ); 4432 if (PL_eval_start) 4433 PL_eval_start = 0; 4434 else { 4435 if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */ 4436 deprecate("assignment to $["); 4437 op_free(o); 4438 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling))); 4439 o->op_private |= OPpCONST_ARYBASE; 4440 } 4441 } 4442 } 4443 return o; 4444 } 4445 4446 OP * 4447 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) 4448 { 4449 dVAR; 4450 const U32 seq = intro_my(); 4451 register COP *cop; 4452 4453 NewOp(1101, cop, 1, COP); 4454 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) { 4455 cop->op_type = OP_DBSTATE; 4456 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ]; 4457 } 4458 else { 4459 cop->op_type = OP_NEXTSTATE; 4460 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ]; 4461 } 4462 cop->op_flags = (U8)flags; 4463 CopHINTS_set(cop, PL_hints); 4464 #ifdef NATIVE_HINTS 4465 cop->op_private |= NATIVE_HINTS; 4466 #endif 4467 CopHINTS_set(&PL_compiling, CopHINTS_get(cop)); 4468 cop->op_next = (OP*)cop; 4469 4470 cop->cop_seq = seq; 4471 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in 4472 CopHINTS and a possible value in cop_hints_hash, so no need to copy it. 4473 */ 4474 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings); 4475 cop->cop_hints_hash = PL_curcop->cop_hints_hash; 4476 if (cop->cop_hints_hash) { 4477 HINTS_REFCNT_LOCK; 4478 cop->cop_hints_hash->refcounted_he_refcnt++; 4479 HINTS_REFCNT_UNLOCK; 4480 } 4481 if (label) { 4482 cop->cop_hints_hash 4483 = Perl_store_cop_label(aTHX_ cop->cop_hints_hash, label); 4484 4485 PL_hints |= HINT_BLOCK_SCOPE; 4486 /* It seems that we need to defer freeing this pointer, as other parts 4487 of the grammar end up wanting to copy it after this op has been 4488 created. */ 4489 SAVEFREEPV(label); 4490 } 4491 4492 if (PL_parser && PL_parser->copline == NOLINE) 4493 CopLINE_set(cop, CopLINE(PL_curcop)); 4494 else { 4495 CopLINE_set(cop, PL_parser->copline); 4496 if (PL_parser) 4497 PL_parser->copline = NOLINE; 4498 } 4499 #ifdef USE_ITHREADS 4500 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */ 4501 #else 4502 CopFILEGV_set(cop, CopFILEGV(PL_curcop)); 4503 #endif 4504 CopSTASH_set(cop, PL_curstash); 4505 4506 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) { 4507 /* this line can have a breakpoint - store the cop in IV */ 4508 AV *av = CopFILEAVx(PL_curcop); 4509 if (av) { 4510 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE); 4511 if (svp && *svp != &PL_sv_undef ) { 4512 (void)SvIOK_on(*svp); 4513 SvIV_set(*svp, PTR2IV(cop)); 4514 } 4515 } 4516 } 4517 4518 if (flags & OPf_SPECIAL) 4519 op_null((OP*)cop); 4520 return prepend_elem(OP_LINESEQ, (OP*)cop, o); 4521 } 4522 4523 4524 OP * 4525 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other) 4526 { 4527 dVAR; 4528 4529 PERL_ARGS_ASSERT_NEWLOGOP; 4530 4531 return new_logop(type, flags, &first, &other); 4532 } 4533 4534 STATIC OP * 4535 S_search_const(pTHX_ OP *o) 4536 { 4537 PERL_ARGS_ASSERT_SEARCH_CONST; 4538 4539 switch (o->op_type) { 4540 case OP_CONST: 4541 return o; 4542 case OP_NULL: 4543 if (o->op_flags & OPf_KIDS) 4544 return search_const(cUNOPo->op_first); 4545 break; 4546 case OP_LEAVE: 4547 case OP_SCOPE: 4548 case OP_LINESEQ: 4549 { 4550 OP *kid; 4551 if (!(o->op_flags & OPf_KIDS)) 4552 return NULL; 4553 kid = cLISTOPo->op_first; 4554 do { 4555 switch (kid->op_type) { 4556 case OP_ENTER: 4557 case OP_NULL: 4558 case OP_NEXTSTATE: 4559 kid = kid->op_sibling; 4560 break; 4561 default: 4562 if (kid != cLISTOPo->op_last) 4563 return NULL; 4564 goto last; 4565 } 4566 } while (kid); 4567 if (!kid) 4568 kid = cLISTOPo->op_last; 4569 last: 4570 return search_const(kid); 4571 } 4572 } 4573 4574 return NULL; 4575 } 4576 4577 STATIC OP * 4578 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) 4579 { 4580 dVAR; 4581 LOGOP *logop; 4582 OP *o; 4583 OP *first; 4584 OP *other; 4585 OP *cstop = NULL; 4586 int prepend_not = 0; 4587 4588 PERL_ARGS_ASSERT_NEW_LOGOP; 4589 4590 first = *firstp; 4591 other = *otherp; 4592 4593 if (type == OP_XOR) /* Not short circuit, but here by precedence. */ 4594 return newBINOP(type, flags, scalar(first), scalar(other)); 4595 4596 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP); 4597 4598 scalarboolean(first); 4599 /* optimize AND and OR ops that have NOTs as children */ 4600 if (first->op_type == OP_NOT 4601 && (first->op_flags & OPf_KIDS) 4602 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */ 4603 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */ 4604 && !PL_madskills) { 4605 if (type == OP_AND || type == OP_OR) { 4606 if (type == OP_AND) 4607 type = OP_OR; 4608 else 4609 type = OP_AND; 4610 op_null(first); 4611 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */ 4612 op_null(other); 4613 prepend_not = 1; /* prepend a NOT op later */ 4614 } 4615 } 4616 } 4617 /* search for a constant op that could let us fold the test */ 4618 if ((cstop = search_const(first))) { 4619 if (cstop->op_private & OPpCONST_STRICT) 4620 no_bareword_allowed(cstop); 4621 else if ((cstop->op_private & OPpCONST_BARE)) 4622 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional"); 4623 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) || 4624 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) || 4625 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) { 4626 *firstp = NULL; 4627 if (other->op_type == OP_CONST) 4628 other->op_private |= OPpCONST_SHORTCIRCUIT; 4629 if (PL_madskills) { 4630 OP *newop = newUNOP(OP_NULL, 0, other); 4631 op_getmad(first, newop, '1'); 4632 newop->op_targ = type; /* set "was" field */ 4633 return newop; 4634 } 4635 op_free(first); 4636 if (other->op_type == OP_LEAVE) 4637 other = newUNOP(OP_NULL, OPf_SPECIAL, other); 4638 return other; 4639 } 4640 else { 4641 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */ 4642 const OP *o2 = other; 4643 if ( ! (o2->op_type == OP_LIST 4644 && (( o2 = cUNOPx(o2)->op_first)) 4645 && o2->op_type == OP_PUSHMARK 4646 && (( o2 = o2->op_sibling)) ) 4647 ) 4648 o2 = other; 4649 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV 4650 || o2->op_type == OP_PADHV) 4651 && o2->op_private & OPpLVAL_INTRO 4652 && !(o2->op_private & OPpPAD_STATE)) 4653 { 4654 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), 4655 "Deprecated use of my() in false conditional"); 4656 } 4657 4658 *otherp = NULL; 4659 if (first->op_type == OP_CONST) 4660 first->op_private |= OPpCONST_SHORTCIRCUIT; 4661 if (PL_madskills) { 4662 first = newUNOP(OP_NULL, 0, first); 4663 op_getmad(other, first, '2'); 4664 first->op_targ = type; /* set "was" field */ 4665 } 4666 else 4667 op_free(other); 4668 return first; 4669 } 4670 } 4671 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR 4672 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */ 4673 { 4674 const OP * const k1 = ((UNOP*)first)->op_first; 4675 const OP * const k2 = k1->op_sibling; 4676 OPCODE warnop = 0; 4677 switch (first->op_type) 4678 { 4679 case OP_NULL: 4680 if (k2 && k2->op_type == OP_READLINE 4681 && (k2->op_flags & OPf_STACKED) 4682 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) 4683 { 4684 warnop = k2->op_type; 4685 } 4686 break; 4687 4688 case OP_SASSIGN: 4689 if (k1->op_type == OP_READDIR 4690 || k1->op_type == OP_GLOB 4691 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB) 4692 || k1->op_type == OP_EACH) 4693 { 4694 warnop = ((k1->op_type == OP_NULL) 4695 ? (OPCODE)k1->op_targ : k1->op_type); 4696 } 4697 break; 4698 } 4699 if (warnop) { 4700 const line_t oldline = CopLINE(PL_curcop); 4701 CopLINE_set(PL_curcop, PL_parser->copline); 4702 Perl_warner(aTHX_ packWARN(WARN_MISC), 4703 "Value of %s%s can be \"0\"; test with defined()", 4704 PL_op_desc[warnop], 4705 ((warnop == OP_READLINE || warnop == OP_GLOB) 4706 ? " construct" : "() operator")); 4707 CopLINE_set(PL_curcop, oldline); 4708 } 4709 } 4710 4711 if (!other) 4712 return first; 4713 4714 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN) 4715 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */ 4716 4717 NewOp(1101, logop, 1, LOGOP); 4718 4719 logop->op_type = (OPCODE)type; 4720 logop->op_ppaddr = PL_ppaddr[type]; 4721 logop->op_first = first; 4722 logop->op_flags = (U8)(flags | OPf_KIDS); 4723 logop->op_other = LINKLIST(other); 4724 logop->op_private = (U8)(1 | (flags >> 8)); 4725 4726 /* establish postfix order */ 4727 logop->op_next = LINKLIST(first); 4728 first->op_next = (OP*)logop; 4729 first->op_sibling = other; 4730 4731 CHECKOP(type,logop); 4732 4733 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop); 4734 other->op_next = o; 4735 4736 return o; 4737 } 4738 4739 OP * 4740 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) 4741 { 4742 dVAR; 4743 LOGOP *logop; 4744 OP *start; 4745 OP *o; 4746 OP *cstop; 4747 4748 PERL_ARGS_ASSERT_NEWCONDOP; 4749 4750 if (!falseop) 4751 return newLOGOP(OP_AND, 0, first, trueop); 4752 if (!trueop) 4753 return newLOGOP(OP_OR, 0, first, falseop); 4754 4755 scalarboolean(first); 4756 if ((cstop = search_const(first))) { 4757 /* Left or right arm of the conditional? */ 4758 const bool left = SvTRUE(((SVOP*)cstop)->op_sv); 4759 OP *live = left ? trueop : falseop; 4760 OP *const dead = left ? falseop : trueop; 4761 if (cstop->op_private & OPpCONST_BARE && 4762 cstop->op_private & OPpCONST_STRICT) { 4763 no_bareword_allowed(cstop); 4764 } 4765 if (PL_madskills) { 4766 /* This is all dead code when PERL_MAD is not defined. */ 4767 live = newUNOP(OP_NULL, 0, live); 4768 op_getmad(first, live, 'C'); 4769 op_getmad(dead, live, left ? 'e' : 't'); 4770 } else { 4771 op_free(first); 4772 op_free(dead); 4773 } 4774 if (live->op_type == OP_LEAVE) 4775 live = newUNOP(OP_NULL, OPf_SPECIAL, live); 4776 return live; 4777 } 4778 NewOp(1101, logop, 1, LOGOP); 4779 logop->op_type = OP_COND_EXPR; 4780 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR]; 4781 logop->op_first = first; 4782 logop->op_flags = (U8)(flags | OPf_KIDS); 4783 logop->op_private = (U8)(1 | (flags >> 8)); 4784 logop->op_other = LINKLIST(trueop); 4785 logop->op_next = LINKLIST(falseop); 4786 4787 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */ 4788 logop); 4789 4790 /* establish postfix order */ 4791 start = LINKLIST(first); 4792 first->op_next = (OP*)logop; 4793 4794 first->op_sibling = trueop; 4795 trueop->op_sibling = falseop; 4796 o = newUNOP(OP_NULL, 0, (OP*)logop); 4797 4798 trueop->op_next = falseop->op_next = o; 4799 4800 o->op_next = start; 4801 return o; 4802 } 4803 4804 OP * 4805 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right) 4806 { 4807 dVAR; 4808 LOGOP *range; 4809 OP *flip; 4810 OP *flop; 4811 OP *leftstart; 4812 OP *o; 4813 4814 PERL_ARGS_ASSERT_NEWRANGE; 4815 4816 NewOp(1101, range, 1, LOGOP); 4817 4818 range->op_type = OP_RANGE; 4819 range->op_ppaddr = PL_ppaddr[OP_RANGE]; 4820 range->op_first = left; 4821 range->op_flags = OPf_KIDS; 4822 leftstart = LINKLIST(left); 4823 range->op_other = LINKLIST(right); 4824 range->op_private = (U8)(1 | (flags >> 8)); 4825 4826 left->op_sibling = right; 4827 4828 range->op_next = (OP*)range; 4829 flip = newUNOP(OP_FLIP, flags, (OP*)range); 4830 flop = newUNOP(OP_FLOP, 0, flip); 4831 o = newUNOP(OP_NULL, 0, flop); 4832 linklist(flop); 4833 range->op_next = leftstart; 4834 4835 left->op_next = flip; 4836 right->op_next = flop; 4837 4838 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY); 4839 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV); 4840 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY); 4841 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV); 4842 4843 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0; 4844 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0; 4845 4846 flip->op_next = o; 4847 if (!flip->op_private || !flop->op_private) 4848 linklist(o); /* blow off optimizer unless constant */ 4849 4850 return o; 4851 } 4852 4853 OP * 4854 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) 4855 { 4856 dVAR; 4857 OP* listop; 4858 OP* o; 4859 const bool once = block && block->op_flags & OPf_SPECIAL && 4860 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL); 4861 4862 PERL_UNUSED_ARG(debuggable); 4863 4864 if (expr) { 4865 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv)) 4866 return block; /* do {} while 0 does once */ 4867 if (expr->op_type == OP_READLINE 4868 || expr->op_type == OP_READDIR 4869 || expr->op_type == OP_GLOB 4870 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) { 4871 expr = newUNOP(OP_DEFINED, 0, 4872 newASSIGNOP(0, newDEFSVOP(), 0, expr) ); 4873 } else if (expr->op_flags & OPf_KIDS) { 4874 const OP * const k1 = ((UNOP*)expr)->op_first; 4875 const OP * const k2 = k1 ? k1->op_sibling : NULL; 4876 switch (expr->op_type) { 4877 case OP_NULL: 4878 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR) 4879 && (k2->op_flags & OPf_STACKED) 4880 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) 4881 expr = newUNOP(OP_DEFINED, 0, expr); 4882 break; 4883 4884 case OP_SASSIGN: 4885 if (k1 && (k1->op_type == OP_READDIR 4886 || k1->op_type == OP_GLOB 4887 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB) 4888 || k1->op_type == OP_EACH)) 4889 expr = newUNOP(OP_DEFINED, 0, expr); 4890 break; 4891 } 4892 } 4893 } 4894 4895 /* if block is null, the next append_elem() would put UNSTACK, a scalar 4896 * op, in listop. This is wrong. [perl #27024] */ 4897 if (!block) 4898 block = newOP(OP_NULL, 0); 4899 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0)); 4900 o = new_logop(OP_AND, 0, &expr, &listop); 4901 4902 if (listop) 4903 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o); 4904 4905 if (once && o != listop) 4906 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other; 4907 4908 if (o == listop) 4909 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */ 4910 4911 o->op_flags |= flags; 4912 o = scope(o); 4913 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/ 4914 return o; 4915 } 4916 4917 OP * 4918 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 4919 whileline, OP *expr, OP *block, OP *cont, I32 has_my) 4920 { 4921 dVAR; 4922 OP *redo; 4923 OP *next = NULL; 4924 OP *listop; 4925 OP *o; 4926 U8 loopflags = 0; 4927 4928 PERL_UNUSED_ARG(debuggable); 4929 4930 if (expr) { 4931 if (expr->op_type == OP_READLINE 4932 || expr->op_type == OP_READDIR 4933 || expr->op_type == OP_GLOB 4934 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) { 4935 expr = newUNOP(OP_DEFINED, 0, 4936 newASSIGNOP(0, newDEFSVOP(), 0, expr) ); 4937 } else if (expr->op_flags & OPf_KIDS) { 4938 const OP * const k1 = ((UNOP*)expr)->op_first; 4939 const OP * const k2 = (k1) ? k1->op_sibling : NULL; 4940 switch (expr->op_type) { 4941 case OP_NULL: 4942 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR) 4943 && (k2->op_flags & OPf_STACKED) 4944 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) 4945 expr = newUNOP(OP_DEFINED, 0, expr); 4946 break; 4947 4948 case OP_SASSIGN: 4949 if (k1 && (k1->op_type == OP_READDIR 4950 || k1->op_type == OP_GLOB 4951 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB) 4952 || k1->op_type == OP_EACH)) 4953 expr = newUNOP(OP_DEFINED, 0, expr); 4954 break; 4955 } 4956 } 4957 } 4958 4959 if (!block) 4960 block = newOP(OP_NULL, 0); 4961 else if (cont || has_my) { 4962 block = scope(block); 4963 } 4964 4965 if (cont) { 4966 next = LINKLIST(cont); 4967 } 4968 if (expr) { 4969 OP * const unstack = newOP(OP_UNSTACK, 0); 4970 if (!next) 4971 next = unstack; 4972 cont = append_elem(OP_LINESEQ, cont, unstack); 4973 } 4974 4975 assert(block); 4976 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont); 4977 assert(listop); 4978 redo = LINKLIST(listop); 4979 4980 if (expr) { 4981 PL_parser->copline = (line_t)whileline; 4982 scalar(listop); 4983 o = new_logop(OP_AND, 0, &expr, &listop); 4984 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) { 4985 op_free(expr); /* oops, it's a while (0) */ 4986 op_free((OP*)loop); 4987 return NULL; /* listop already freed by new_logop */ 4988 } 4989 if (listop) 4990 ((LISTOP*)listop)->op_last->op_next = 4991 (o == listop ? redo : LINKLIST(o)); 4992 } 4993 else 4994 o = listop; 4995 4996 if (!loop) { 4997 NewOp(1101,loop,1,LOOP); 4998 loop->op_type = OP_ENTERLOOP; 4999 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP]; 5000 loop->op_private = 0; 5001 loop->op_next = (OP*)loop; 5002 } 5003 5004 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o); 5005 5006 loop->op_redoop = redo; 5007 loop->op_lastop = o; 5008 o->op_private |= loopflags; 5009 5010 if (next) 5011 loop->op_nextop = next; 5012 else 5013 loop->op_nextop = o; 5014 5015 o->op_flags |= flags; 5016 o->op_private |= (flags >> 8); 5017 return o; 5018 } 5019 5020 OP * 5021 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont) 5022 { 5023 dVAR; 5024 LOOP *loop; 5025 OP *wop; 5026 PADOFFSET padoff = 0; 5027 I32 iterflags = 0; 5028 I32 iterpflags = 0; 5029 OP *madsv = NULL; 5030 5031 PERL_ARGS_ASSERT_NEWFOROP; 5032 5033 if (sv) { 5034 if (sv->op_type == OP_RV2SV) { /* symbol table variable */ 5035 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */ 5036 sv->op_type = OP_RV2GV; 5037 sv->op_ppaddr = PL_ppaddr[OP_RV2GV]; 5038 5039 /* The op_type check is needed to prevent a possible segfault 5040 * if the loop variable is undeclared and 'strict vars' is in 5041 * effect. This is illegal but is nonetheless parsed, so we 5042 * may reach this point with an OP_CONST where we're expecting 5043 * an OP_GV. 5044 */ 5045 if (cUNOPx(sv)->op_first->op_type == OP_GV 5046 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv) 5047 iterpflags |= OPpITER_DEF; 5048 } 5049 else if (sv->op_type == OP_PADSV) { /* private variable */ 5050 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */ 5051 padoff = sv->op_targ; 5052 if (PL_madskills) 5053 madsv = sv; 5054 else { 5055 sv->op_targ = 0; 5056 op_free(sv); 5057 } 5058 sv = NULL; 5059 } 5060 else 5061 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]); 5062 if (padoff) { 5063 SV *const namesv = PAD_COMPNAME_SV(padoff); 5064 STRLEN len; 5065 const char *const name = SvPV_const(namesv, len); 5066 5067 if (len == 2 && name[0] == '$' && name[1] == '_') 5068 iterpflags |= OPpITER_DEF; 5069 } 5070 } 5071 else { 5072 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0); 5073 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) { 5074 sv = newGVOP(OP_GV, 0, PL_defgv); 5075 } 5076 else { 5077 padoff = offset; 5078 } 5079 iterpflags |= OPpITER_DEF; 5080 } 5081 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) { 5082 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART); 5083 iterflags |= OPf_STACKED; 5084 } 5085 else if (expr->op_type == OP_NULL && 5086 (expr->op_flags & OPf_KIDS) && 5087 ((BINOP*)expr)->op_first->op_type == OP_FLOP) 5088 { 5089 /* Basically turn for($x..$y) into the same as for($x,$y), but we 5090 * set the STACKED flag to indicate that these values are to be 5091 * treated as min/max values by 'pp_iterinit'. 5092 */ 5093 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first; 5094 LOGOP* const range = (LOGOP*) flip->op_first; 5095 OP* const left = range->op_first; 5096 OP* const right = left->op_sibling; 5097 LISTOP* listop; 5098 5099 range->op_flags &= ~OPf_KIDS; 5100 range->op_first = NULL; 5101 5102 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right); 5103 listop->op_first->op_next = range->op_next; 5104 left->op_next = range->op_other; 5105 right->op_next = (OP*)listop; 5106 listop->op_next = listop->op_first; 5107 5108 #ifdef PERL_MAD 5109 op_getmad(expr,(OP*)listop,'O'); 5110 #else 5111 op_free(expr); 5112 #endif 5113 expr = (OP*)(listop); 5114 op_null(expr); 5115 iterflags |= OPf_STACKED; 5116 } 5117 else { 5118 expr = mod(force_list(expr), OP_GREPSTART); 5119 } 5120 5121 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags, 5122 append_elem(OP_LIST, expr, scalar(sv)))); 5123 assert(!loop->op_next); 5124 /* for my $x () sets OPpLVAL_INTRO; 5125 * for our $x () sets OPpOUR_INTRO */ 5126 loop->op_private = (U8)iterpflags; 5127 #ifdef PL_OP_SLAB_ALLOC 5128 { 5129 LOOP *tmp; 5130 NewOp(1234,tmp,1,LOOP); 5131 Copy(loop,tmp,1,LISTOP); 5132 S_op_destroy(aTHX_ (OP*)loop); 5133 loop = tmp; 5134 } 5135 #else 5136 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP)); 5137 #endif 5138 loop->op_targ = padoff; 5139 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0); 5140 if (madsv) 5141 op_getmad(madsv, (OP*)loop, 'v'); 5142 PL_parser->copline = forline; 5143 return newSTATEOP(0, label, wop); 5144 } 5145 5146 OP* 5147 Perl_newLOOPEX(pTHX_ I32 type, OP *label) 5148 { 5149 dVAR; 5150 OP *o; 5151 5152 PERL_ARGS_ASSERT_NEWLOOPEX; 5153 5154 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP); 5155 5156 if (type != OP_GOTO || label->op_type == OP_CONST) { 5157 /* "last()" means "last" */ 5158 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) 5159 o = newOP(type, OPf_SPECIAL); 5160 else { 5161 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST 5162 ? SvPV_nolen_const(((SVOP*)label)->op_sv) 5163 : "")); 5164 } 5165 #ifdef PERL_MAD 5166 op_getmad(label,o,'L'); 5167 #else 5168 op_free(label); 5169 #endif 5170 } 5171 else { 5172 /* Check whether it's going to be a goto &function */ 5173 if (label->op_type == OP_ENTERSUB 5174 && !(label->op_flags & OPf_STACKED)) 5175 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN)); 5176 o = newUNOP(type, OPf_STACKED, label); 5177 } 5178 PL_hints |= HINT_BLOCK_SCOPE; 5179 return o; 5180 } 5181 5182 /* if the condition is a literal array or hash 5183 (or @{ ... } etc), make a reference to it. 5184 */ 5185 STATIC OP * 5186 S_ref_array_or_hash(pTHX_ OP *cond) 5187 { 5188 if (cond 5189 && (cond->op_type == OP_RV2AV 5190 || cond->op_type == OP_PADAV 5191 || cond->op_type == OP_RV2HV 5192 || cond->op_type == OP_PADHV)) 5193 5194 return newUNOP(OP_REFGEN, 5195 0, mod(cond, OP_REFGEN)); 5196 5197 else 5198 return cond; 5199 } 5200 5201 /* These construct the optree fragments representing given() 5202 and when() blocks. 5203 5204 entergiven and enterwhen are LOGOPs; the op_other pointer 5205 points up to the associated leave op. We need this so we 5206 can put it in the context and make break/continue work. 5207 (Also, of course, pp_enterwhen will jump straight to 5208 op_other if the match fails.) 5209 */ 5210 5211 STATIC OP * 5212 S_newGIVWHENOP(pTHX_ OP *cond, OP *block, 5213 I32 enter_opcode, I32 leave_opcode, 5214 PADOFFSET entertarg) 5215 { 5216 dVAR; 5217 LOGOP *enterop; 5218 OP *o; 5219 5220 PERL_ARGS_ASSERT_NEWGIVWHENOP; 5221 5222 NewOp(1101, enterop, 1, LOGOP); 5223 enterop->op_type = (Optype)enter_opcode; 5224 enterop->op_ppaddr = PL_ppaddr[enter_opcode]; 5225 enterop->op_flags = (U8) OPf_KIDS; 5226 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg); 5227 enterop->op_private = 0; 5228 5229 o = newUNOP(leave_opcode, 0, (OP *) enterop); 5230 5231 if (cond) { 5232 enterop->op_first = scalar(cond); 5233 cond->op_sibling = block; 5234 5235 o->op_next = LINKLIST(cond); 5236 cond->op_next = (OP *) enterop; 5237 } 5238 else { 5239 /* This is a default {} block */ 5240 enterop->op_first = block; 5241 enterop->op_flags |= OPf_SPECIAL; 5242 5243 o->op_next = (OP *) enterop; 5244 } 5245 5246 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since 5247 entergiven and enterwhen both 5248 use ck_null() */ 5249 5250 enterop->op_next = LINKLIST(block); 5251 block->op_next = enterop->op_other = o; 5252 5253 return o; 5254 } 5255 5256 /* Does this look like a boolean operation? For these purposes 5257 a boolean operation is: 5258 - a subroutine call [*] 5259 - a logical connective 5260 - a comparison operator 5261 - a filetest operator, with the exception of -s -M -A -C 5262 - defined(), exists() or eof() 5263 - /$re/ or $foo =~ /$re/ 5264 5265 [*] possibly surprising 5266 */ 5267 STATIC bool 5268 S_looks_like_bool(pTHX_ const OP *o) 5269 { 5270 dVAR; 5271 5272 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL; 5273 5274 switch(o->op_type) { 5275 case OP_OR: 5276 case OP_DOR: 5277 return looks_like_bool(cLOGOPo->op_first); 5278 5279 case OP_AND: 5280 return ( 5281 looks_like_bool(cLOGOPo->op_first) 5282 && looks_like_bool(cLOGOPo->op_first->op_sibling)); 5283 5284 case OP_NULL: 5285 case OP_SCALAR: 5286 return ( 5287 o->op_flags & OPf_KIDS 5288 && looks_like_bool(cUNOPo->op_first)); 5289 5290 case OP_ENTERSUB: 5291 5292 case OP_NOT: case OP_XOR: 5293 5294 case OP_EQ: case OP_NE: case OP_LT: 5295 case OP_GT: case OP_LE: case OP_GE: 5296 5297 case OP_I_EQ: case OP_I_NE: case OP_I_LT: 5298 case OP_I_GT: case OP_I_LE: case OP_I_GE: 5299 5300 case OP_SEQ: case OP_SNE: case OP_SLT: 5301 case OP_SGT: case OP_SLE: case OP_SGE: 5302 5303 case OP_SMARTMATCH: 5304 5305 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC: 5306 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC: 5307 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED: 5308 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR: 5309 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR: 5310 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID: 5311 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY: 5312 case OP_FTTEXT: case OP_FTBINARY: 5313 5314 case OP_DEFINED: case OP_EXISTS: 5315 case OP_MATCH: case OP_EOF: 5316 5317 case OP_FLOP: 5318 5319 return TRUE; 5320 5321 case OP_CONST: 5322 /* Detect comparisons that have been optimized away */ 5323 if (cSVOPo->op_sv == &PL_sv_yes 5324 || cSVOPo->op_sv == &PL_sv_no) 5325 5326 return TRUE; 5327 else 5328 return FALSE; 5329 5330 /* FALL THROUGH */ 5331 default: 5332 return FALSE; 5333 } 5334 } 5335 5336 OP * 5337 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off) 5338 { 5339 dVAR; 5340 PERL_ARGS_ASSERT_NEWGIVENOP; 5341 return newGIVWHENOP( 5342 ref_array_or_hash(cond), 5343 block, 5344 OP_ENTERGIVEN, OP_LEAVEGIVEN, 5345 defsv_off); 5346 } 5347 5348 /* If cond is null, this is a default {} block */ 5349 OP * 5350 Perl_newWHENOP(pTHX_ OP *cond, OP *block) 5351 { 5352 const bool cond_llb = (!cond || looks_like_bool(cond)); 5353 OP *cond_op; 5354 5355 PERL_ARGS_ASSERT_NEWWHENOP; 5356 5357 if (cond_llb) 5358 cond_op = cond; 5359 else { 5360 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL, 5361 newDEFSVOP(), 5362 scalar(ref_array_or_hash(cond))); 5363 } 5364 5365 return newGIVWHENOP( 5366 cond_op, 5367 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)), 5368 OP_ENTERWHEN, OP_LEAVEWHEN, 0); 5369 } 5370 5371 /* 5372 =for apidoc cv_undef 5373 5374 Clear out all the active components of a CV. This can happen either 5375 by an explicit C<undef &foo>, or by the reference count going to zero. 5376 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous 5377 children can still follow the full lexical scope chain. 5378 5379 =cut 5380 */ 5381 5382 void 5383 Perl_cv_undef(pTHX_ CV *cv) 5384 { 5385 dVAR; 5386 5387 PERL_ARGS_ASSERT_CV_UNDEF; 5388 5389 DEBUG_X(PerlIO_printf(Perl_debug_log, 5390 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n", 5391 PTR2UV(cv), PTR2UV(PL_comppad)) 5392 ); 5393 5394 #ifdef USE_ITHREADS 5395 if (CvFILE(cv) && !CvISXSUB(cv)) { 5396 /* for XSUBs CvFILE point directly to static memory; __FILE__ */ 5397 Safefree(CvFILE(cv)); 5398 } 5399 CvFILE(cv) = NULL; 5400 #endif 5401 5402 if (!CvISXSUB(cv) && CvROOT(cv)) { 5403 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv)) 5404 Perl_croak(aTHX_ "Can't undef active subroutine"); 5405 ENTER; 5406 5407 PAD_SAVE_SETNULLPAD(); 5408 5409 op_free(CvROOT(cv)); 5410 CvROOT(cv) = NULL; 5411 CvSTART(cv) = NULL; 5412 LEAVE; 5413 } 5414 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */ 5415 CvGV(cv) = NULL; 5416 5417 pad_undef(cv); 5418 5419 /* remove CvOUTSIDE unless this is an undef rather than a free */ 5420 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) { 5421 if (!CvWEAKOUTSIDE(cv)) 5422 SvREFCNT_dec(CvOUTSIDE(cv)); 5423 CvOUTSIDE(cv) = NULL; 5424 } 5425 if (CvCONST(cv)) { 5426 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr)); 5427 CvCONST_off(cv); 5428 } 5429 if (CvISXSUB(cv) && CvXSUB(cv)) { 5430 CvXSUB(cv) = NULL; 5431 } 5432 /* delete all flags except WEAKOUTSIDE */ 5433 CvFLAGS(cv) &= CVf_WEAKOUTSIDE; 5434 } 5435 5436 void 5437 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p, 5438 const STRLEN len) 5439 { 5440 PERL_ARGS_ASSERT_CV_CKPROTO_LEN; 5441 5442 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by 5443 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */ 5444 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */ 5445 || (p && (len != SvCUR(cv) /* Not the same length. */ 5446 || memNE(p, SvPVX_const(cv), len)))) 5447 && ckWARN_d(WARN_PROTOTYPE)) { 5448 SV* const msg = sv_newmortal(); 5449 SV* name = NULL; 5450 5451 if (gv) 5452 gv_efullname3(name = sv_newmortal(), gv, NULL); 5453 sv_setpvs(msg, "Prototype mismatch:"); 5454 if (name) 5455 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name)); 5456 if (SvPOK(cv)) 5457 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv)); 5458 else 5459 sv_catpvs(msg, ": none"); 5460 sv_catpvs(msg, " vs "); 5461 if (p) 5462 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p); 5463 else 5464 sv_catpvs(msg, "none"); 5465 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg)); 5466 } 5467 } 5468 5469 static void const_sv_xsub(pTHX_ CV* cv); 5470 5471 /* 5472 5473 =head1 Optree Manipulation Functions 5474 5475 =for apidoc cv_const_sv 5476 5477 If C<cv> is a constant sub eligible for inlining. returns the constant 5478 value returned by the sub. Otherwise, returns NULL. 5479 5480 Constant subs can be created with C<newCONSTSUB> or as described in 5481 L<perlsub/"Constant Functions">. 5482 5483 =cut 5484 */ 5485 SV * 5486 Perl_cv_const_sv(pTHX_ const CV *const cv) 5487 { 5488 PERL_UNUSED_CONTEXT; 5489 if (!cv) 5490 return NULL; 5491 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM)) 5492 return NULL; 5493 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL; 5494 } 5495 5496 /* op_const_sv: examine an optree to determine whether it's in-lineable. 5497 * Can be called in 3 ways: 5498 * 5499 * !cv 5500 * look for a single OP_CONST with attached value: return the value 5501 * 5502 * cv && CvCLONE(cv) && !CvCONST(cv) 5503 * 5504 * examine the clone prototype, and if contains only a single 5505 * OP_CONST referencing a pad const, or a single PADSV referencing 5506 * an outer lexical, return a non-zero value to indicate the CV is 5507 * a candidate for "constizing" at clone time 5508 * 5509 * cv && CvCONST(cv) 5510 * 5511 * We have just cloned an anon prototype that was marked as a const 5512 * candidiate. Try to grab the current value, and in the case of 5513 * PADSV, ignore it if it has multiple references. Return the value. 5514 */ 5515 5516 SV * 5517 Perl_op_const_sv(pTHX_ const OP *o, CV *cv) 5518 { 5519 dVAR; 5520 SV *sv = NULL; 5521 5522 if (PL_madskills) 5523 return NULL; 5524 5525 if (!o) 5526 return NULL; 5527 5528 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first) 5529 o = cLISTOPo->op_first->op_sibling; 5530 5531 for (; o; o = o->op_next) { 5532 const OPCODE type = o->op_type; 5533 5534 if (sv && o->op_next == o) 5535 return sv; 5536 if (o->op_next != o) { 5537 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK) 5538 continue; 5539 if (type == OP_DBSTATE) 5540 continue; 5541 } 5542 if (type == OP_LEAVESUB || type == OP_RETURN) 5543 break; 5544 if (sv) 5545 return NULL; 5546 if (type == OP_CONST && cSVOPo->op_sv) 5547 sv = cSVOPo->op_sv; 5548 else if (cv && type == OP_CONST) { 5549 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ); 5550 if (!sv) 5551 return NULL; 5552 } 5553 else if (cv && type == OP_PADSV) { 5554 if (CvCONST(cv)) { /* newly cloned anon */ 5555 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ); 5556 /* the candidate should have 1 ref from this pad and 1 ref 5557 * from the parent */ 5558 if (!sv || SvREFCNT(sv) != 2) 5559 return NULL; 5560 sv = newSVsv(sv); 5561 SvREADONLY_on(sv); 5562 return sv; 5563 } 5564 else { 5565 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE) 5566 sv = &PL_sv_undef; /* an arbitrary non-null value */ 5567 } 5568 } 5569 else { 5570 return NULL; 5571 } 5572 } 5573 return sv; 5574 } 5575 5576 #ifdef PERL_MAD 5577 OP * 5578 #else 5579 void 5580 #endif 5581 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) 5582 { 5583 #if 0 5584 /* This would be the return value, but the return cannot be reached. */ 5585 OP* pegop = newOP(OP_NULL, 0); 5586 #endif 5587 5588 PERL_UNUSED_ARG(floor); 5589 5590 if (o) 5591 SAVEFREEOP(o); 5592 if (proto) 5593 SAVEFREEOP(proto); 5594 if (attrs) 5595 SAVEFREEOP(attrs); 5596 if (block) 5597 SAVEFREEOP(block); 5598 Perl_croak(aTHX_ "\"my sub\" not yet implemented"); 5599 #ifdef PERL_MAD 5600 NORETURN_FUNCTION_END; 5601 #endif 5602 } 5603 5604 CV * 5605 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block) 5606 { 5607 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block); 5608 } 5609 5610 CV * 5611 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) 5612 { 5613 dVAR; 5614 GV *gv; 5615 const char *ps; 5616 STRLEN ps_len; 5617 register CV *cv = NULL; 5618 SV *const_sv; 5619 /* If the subroutine has no body, no attributes, and no builtin attributes 5620 then it's just a sub declaration, and we may be able to get away with 5621 storing with a placeholder scalar in the symbol table, rather than a 5622 full GV and CV. If anything is present then it will take a full CV to 5623 store it. */ 5624 const I32 gv_fetch_flags 5625 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS) 5626 || PL_madskills) 5627 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT; 5628 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL; 5629 bool has_name; 5630 5631 if (proto) { 5632 assert(proto->op_type == OP_CONST); 5633 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len); 5634 } 5635 else 5636 ps = NULL; 5637 5638 if (name) { 5639 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV); 5640 has_name = TRUE; 5641 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) { 5642 SV * const sv = sv_newmortal(); 5643 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]", 5644 PL_curstash ? "__ANON__" : "__ANON__::__ANON__", 5645 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); 5646 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV); 5647 has_name = TRUE; 5648 } else if (PL_curstash) { 5649 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV); 5650 has_name = FALSE; 5651 } else { 5652 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV); 5653 has_name = FALSE; 5654 } 5655 5656 if (!PL_madskills) { 5657 if (o) 5658 SAVEFREEOP(o); 5659 if (proto) 5660 SAVEFREEOP(proto); 5661 if (attrs) 5662 SAVEFREEOP(attrs); 5663 } 5664 5665 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at 5666 maximum a prototype before. */ 5667 if (SvTYPE(gv) > SVt_NULL) { 5668 if (!SvPOK((const SV *)gv) 5669 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1)) 5670 { 5671 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype"); 5672 } 5673 cv_ckproto_len((const CV *)gv, NULL, ps, ps_len); 5674 } 5675 if (ps) 5676 sv_setpvn(MUTABLE_SV(gv), ps, ps_len); 5677 else 5678 sv_setiv(MUTABLE_SV(gv), -1); 5679 5680 SvREFCNT_dec(PL_compcv); 5681 cv = PL_compcv = NULL; 5682 goto done; 5683 } 5684 5685 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv); 5686 5687 if (!block || !ps || *ps || attrs 5688 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS) 5689 #ifdef PERL_MAD 5690 || block->op_type == OP_NULL 5691 #endif 5692 ) 5693 const_sv = NULL; 5694 else 5695 const_sv = op_const_sv(block, NULL); 5696 5697 if (cv) { 5698 const bool exists = CvROOT(cv) || CvXSUB(cv); 5699 5700 /* if the subroutine doesn't exist and wasn't pre-declared 5701 * with a prototype, assume it will be AUTOLOADed, 5702 * skipping the prototype check 5703 */ 5704 if (exists || SvPOK(cv)) 5705 cv_ckproto_len(cv, gv, ps, ps_len); 5706 /* already defined (or promised)? */ 5707 if (exists || GvASSUMECV(gv)) { 5708 if ((!block 5709 #ifdef PERL_MAD 5710 || block->op_type == OP_NULL 5711 #endif 5712 )&& !attrs) { 5713 if (CvFLAGS(PL_compcv)) { 5714 /* might have had built-in attrs applied */ 5715 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && ckWARN(WARN_MISC)) 5716 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined"); 5717 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS & ~CVf_LVALUE); 5718 } 5719 /* just a "sub foo;" when &foo is already defined */ 5720 SAVEFREESV(PL_compcv); 5721 goto done; 5722 } 5723 if (block 5724 #ifdef PERL_MAD 5725 && block->op_type != OP_NULL 5726 #endif 5727 ) { 5728 if (ckWARN(WARN_REDEFINE) 5729 || (CvCONST(cv) 5730 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv)))) 5731 { 5732 const line_t oldline = CopLINE(PL_curcop); 5733 if (PL_parser && PL_parser->copline != NOLINE) 5734 CopLINE_set(PL_curcop, PL_parser->copline); 5735 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), 5736 CvCONST(cv) ? "Constant subroutine %s redefined" 5737 : "Subroutine %s redefined", name); 5738 CopLINE_set(PL_curcop, oldline); 5739 } 5740 #ifdef PERL_MAD 5741 if (!PL_minus_c) /* keep old one around for madskills */ 5742 #endif 5743 { 5744 /* (PL_madskills unset in used file.) */ 5745 SvREFCNT_dec(cv); 5746 } 5747 cv = NULL; 5748 } 5749 } 5750 } 5751 if (const_sv) { 5752 SvREFCNT_inc_simple_void_NN(const_sv); 5753 if (cv) { 5754 assert(!CvROOT(cv) && !CvCONST(cv)); 5755 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */ 5756 CvXSUBANY(cv).any_ptr = const_sv; 5757 CvXSUB(cv) = const_sv_xsub; 5758 CvCONST_on(cv); 5759 CvISXSUB_on(cv); 5760 } 5761 else { 5762 GvCV(gv) = NULL; 5763 cv = newCONSTSUB(NULL, name, const_sv); 5764 } 5765 mro_method_changed_in( /* sub Foo::Bar () { 123 } */ 5766 (CvGV(cv) && GvSTASH(CvGV(cv))) 5767 ? GvSTASH(CvGV(cv)) 5768 : CvSTASH(cv) 5769 ? CvSTASH(cv) 5770 : PL_curstash 5771 ); 5772 if (PL_madskills) 5773 goto install_block; 5774 op_free(block); 5775 SvREFCNT_dec(PL_compcv); 5776 PL_compcv = NULL; 5777 goto done; 5778 } 5779 if (cv) { /* must reuse cv if autoloaded */ 5780 /* transfer PL_compcv to cv */ 5781 if (block 5782 #ifdef PERL_MAD 5783 && block->op_type != OP_NULL 5784 #endif 5785 ) { 5786 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS; 5787 cv_undef(cv); 5788 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs; 5789 if (!CvWEAKOUTSIDE(cv)) 5790 SvREFCNT_dec(CvOUTSIDE(cv)); 5791 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv); 5792 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv); 5793 CvOUTSIDE(PL_compcv) = 0; 5794 CvPADLIST(cv) = CvPADLIST(PL_compcv); 5795 CvPADLIST(PL_compcv) = 0; 5796 /* inner references to PL_compcv must be fixed up ... */ 5797 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv); 5798 if (PERLDB_INTER)/* Advice debugger on the new sub. */ 5799 ++PL_sub_generation; 5800 } 5801 else { 5802 /* Might have had built-in attributes applied -- propagate them. */ 5803 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS); 5804 } 5805 /* ... before we throw it away */ 5806 SvREFCNT_dec(PL_compcv); 5807 PL_compcv = cv; 5808 } 5809 else { 5810 cv = PL_compcv; 5811 if (name) { 5812 GvCV(gv) = cv; 5813 if (PL_madskills) { 5814 if (strEQ(name, "import")) { 5815 PL_formfeed = MUTABLE_SV(cv); 5816 /* diag_listed_as: SKIPME */ 5817 Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv)); 5818 } 5819 } 5820 GvCVGEN(gv) = 0; 5821 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */ 5822 } 5823 } 5824 if (!CvGV(cv)) { 5825 CvGV(cv) = gv; 5826 CvFILE_set_from_cop(cv, PL_curcop); 5827 CvSTASH(cv) = PL_curstash; 5828 } 5829 if (attrs) { 5830 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */ 5831 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash; 5832 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE); 5833 } 5834 5835 if (ps) 5836 sv_setpvn(MUTABLE_SV(cv), ps, ps_len); 5837 5838 if (PL_parser && PL_parser->error_count) { 5839 op_free(block); 5840 block = NULL; 5841 if (name) { 5842 const char *s = strrchr(name, ':'); 5843 s = s ? s+1 : name; 5844 if (strEQ(s, "BEGIN")) { 5845 const char not_safe[] = 5846 "BEGIN not safe after errors--compilation aborted"; 5847 if (PL_in_eval & EVAL_KEEPERR) 5848 Perl_croak(aTHX_ not_safe); 5849 else { 5850 /* force display of errors found but not reported */ 5851 sv_catpv(ERRSV, not_safe); 5852 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV)); 5853 } 5854 } 5855 } 5856 } 5857 install_block: 5858 if (!block) 5859 goto done; 5860 5861 /* If we assign an optree to a PVCV, then we've defined a subroutine that 5862 the debugger could be able to set a breakpoint in, so signal to 5863 pp_entereval that it should not throw away any saved lines at scope 5864 exit. */ 5865 5866 PL_breakable_sub_gen++; 5867 if (CvLVALUE(cv)) { 5868 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0, 5869 mod(scalarseq(block), OP_LEAVESUBLV)); 5870 block->op_attached = 1; 5871 } 5872 else { 5873 /* This makes sub {}; work as expected. */ 5874 if (block->op_type == OP_STUB) { 5875 OP* const newblock = newSTATEOP(0, NULL, 0); 5876 #ifdef PERL_MAD 5877 op_getmad(block,newblock,'B'); 5878 #else 5879 op_free(block); 5880 #endif 5881 block = newblock; 5882 } 5883 else 5884 block->op_attached = 1; 5885 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block)); 5886 } 5887 CvROOT(cv)->op_private |= OPpREFCOUNTED; 5888 OpREFCNT_set(CvROOT(cv), 1); 5889 CvSTART(cv) = LINKLIST(CvROOT(cv)); 5890 CvROOT(cv)->op_next = 0; 5891 CALL_PEEP(CvSTART(cv)); 5892 5893 /* now that optimizer has done its work, adjust pad values */ 5894 5895 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB); 5896 5897 if (CvCLONE(cv)) { 5898 assert(!CvCONST(cv)); 5899 if (ps && !*ps && op_const_sv(block, cv)) 5900 CvCONST_on(cv); 5901 } 5902 5903 if (has_name) { 5904 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) { 5905 SV * const sv = newSV(0); 5906 SV * const tmpstr = sv_newmortal(); 5907 GV * const db_postponed = gv_fetchpvs("DB::postponed", 5908 GV_ADDMULTI, SVt_PVHV); 5909 HV *hv; 5910 5911 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld", 5912 CopFILE(PL_curcop), 5913 (long)PL_subline, (long)CopLINE(PL_curcop)); 5914 gv_efullname3(tmpstr, gv, NULL); 5915 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), 5916 SvCUR(tmpstr), sv, 0); 5917 hv = GvHVn(db_postponed); 5918 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) { 5919 CV * const pcv = GvCV(db_postponed); 5920 if (pcv) { 5921 dSP; 5922 PUSHMARK(SP); 5923 XPUSHs(tmpstr); 5924 PUTBACK; 5925 call_sv(MUTABLE_SV(pcv), G_DISCARD); 5926 } 5927 } 5928 } 5929 5930 if (name && ! (PL_parser && PL_parser->error_count)) 5931 process_special_blocks(name, gv, cv); 5932 } 5933 5934 done: 5935 if (PL_parser) 5936 PL_parser->copline = NOLINE; 5937 LEAVE_SCOPE(floor); 5938 return cv; 5939 } 5940 5941 STATIC void 5942 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv, 5943 CV *const cv) 5944 { 5945 const char *const colon = strrchr(fullname,':'); 5946 const char *const name = colon ? colon + 1 : fullname; 5947 5948 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS; 5949 5950 if (*name == 'B') { 5951 if (strEQ(name, "BEGIN")) { 5952 const I32 oldscope = PL_scopestack_ix; 5953 ENTER; 5954 SAVECOPFILE(&PL_compiling); 5955 SAVECOPLINE(&PL_compiling); 5956 5957 DEBUG_x( dump_sub(gv) ); 5958 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv)); 5959 GvCV(gv) = 0; /* cv has been hijacked */ 5960 call_list(oldscope, PL_beginav); 5961 5962 PL_curcop = &PL_compiling; 5963 CopHINTS_set(&PL_compiling, PL_hints); 5964 LEAVE; 5965 } 5966 else 5967 return; 5968 } else { 5969 if (*name == 'E') { 5970 if strEQ(name, "END") { 5971 DEBUG_x( dump_sub(gv) ); 5972 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv)); 5973 } else 5974 return; 5975 } else if (*name == 'U') { 5976 if (strEQ(name, "UNITCHECK")) { 5977 /* It's never too late to run a unitcheck block */ 5978 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv)); 5979 } 5980 else 5981 return; 5982 } else if (*name == 'C') { 5983 if (strEQ(name, "CHECK")) { 5984 if (PL_main_start) 5985 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), 5986 "Too late to run CHECK block"); 5987 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv)); 5988 } 5989 else 5990 return; 5991 } else if (*name == 'I') { 5992 if (strEQ(name, "INIT")) { 5993 if (PL_main_start) 5994 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), 5995 "Too late to run INIT block"); 5996 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv)); 5997 } 5998 else 5999 return; 6000 } else 6001 return; 6002 DEBUG_x( dump_sub(gv) ); 6003 GvCV(gv) = 0; /* cv has been hijacked */ 6004 } 6005 } 6006 6007 /* 6008 =for apidoc newCONSTSUB 6009 6010 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is 6011 eligible for inlining at compile-time. 6012 6013 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>, 6014 which won't be called if used as a destructor, but will suppress the overhead 6015 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at 6016 compile time.) 6017 6018 =cut 6019 */ 6020 6021 CV * 6022 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv) 6023 { 6024 dVAR; 6025 CV* cv; 6026 #ifdef USE_ITHREADS 6027 const char *const file = CopFILE(PL_curcop); 6028 #else 6029 SV *const temp_sv = CopFILESV(PL_curcop); 6030 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL; 6031 #endif 6032 6033 ENTER; 6034 6035 if (IN_PERL_RUNTIME) { 6036 /* at runtime, it's not safe to manipulate PL_curcop: it may be 6037 * an op shared between threads. Use a non-shared COP for our 6038 * dirty work */ 6039 SAVEVPTR(PL_curcop); 6040 PL_curcop = &PL_compiling; 6041 } 6042 SAVECOPLINE(PL_curcop); 6043 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE); 6044 6045 SAVEHINTS(); 6046 PL_hints &= ~HINT_BLOCK_SCOPE; 6047 6048 if (stash) { 6049 SAVESPTR(PL_curstash); 6050 SAVECOPSTASH(PL_curcop); 6051 PL_curstash = stash; 6052 CopSTASH_set(PL_curcop,stash); 6053 } 6054 6055 /* file becomes the CvFILE. For an XS, it's supposed to be static storage, 6056 and so doesn't get free()d. (It's expected to be from the C pre- 6057 processor __FILE__ directive). But we need a dynamically allocated one, 6058 and we need it to get freed. */ 6059 cv = newXS_flags(name, const_sv_xsub, file ? file : "", "", 6060 XS_DYNAMIC_FILENAME); 6061 CvXSUBANY(cv).any_ptr = sv; 6062 CvCONST_on(cv); 6063 6064 #ifdef USE_ITHREADS 6065 if (stash) 6066 CopSTASH_free(PL_curcop); 6067 #endif 6068 LEAVE; 6069 6070 return cv; 6071 } 6072 6073 CV * 6074 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr, 6075 const char *const filename, const char *const proto, 6076 U32 flags) 6077 { 6078 CV *cv = newXS(name, subaddr, filename); 6079 6080 PERL_ARGS_ASSERT_NEWXS_FLAGS; 6081 6082 if (flags & XS_DYNAMIC_FILENAME) { 6083 /* We need to "make arrangements" (ie cheat) to ensure that the 6084 filename lasts as long as the PVCV we just created, but also doesn't 6085 leak */ 6086 STRLEN filename_len = strlen(filename); 6087 STRLEN proto_and_file_len = filename_len; 6088 char *proto_and_file; 6089 STRLEN proto_len; 6090 6091 if (proto) { 6092 proto_len = strlen(proto); 6093 proto_and_file_len += proto_len; 6094 6095 Newx(proto_and_file, proto_and_file_len + 1, char); 6096 Copy(proto, proto_and_file, proto_len, char); 6097 Copy(filename, proto_and_file + proto_len, filename_len + 1, char); 6098 } else { 6099 proto_len = 0; 6100 proto_and_file = savepvn(filename, filename_len); 6101 } 6102 6103 /* This gets free()d. :-) */ 6104 sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len, 6105 SV_HAS_TRAILING_NUL); 6106 if (proto) { 6107 /* This gives us the correct prototype, rather than one with the 6108 file name appended. */ 6109 SvCUR_set(cv, proto_len); 6110 } else { 6111 SvPOK_off(cv); 6112 } 6113 CvFILE(cv) = proto_and_file + proto_len; 6114 } else { 6115 sv_setpv(MUTABLE_SV(cv), proto); 6116 } 6117 return cv; 6118 } 6119 6120 /* 6121 =for apidoc U||newXS 6122 6123 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be 6124 static storage, as it is used directly as CvFILE(), without a copy being made. 6125 6126 =cut 6127 */ 6128 6129 CV * 6130 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename) 6131 { 6132 dVAR; 6133 GV * const gv = gv_fetchpv(name ? name : 6134 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"), 6135 GV_ADDMULTI, SVt_PVCV); 6136 register CV *cv; 6137 6138 PERL_ARGS_ASSERT_NEWXS; 6139 6140 if (!subaddr) 6141 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename); 6142 6143 if ((cv = (name ? GvCV(gv) : NULL))) { 6144 if (GvCVGEN(gv)) { 6145 /* just a cached method */ 6146 SvREFCNT_dec(cv); 6147 cv = NULL; 6148 } 6149 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) { 6150 /* already defined (or promised) */ 6151 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */ 6152 if (ckWARN(WARN_REDEFINE)) { 6153 GV * const gvcv = CvGV(cv); 6154 if (gvcv) { 6155 HV * const stash = GvSTASH(gvcv); 6156 if (stash) { 6157 const char *redefined_name = HvNAME_get(stash); 6158 if ( strEQ(redefined_name,"autouse") ) { 6159 const line_t oldline = CopLINE(PL_curcop); 6160 if (PL_parser && PL_parser->copline != NOLINE) 6161 CopLINE_set(PL_curcop, PL_parser->copline); 6162 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), 6163 CvCONST(cv) ? "Constant subroutine %s redefined" 6164 : "Subroutine %s redefined" 6165 ,name); 6166 CopLINE_set(PL_curcop, oldline); 6167 } 6168 } 6169 } 6170 } 6171 SvREFCNT_dec(cv); 6172 cv = NULL; 6173 } 6174 } 6175 6176 if (cv) /* must reuse cv if autoloaded */ 6177 cv_undef(cv); 6178 else { 6179 cv = MUTABLE_CV(newSV_type(SVt_PVCV)); 6180 if (name) { 6181 GvCV(gv) = cv; 6182 GvCVGEN(gv) = 0; 6183 mro_method_changed_in(GvSTASH(gv)); /* newXS */ 6184 } 6185 } 6186 CvGV(cv) = gv; 6187 (void)gv_fetchfile(filename); 6188 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be 6189 an external constant string */ 6190 CvISXSUB_on(cv); 6191 CvXSUB(cv) = subaddr; 6192 6193 if (name) 6194 process_special_blocks(name, gv, cv); 6195 else 6196 CvANON_on(cv); 6197 6198 return cv; 6199 } 6200 6201 #ifdef PERL_MAD 6202 OP * 6203 #else 6204 void 6205 #endif 6206 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) 6207 { 6208 dVAR; 6209 register CV *cv; 6210 #ifdef PERL_MAD 6211 OP* pegop = newOP(OP_NULL, 0); 6212 #endif 6213 6214 GV * const gv = o 6215 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM) 6216 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM); 6217 6218 GvMULTI_on(gv); 6219 if ((cv = GvFORM(gv))) { 6220 if (ckWARN(WARN_REDEFINE)) { 6221 const line_t oldline = CopLINE(PL_curcop); 6222 if (PL_parser && PL_parser->copline != NOLINE) 6223 CopLINE_set(PL_curcop, PL_parser->copline); 6224 if (o) { 6225 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), 6226 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv)); 6227 } else { 6228 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), 6229 "Format STDOUT redefined"); 6230 } 6231 CopLINE_set(PL_curcop, oldline); 6232 } 6233 SvREFCNT_dec(cv); 6234 } 6235 cv = PL_compcv; 6236 GvFORM(gv) = cv; 6237 CvGV(cv) = gv; 6238 CvFILE_set_from_cop(cv, PL_curcop); 6239 6240 6241 pad_tidy(padtidy_FORMAT); 6242 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block)); 6243 CvROOT(cv)->op_private |= OPpREFCOUNTED; 6244 OpREFCNT_set(CvROOT(cv), 1); 6245 CvSTART(cv) = LINKLIST(CvROOT(cv)); 6246 CvROOT(cv)->op_next = 0; 6247 CALL_PEEP(CvSTART(cv)); 6248 #ifdef PERL_MAD 6249 op_getmad(o,pegop,'n'); 6250 op_getmad_weak(block, pegop, 'b'); 6251 #else 6252 op_free(o); 6253 #endif 6254 if (PL_parser) 6255 PL_parser->copline = NOLINE; 6256 LEAVE_SCOPE(floor); 6257 #ifdef PERL_MAD 6258 return pegop; 6259 #endif 6260 } 6261 6262 OP * 6263 Perl_newANONLIST(pTHX_ OP *o) 6264 { 6265 return convert(OP_ANONLIST, OPf_SPECIAL, o); 6266 } 6267 6268 OP * 6269 Perl_newANONHASH(pTHX_ OP *o) 6270 { 6271 return convert(OP_ANONHASH, OPf_SPECIAL, o); 6272 } 6273 6274 OP * 6275 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block) 6276 { 6277 return newANONATTRSUB(floor, proto, NULL, block); 6278 } 6279 6280 OP * 6281 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block) 6282 { 6283 return newUNOP(OP_REFGEN, 0, 6284 newSVOP(OP_ANONCODE, 0, 6285 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block)))); 6286 } 6287 6288 OP * 6289 Perl_oopsAV(pTHX_ OP *o) 6290 { 6291 dVAR; 6292 6293 PERL_ARGS_ASSERT_OOPSAV; 6294 6295 switch (o->op_type) { 6296 case OP_PADSV: 6297 o->op_type = OP_PADAV; 6298 o->op_ppaddr = PL_ppaddr[OP_PADAV]; 6299 return ref(o, OP_RV2AV); 6300 6301 case OP_RV2SV: 6302 o->op_type = OP_RV2AV; 6303 o->op_ppaddr = PL_ppaddr[OP_RV2AV]; 6304 ref(o, OP_RV2AV); 6305 break; 6306 6307 default: 6308 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV"); 6309 break; 6310 } 6311 return o; 6312 } 6313 6314 OP * 6315 Perl_oopsHV(pTHX_ OP *o) 6316 { 6317 dVAR; 6318 6319 PERL_ARGS_ASSERT_OOPSHV; 6320 6321 switch (o->op_type) { 6322 case OP_PADSV: 6323 case OP_PADAV: 6324 o->op_type = OP_PADHV; 6325 o->op_ppaddr = PL_ppaddr[OP_PADHV]; 6326 return ref(o, OP_RV2HV); 6327 6328 case OP_RV2SV: 6329 case OP_RV2AV: 6330 o->op_type = OP_RV2HV; 6331 o->op_ppaddr = PL_ppaddr[OP_RV2HV]; 6332 ref(o, OP_RV2HV); 6333 break; 6334 6335 default: 6336 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV"); 6337 break; 6338 } 6339 return o; 6340 } 6341 6342 OP * 6343 Perl_newAVREF(pTHX_ OP *o) 6344 { 6345 dVAR; 6346 6347 PERL_ARGS_ASSERT_NEWAVREF; 6348 6349 if (o->op_type == OP_PADANY) { 6350 o->op_type = OP_PADAV; 6351 o->op_ppaddr = PL_ppaddr[OP_PADAV]; 6352 return o; 6353 } 6354 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) { 6355 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), 6356 "Using an array as a reference is deprecated"); 6357 } 6358 return newUNOP(OP_RV2AV, 0, scalar(o)); 6359 } 6360 6361 OP * 6362 Perl_newGVREF(pTHX_ I32 type, OP *o) 6363 { 6364 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT) 6365 return newUNOP(OP_NULL, 0, o); 6366 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type); 6367 } 6368 6369 OP * 6370 Perl_newHVREF(pTHX_ OP *o) 6371 { 6372 dVAR; 6373 6374 PERL_ARGS_ASSERT_NEWHVREF; 6375 6376 if (o->op_type == OP_PADANY) { 6377 o->op_type = OP_PADHV; 6378 o->op_ppaddr = PL_ppaddr[OP_PADHV]; 6379 return o; 6380 } 6381 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) { 6382 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), 6383 "Using a hash as a reference is deprecated"); 6384 } 6385 return newUNOP(OP_RV2HV, 0, scalar(o)); 6386 } 6387 6388 OP * 6389 Perl_newCVREF(pTHX_ I32 flags, OP *o) 6390 { 6391 return newUNOP(OP_RV2CV, flags, scalar(o)); 6392 } 6393 6394 OP * 6395 Perl_newSVREF(pTHX_ OP *o) 6396 { 6397 dVAR; 6398 6399 PERL_ARGS_ASSERT_NEWSVREF; 6400 6401 if (o->op_type == OP_PADANY) { 6402 o->op_type = OP_PADSV; 6403 o->op_ppaddr = PL_ppaddr[OP_PADSV]; 6404 return o; 6405 } 6406 return newUNOP(OP_RV2SV, 0, scalar(o)); 6407 } 6408 6409 /* Check routines. See the comments at the top of this file for details 6410 * on when these are called */ 6411 6412 OP * 6413 Perl_ck_anoncode(pTHX_ OP *o) 6414 { 6415 PERL_ARGS_ASSERT_CK_ANONCODE; 6416 6417 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type); 6418 if (!PL_madskills) 6419 cSVOPo->op_sv = NULL; 6420 return o; 6421 } 6422 6423 OP * 6424 Perl_ck_bitop(pTHX_ OP *o) 6425 { 6426 dVAR; 6427 6428 PERL_ARGS_ASSERT_CK_BITOP; 6429 6430 #define OP_IS_NUMCOMPARE(op) \ 6431 ((op) == OP_LT || (op) == OP_I_LT || \ 6432 (op) == OP_GT || (op) == OP_I_GT || \ 6433 (op) == OP_LE || (op) == OP_I_LE || \ 6434 (op) == OP_GE || (op) == OP_I_GE || \ 6435 (op) == OP_EQ || (op) == OP_I_EQ || \ 6436 (op) == OP_NE || (op) == OP_I_NE || \ 6437 (op) == OP_NCMP || (op) == OP_I_NCMP) 6438 o->op_private = (U8)(PL_hints & HINT_INTEGER); 6439 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */ 6440 && (o->op_type == OP_BIT_OR 6441 || o->op_type == OP_BIT_AND 6442 || o->op_type == OP_BIT_XOR)) 6443 { 6444 const OP * const left = cBINOPo->op_first; 6445 const OP * const right = left->op_sibling; 6446 if ((OP_IS_NUMCOMPARE(left->op_type) && 6447 (left->op_flags & OPf_PARENS) == 0) || 6448 (OP_IS_NUMCOMPARE(right->op_type) && 6449 (right->op_flags & OPf_PARENS) == 0)) 6450 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE), 6451 "Possible precedence problem on bitwise %c operator", 6452 o->op_type == OP_BIT_OR ? '|' 6453 : o->op_type == OP_BIT_AND ? '&' : '^' 6454 ); 6455 } 6456 return o; 6457 } 6458 6459 OP * 6460 Perl_ck_concat(pTHX_ OP *o) 6461 { 6462 const OP * const kid = cUNOPo->op_first; 6463 6464 PERL_ARGS_ASSERT_CK_CONCAT; 6465 PERL_UNUSED_CONTEXT; 6466 6467 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) && 6468 !(kUNOP->op_first->op_flags & OPf_MOD)) 6469 o->op_flags |= OPf_STACKED; 6470 return o; 6471 } 6472 6473 OP * 6474 Perl_ck_spair(pTHX_ OP *o) 6475 { 6476 dVAR; 6477 6478 PERL_ARGS_ASSERT_CK_SPAIR; 6479 6480 if (o->op_flags & OPf_KIDS) { 6481 OP* newop; 6482 OP* kid; 6483 const OPCODE type = o->op_type; 6484 o = modkids(ck_fun(o), type); 6485 kid = cUNOPo->op_first; 6486 newop = kUNOP->op_first->op_sibling; 6487 if (newop) { 6488 const OPCODE type = newop->op_type; 6489 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) || 6490 type == OP_PADAV || type == OP_PADHV || 6491 type == OP_RV2AV || type == OP_RV2HV) 6492 return o; 6493 } 6494 #ifdef PERL_MAD 6495 op_getmad(kUNOP->op_first,newop,'K'); 6496 #else 6497 op_free(kUNOP->op_first); 6498 #endif 6499 kUNOP->op_first = newop; 6500 } 6501 o->op_ppaddr = PL_ppaddr[++o->op_type]; 6502 return ck_fun(o); 6503 } 6504 6505 OP * 6506 Perl_ck_delete(pTHX_ OP *o) 6507 { 6508 PERL_ARGS_ASSERT_CK_DELETE; 6509 6510 o = ck_fun(o); 6511 o->op_private = 0; 6512 if (o->op_flags & OPf_KIDS) { 6513 OP * const kid = cUNOPo->op_first; 6514 switch (kid->op_type) { 6515 case OP_ASLICE: 6516 o->op_flags |= OPf_SPECIAL; 6517 /* FALL THROUGH */ 6518 case OP_HSLICE: 6519 o->op_private |= OPpSLICE; 6520 break; 6521 case OP_AELEM: 6522 o->op_flags |= OPf_SPECIAL; 6523 /* FALL THROUGH */ 6524 case OP_HELEM: 6525 break; 6526 default: 6527 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice", 6528 OP_DESC(o)); 6529 } 6530 if (kid->op_private & OPpLVAL_INTRO) 6531 o->op_private |= OPpLVAL_INTRO; 6532 op_null(kid); 6533 } 6534 return o; 6535 } 6536 6537 OP * 6538 Perl_ck_die(pTHX_ OP *o) 6539 { 6540 PERL_ARGS_ASSERT_CK_DIE; 6541 6542 #ifdef VMS 6543 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH; 6544 #endif 6545 return ck_fun(o); 6546 } 6547 6548 OP * 6549 Perl_ck_eof(pTHX_ OP *o) 6550 { 6551 dVAR; 6552 6553 PERL_ARGS_ASSERT_CK_EOF; 6554 6555 if (o->op_flags & OPf_KIDS) { 6556 if (cLISTOPo->op_first->op_type == OP_STUB) { 6557 OP * const newop 6558 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv)); 6559 #ifdef PERL_MAD 6560 op_getmad(o,newop,'O'); 6561 #else 6562 op_free(o); 6563 #endif 6564 o = newop; 6565 } 6566 return ck_fun(o); 6567 } 6568 return o; 6569 } 6570 6571 OP * 6572 Perl_ck_eval(pTHX_ OP *o) 6573 { 6574 dVAR; 6575 6576 PERL_ARGS_ASSERT_CK_EVAL; 6577 6578 PL_hints |= HINT_BLOCK_SCOPE; 6579 if (o->op_flags & OPf_KIDS) { 6580 SVOP * const kid = (SVOP*)cUNOPo->op_first; 6581 6582 if (!kid) { 6583 o->op_flags &= ~OPf_KIDS; 6584 op_null(o); 6585 } 6586 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) { 6587 LOGOP *enter; 6588 #ifdef PERL_MAD 6589 OP* const oldo = o; 6590 #endif 6591 6592 cUNOPo->op_first = 0; 6593 #ifndef PERL_MAD 6594 op_free(o); 6595 #endif 6596 6597 NewOp(1101, enter, 1, LOGOP); 6598 enter->op_type = OP_ENTERTRY; 6599 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY]; 6600 enter->op_private = 0; 6601 6602 /* establish postfix order */ 6603 enter->op_next = (OP*)enter; 6604 6605 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid); 6606 o->op_type = OP_LEAVETRY; 6607 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY]; 6608 enter->op_other = o; 6609 op_getmad(oldo,o,'O'); 6610 return o; 6611 } 6612 else { 6613 scalar((OP*)kid); 6614 PL_cv_has_eval = 1; 6615 } 6616 } 6617 else { 6618 #ifdef PERL_MAD 6619 OP* const oldo = o; 6620 #else 6621 op_free(o); 6622 #endif 6623 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP()); 6624 op_getmad(oldo,o,'O'); 6625 } 6626 o->op_targ = (PADOFFSET)PL_hints; 6627 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) { 6628 /* Store a copy of %^H that pp_entereval can pick up. */ 6629 OP *hhop = newSVOP(OP_HINTSEVAL, 0, 6630 MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)))); 6631 cUNOPo->op_first->op_sibling = hhop; 6632 o->op_private |= OPpEVAL_HAS_HH; 6633 } 6634 return o; 6635 } 6636 6637 OP * 6638 Perl_ck_exit(pTHX_ OP *o) 6639 { 6640 PERL_ARGS_ASSERT_CK_EXIT; 6641 6642 #ifdef VMS 6643 HV * const table = GvHV(PL_hintgv); 6644 if (table) { 6645 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE); 6646 if (svp && *svp && SvTRUE(*svp)) 6647 o->op_private |= OPpEXIT_VMSISH; 6648 } 6649 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH; 6650 #endif 6651 return ck_fun(o); 6652 } 6653 6654 OP * 6655 Perl_ck_exec(pTHX_ OP *o) 6656 { 6657 PERL_ARGS_ASSERT_CK_EXEC; 6658 6659 if (o->op_flags & OPf_STACKED) { 6660 OP *kid; 6661 o = ck_fun(o); 6662 kid = cUNOPo->op_first->op_sibling; 6663 if (kid->op_type == OP_RV2GV) 6664 op_null(kid); 6665 } 6666 else 6667 o = listkids(o); 6668 return o; 6669 } 6670 6671 OP * 6672 Perl_ck_exists(pTHX_ OP *o) 6673 { 6674 dVAR; 6675 6676 PERL_ARGS_ASSERT_CK_EXISTS; 6677 6678 o = ck_fun(o); 6679 if (o->op_flags & OPf_KIDS) { 6680 OP * const kid = cUNOPo->op_first; 6681 if (kid->op_type == OP_ENTERSUB) { 6682 (void) ref(kid, o->op_type); 6683 if (kid->op_type != OP_RV2CV 6684 && !(PL_parser && PL_parser->error_count)) 6685 Perl_croak(aTHX_ "%s argument is not a subroutine name", 6686 OP_DESC(o)); 6687 o->op_private |= OPpEXISTS_SUB; 6688 } 6689 else if (kid->op_type == OP_AELEM) 6690 o->op_flags |= OPf_SPECIAL; 6691 else if (kid->op_type != OP_HELEM) 6692 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine", 6693 OP_DESC(o)); 6694 op_null(kid); 6695 } 6696 return o; 6697 } 6698 6699 OP * 6700 Perl_ck_rvconst(pTHX_ register OP *o) 6701 { 6702 dVAR; 6703 SVOP * const kid = (SVOP*)cUNOPo->op_first; 6704 6705 PERL_ARGS_ASSERT_CK_RVCONST; 6706 6707 o->op_private |= (PL_hints & HINT_STRICT_REFS); 6708 if (o->op_type == OP_RV2CV) 6709 o->op_private &= ~1; 6710 6711 if (kid->op_type == OP_CONST) { 6712 int iscv; 6713 GV *gv; 6714 SV * const kidsv = kid->op_sv; 6715 6716 /* Is it a constant from cv_const_sv()? */ 6717 if (SvROK(kidsv) && SvREADONLY(kidsv)) { 6718 SV * const rsv = SvRV(kidsv); 6719 const svtype type = SvTYPE(rsv); 6720 const char *badtype = NULL; 6721 6722 switch (o->op_type) { 6723 case OP_RV2SV: 6724 if (type > SVt_PVMG) 6725 badtype = "a SCALAR"; 6726 break; 6727 case OP_RV2AV: 6728 if (type != SVt_PVAV) 6729 badtype = "an ARRAY"; 6730 break; 6731 case OP_RV2HV: 6732 if (type != SVt_PVHV) 6733 badtype = "a HASH"; 6734 break; 6735 case OP_RV2CV: 6736 if (type != SVt_PVCV) 6737 badtype = "a CODE"; 6738 break; 6739 } 6740 if (badtype) 6741 Perl_croak(aTHX_ "Constant is not %s reference", badtype); 6742 return o; 6743 } 6744 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) && 6745 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) { 6746 /* If this is an access to a stash, disable "strict refs", because 6747 * stashes aren't auto-vivified at compile-time (unless we store 6748 * symbols in them), and we don't want to produce a run-time 6749 * stricture error when auto-vivifying the stash. */ 6750 const char *s = SvPV_nolen(kidsv); 6751 const STRLEN l = SvCUR(kidsv); 6752 if (l > 1 && s[l-1] == ':' && s[l-2] == ':') 6753 o->op_private &= ~HINT_STRICT_REFS; 6754 } 6755 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) { 6756 const char *badthing; 6757 switch (o->op_type) { 6758 case OP_RV2SV: 6759 badthing = "a SCALAR"; 6760 break; 6761 case OP_RV2AV: 6762 badthing = "an ARRAY"; 6763 break; 6764 case OP_RV2HV: 6765 badthing = "a HASH"; 6766 break; 6767 default: 6768 badthing = NULL; 6769 break; 6770 } 6771 if (badthing) 6772 Perl_croak(aTHX_ 6773 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use", 6774 SVfARG(kidsv), badthing); 6775 } 6776 /* 6777 * This is a little tricky. We only want to add the symbol if we 6778 * didn't add it in the lexer. Otherwise we get duplicate strict 6779 * warnings. But if we didn't add it in the lexer, we must at 6780 * least pretend like we wanted to add it even if it existed before, 6781 * or we get possible typo warnings. OPpCONST_ENTERED says 6782 * whether the lexer already added THIS instance of this symbol. 6783 */ 6784 iscv = (o->op_type == OP_RV2CV) * 2; 6785 do { 6786 gv = gv_fetchsv(kidsv, 6787 iscv | !(kid->op_private & OPpCONST_ENTERED), 6788 iscv 6789 ? SVt_PVCV 6790 : o->op_type == OP_RV2SV 6791 ? SVt_PV 6792 : o->op_type == OP_RV2AV 6793 ? SVt_PVAV 6794 : o->op_type == OP_RV2HV 6795 ? SVt_PVHV 6796 : SVt_PVGV); 6797 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++); 6798 if (gv) { 6799 kid->op_type = OP_GV; 6800 SvREFCNT_dec(kid->op_sv); 6801 #ifdef USE_ITHREADS 6802 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */ 6803 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP); 6804 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix)); 6805 GvIN_PAD_on(gv); 6806 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv))); 6807 #else 6808 kid->op_sv = SvREFCNT_inc_simple_NN(gv); 6809 #endif 6810 kid->op_private = 0; 6811 kid->op_ppaddr = PL_ppaddr[OP_GV]; 6812 } 6813 } 6814 return o; 6815 } 6816 6817 OP * 6818 Perl_ck_ftst(pTHX_ OP *o) 6819 { 6820 dVAR; 6821 const I32 type = o->op_type; 6822 6823 PERL_ARGS_ASSERT_CK_FTST; 6824 6825 if (o->op_flags & OPf_REF) { 6826 NOOP; 6827 } 6828 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) { 6829 SVOP * const kid = (SVOP*)cUNOPo->op_first; 6830 const OPCODE kidtype = kid->op_type; 6831 6832 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) { 6833 OP * const newop = newGVOP(type, OPf_REF, 6834 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO)); 6835 #ifdef PERL_MAD 6836 op_getmad(o,newop,'O'); 6837 #else 6838 op_free(o); 6839 #endif 6840 return newop; 6841 } 6842 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type)) 6843 o->op_private |= OPpFT_ACCESS; 6844 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst) 6845 && kidtype != OP_STAT && kidtype != OP_LSTAT) 6846 o->op_private |= OPpFT_STACKED; 6847 } 6848 else { 6849 #ifdef PERL_MAD 6850 OP* const oldo = o; 6851 #else 6852 op_free(o); 6853 #endif 6854 if (type == OP_FTTTY) 6855 o = newGVOP(type, OPf_REF, PL_stdingv); 6856 else 6857 o = newUNOP(type, 0, newDEFSVOP()); 6858 op_getmad(oldo,o,'O'); 6859 } 6860 return o; 6861 } 6862 6863 OP * 6864 Perl_ck_fun(pTHX_ OP *o) 6865 { 6866 dVAR; 6867 const int type = o->op_type; 6868 register I32 oa = PL_opargs[type] >> OASHIFT; 6869 6870 PERL_ARGS_ASSERT_CK_FUN; 6871 6872 if (o->op_flags & OPf_STACKED) { 6873 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL)) 6874 oa &= ~OA_OPTIONAL; 6875 else 6876 return no_fh_allowed(o); 6877 } 6878 6879 if (o->op_flags & OPf_KIDS) { 6880 OP **tokid = &cLISTOPo->op_first; 6881 register OP *kid = cLISTOPo->op_first; 6882 OP *sibl; 6883 I32 numargs = 0; 6884 6885 if (kid->op_type == OP_PUSHMARK || 6886 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK)) 6887 { 6888 tokid = &kid->op_sibling; 6889 kid = kid->op_sibling; 6890 } 6891 if (!kid && PL_opargs[type] & OA_DEFGV) 6892 *tokid = kid = newDEFSVOP(); 6893 6894 while (oa && kid) { 6895 numargs++; 6896 sibl = kid->op_sibling; 6897 #ifdef PERL_MAD 6898 if (!sibl && kid->op_type == OP_STUB) { 6899 numargs--; 6900 break; 6901 } 6902 #endif 6903 switch (oa & 7) { 6904 case OA_SCALAR: 6905 /* list seen where single (scalar) arg expected? */ 6906 if (numargs == 1 && !(oa >> 4) 6907 && kid->op_type == OP_LIST && type != OP_SCALAR) 6908 { 6909 return too_many_arguments(o,PL_op_desc[type]); 6910 } 6911 scalar(kid); 6912 break; 6913 case OA_LIST: 6914 if (oa < 16) { 6915 kid = 0; 6916 continue; 6917 } 6918 else 6919 list(kid); 6920 break; 6921 case OA_AVREF: 6922 if ((type == OP_PUSH || type == OP_UNSHIFT) 6923 && !kid->op_sibling) 6924 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), 6925 "Useless use of %s with no values", 6926 PL_op_desc[type]); 6927 6928 if (kid->op_type == OP_CONST && 6929 (kid->op_private & OPpCONST_BARE)) 6930 { 6931 OP * const newop = newAVREF(newGVOP(OP_GV, 0, 6932 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) )); 6933 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), 6934 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()", 6935 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]); 6936 #ifdef PERL_MAD 6937 op_getmad(kid,newop,'K'); 6938 #else 6939 op_free(kid); 6940 #endif 6941 kid = newop; 6942 kid->op_sibling = sibl; 6943 *tokid = kid; 6944 } 6945 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) 6946 bad_type(numargs, "array", PL_op_desc[type], kid); 6947 mod(kid, type); 6948 break; 6949 case OA_HVREF: 6950 if (kid->op_type == OP_CONST && 6951 (kid->op_private & OPpCONST_BARE)) 6952 { 6953 OP * const newop = newHVREF(newGVOP(OP_GV, 0, 6954 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) )); 6955 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), 6956 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()", 6957 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]); 6958 #ifdef PERL_MAD 6959 op_getmad(kid,newop,'K'); 6960 #else 6961 op_free(kid); 6962 #endif 6963 kid = newop; 6964 kid->op_sibling = sibl; 6965 *tokid = kid; 6966 } 6967 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV) 6968 bad_type(numargs, "hash", PL_op_desc[type], kid); 6969 mod(kid, type); 6970 break; 6971 case OA_CVREF: 6972 { 6973 OP * const newop = newUNOP(OP_NULL, 0, kid); 6974 kid->op_sibling = 0; 6975 linklist(kid); 6976 newop->op_next = newop; 6977 kid = newop; 6978 kid->op_sibling = sibl; 6979 *tokid = kid; 6980 } 6981 break; 6982 case OA_FILEREF: 6983 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) { 6984 if (kid->op_type == OP_CONST && 6985 (kid->op_private & OPpCONST_BARE)) 6986 { 6987 OP * const newop = newGVOP(OP_GV, 0, 6988 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO)); 6989 if (!(o->op_private & 1) && /* if not unop */ 6990 kid == cLISTOPo->op_last) 6991 cLISTOPo->op_last = newop; 6992 #ifdef PERL_MAD 6993 op_getmad(kid,newop,'K'); 6994 #else 6995 op_free(kid); 6996 #endif 6997 kid = newop; 6998 } 6999 else if (kid->op_type == OP_READLINE) { 7000 /* neophyte patrol: open(<FH>), close(<FH>) etc. */ 7001 bad_type(numargs, "HANDLE", OP_DESC(o), kid); 7002 } 7003 else { 7004 I32 flags = OPf_SPECIAL; 7005 I32 priv = 0; 7006 PADOFFSET targ = 0; 7007 7008 /* is this op a FH constructor? */ 7009 if (is_handle_constructor(o,numargs)) { 7010 const char *name = NULL; 7011 STRLEN len = 0; 7012 7013 flags = 0; 7014 /* Set a flag to tell rv2gv to vivify 7015 * need to "prove" flag does not mean something 7016 * else already - NI-S 1999/05/07 7017 */ 7018 priv = OPpDEREF; 7019 if (kid->op_type == OP_PADSV) { 7020 SV *const namesv 7021 = PAD_COMPNAME_SV(kid->op_targ); 7022 name = SvPV_const(namesv, len); 7023 } 7024 else if (kid->op_type == OP_RV2SV 7025 && kUNOP->op_first->op_type == OP_GV) 7026 { 7027 GV * const gv = cGVOPx_gv(kUNOP->op_first); 7028 name = GvNAME(gv); 7029 len = GvNAMELEN(gv); 7030 } 7031 else if (kid->op_type == OP_AELEM 7032 || kid->op_type == OP_HELEM) 7033 { 7034 OP *firstop; 7035 OP *op = ((BINOP*)kid)->op_first; 7036 name = NULL; 7037 if (op) { 7038 SV *tmpstr = NULL; 7039 const char * const a = 7040 kid->op_type == OP_AELEM ? 7041 "[]" : "{}"; 7042 if (((op->op_type == OP_RV2AV) || 7043 (op->op_type == OP_RV2HV)) && 7044 (firstop = ((UNOP*)op)->op_first) && 7045 (firstop->op_type == OP_GV)) { 7046 /* packagevar $a[] or $h{} */ 7047 GV * const gv = cGVOPx_gv(firstop); 7048 if (gv) 7049 tmpstr = 7050 Perl_newSVpvf(aTHX_ 7051 "%s%c...%c", 7052 GvNAME(gv), 7053 a[0], a[1]); 7054 } 7055 else if (op->op_type == OP_PADAV 7056 || op->op_type == OP_PADHV) { 7057 /* lexicalvar $a[] or $h{} */ 7058 const char * const padname = 7059 PAD_COMPNAME_PV(op->op_targ); 7060 if (padname) 7061 tmpstr = 7062 Perl_newSVpvf(aTHX_ 7063 "%s%c...%c", 7064 padname + 1, 7065 a[0], a[1]); 7066 } 7067 if (tmpstr) { 7068 name = SvPV_const(tmpstr, len); 7069 sv_2mortal(tmpstr); 7070 } 7071 } 7072 if (!name) { 7073 name = "__ANONIO__"; 7074 len = 10; 7075 } 7076 mod(kid, type); 7077 } 7078 if (name) { 7079 SV *namesv; 7080 targ = pad_alloc(OP_RV2GV, SVs_PADTMP); 7081 namesv = PAD_SVl(targ); 7082 SvUPGRADE(namesv, SVt_PV); 7083 if (*name != '$') 7084 sv_setpvs(namesv, "$"); 7085 sv_catpvn(namesv, name, len); 7086 } 7087 } 7088 kid->op_sibling = 0; 7089 kid = newUNOP(OP_RV2GV, flags, scalar(kid)); 7090 kid->op_targ = targ; 7091 kid->op_private |= priv; 7092 } 7093 kid->op_sibling = sibl; 7094 *tokid = kid; 7095 } 7096 scalar(kid); 7097 break; 7098 case OA_SCALARREF: 7099 mod(scalar(kid), type); 7100 break; 7101 } 7102 oa >>= 4; 7103 tokid = &kid->op_sibling; 7104 kid = kid->op_sibling; 7105 } 7106 #ifdef PERL_MAD 7107 if (kid && kid->op_type != OP_STUB) 7108 return too_many_arguments(o,OP_DESC(o)); 7109 o->op_private |= numargs; 7110 #else 7111 /* FIXME - should the numargs move as for the PERL_MAD case? */ 7112 o->op_private |= numargs; 7113 if (kid) 7114 return too_many_arguments(o,OP_DESC(o)); 7115 #endif 7116 listkids(o); 7117 } 7118 else if (PL_opargs[type] & OA_DEFGV) { 7119 #ifdef PERL_MAD 7120 OP *newop = newUNOP(type, 0, newDEFSVOP()); 7121 op_getmad(o,newop,'O'); 7122 return newop; 7123 #else 7124 /* Ordering of these two is important to keep f_map.t passing. */ 7125 op_free(o); 7126 return newUNOP(type, 0, newDEFSVOP()); 7127 #endif 7128 } 7129 7130 if (oa) { 7131 while (oa & OA_OPTIONAL) 7132 oa >>= 4; 7133 if (oa && oa != OA_LIST) 7134 return too_few_arguments(o,OP_DESC(o)); 7135 } 7136 return o; 7137 } 7138 7139 OP * 7140 Perl_ck_glob(pTHX_ OP *o) 7141 { 7142 dVAR; 7143 GV *gv; 7144 7145 PERL_ARGS_ASSERT_CK_GLOB; 7146 7147 o = ck_fun(o); 7148 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling) 7149 append_elem(OP_GLOB, o, newDEFSVOP()); 7150 7151 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV)) 7152 && GvCVu(gv) && GvIMPORTED_CV(gv))) 7153 { 7154 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV); 7155 } 7156 7157 #if !defined(PERL_EXTERNAL_GLOB) 7158 /* XXX this can be tightened up and made more failsafe. */ 7159 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) { 7160 GV *glob_gv; 7161 ENTER; 7162 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, 7163 newSVpvs("File::Glob"), NULL, NULL, NULL); 7164 if((glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV))) { 7165 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV); 7166 GvCV(gv) = GvCV(glob_gv); 7167 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv))); 7168 GvIMPORTED_CV_on(gv); 7169 } 7170 LEAVE; 7171 } 7172 #endif /* PERL_EXTERNAL_GLOB */ 7173 7174 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) { 7175 append_elem(OP_GLOB, o, 7176 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++))); 7177 o->op_type = OP_LIST; 7178 o->op_ppaddr = PL_ppaddr[OP_LIST]; 7179 cLISTOPo->op_first->op_type = OP_PUSHMARK; 7180 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK]; 7181 cLISTOPo->op_first->op_targ = 0; 7182 o = newUNOP(OP_ENTERSUB, OPf_STACKED, 7183 append_elem(OP_LIST, o, 7184 scalar(newUNOP(OP_RV2CV, 0, 7185 newGVOP(OP_GV, 0, gv))))); 7186 o = newUNOP(OP_NULL, 0, ck_subr(o)); 7187 o->op_targ = OP_GLOB; /* hint at what it used to be */ 7188 return o; 7189 } 7190 gv = newGVgen("main"); 7191 gv_IOadd(gv); 7192 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv)); 7193 scalarkids(o); 7194 return o; 7195 } 7196 7197 OP * 7198 Perl_ck_grep(pTHX_ OP *o) 7199 { 7200 dVAR; 7201 LOGOP *gwop = NULL; 7202 OP *kid; 7203 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE; 7204 PADOFFSET offset; 7205 7206 PERL_ARGS_ASSERT_CK_GREP; 7207 7208 o->op_ppaddr = PL_ppaddr[OP_GREPSTART]; 7209 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */ 7210 7211 if (o->op_flags & OPf_STACKED) { 7212 OP* k; 7213 o = ck_sort(o); 7214 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first; 7215 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE) 7216 return no_fh_allowed(o); 7217 for (k = kid; k; k = k->op_next) { 7218 kid = k; 7219 } 7220 NewOp(1101, gwop, 1, LOGOP); 7221 kid->op_next = (OP*)gwop; 7222 o->op_flags &= ~OPf_STACKED; 7223 } 7224 kid = cLISTOPo->op_first->op_sibling; 7225 if (type == OP_MAPWHILE) 7226 list(kid); 7227 else 7228 scalar(kid); 7229 o = ck_fun(o); 7230 if (PL_parser && PL_parser->error_count) 7231 return o; 7232 kid = cLISTOPo->op_first->op_sibling; 7233 if (kid->op_type != OP_NULL) 7234 Perl_croak(aTHX_ "panic: ck_grep"); 7235 kid = kUNOP->op_first; 7236 7237 if (!gwop) 7238 NewOp(1101, gwop, 1, LOGOP); 7239 gwop->op_type = type; 7240 gwop->op_ppaddr = PL_ppaddr[type]; 7241 gwop->op_first = listkids(o); 7242 gwop->op_flags |= OPf_KIDS; 7243 gwop->op_other = LINKLIST(kid); 7244 kid->op_next = (OP*)gwop; 7245 offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0); 7246 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) { 7247 o->op_private = gwop->op_private = 0; 7248 gwop->op_targ = pad_alloc(type, SVs_PADTMP); 7249 } 7250 else { 7251 o->op_private = gwop->op_private = OPpGREP_LEX; 7252 gwop->op_targ = o->op_targ = offset; 7253 } 7254 7255 kid = cLISTOPo->op_first->op_sibling; 7256 if (!kid || !kid->op_sibling) 7257 return too_few_arguments(o,OP_DESC(o)); 7258 for (kid = kid->op_sibling; kid; kid = kid->op_sibling) 7259 mod(kid, OP_GREPSTART); 7260 7261 return (OP*)gwop; 7262 } 7263 7264 OP * 7265 Perl_ck_index(pTHX_ OP *o) 7266 { 7267 PERL_ARGS_ASSERT_CK_INDEX; 7268 7269 if (o->op_flags & OPf_KIDS) { 7270 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ 7271 if (kid) 7272 kid = kid->op_sibling; /* get past "big" */ 7273 if (kid && kid->op_type == OP_CONST) 7274 fbm_compile(((SVOP*)kid)->op_sv, 0); 7275 } 7276 return ck_fun(o); 7277 } 7278 7279 OP * 7280 Perl_ck_lfun(pTHX_ OP *o) 7281 { 7282 const OPCODE type = o->op_type; 7283 7284 PERL_ARGS_ASSERT_CK_LFUN; 7285 7286 return modkids(ck_fun(o), type); 7287 } 7288 7289 OP * 7290 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ 7291 { 7292 PERL_ARGS_ASSERT_CK_DEFINED; 7293 7294 if ((o->op_flags & OPf_KIDS)) { 7295 switch (cUNOPo->op_first->op_type) { 7296 case OP_RV2AV: 7297 /* This is needed for 7298 if (defined %stash::) 7299 to work. Do not break Tk. 7300 */ 7301 break; /* Globals via GV can be undef */ 7302 case OP_PADAV: 7303 case OP_AASSIGN: /* Is this a good idea? */ 7304 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), 7305 "defined(@array) is deprecated"); 7306 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), 7307 "\t(Maybe you should just omit the defined()?)\n"); 7308 break; 7309 case OP_RV2HV: 7310 case OP_PADHV: 7311 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), 7312 "defined(%%hash) is deprecated"); 7313 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), 7314 "\t(Maybe you should just omit the defined()?)\n"); 7315 break; 7316 default: 7317 /* no warning */ 7318 break; 7319 } 7320 } 7321 return ck_rfun(o); 7322 } 7323 7324 OP * 7325 Perl_ck_readline(pTHX_ OP *o) 7326 { 7327 PERL_ARGS_ASSERT_CK_READLINE; 7328 7329 if (!(o->op_flags & OPf_KIDS)) { 7330 OP * const newop 7331 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv)); 7332 #ifdef PERL_MAD 7333 op_getmad(o,newop,'O'); 7334 #else 7335 op_free(o); 7336 #endif 7337 return newop; 7338 } 7339 return o; 7340 } 7341 7342 OP * 7343 Perl_ck_rfun(pTHX_ OP *o) 7344 { 7345 const OPCODE type = o->op_type; 7346 7347 PERL_ARGS_ASSERT_CK_RFUN; 7348 7349 return refkids(ck_fun(o), type); 7350 } 7351 7352 OP * 7353 Perl_ck_listiob(pTHX_ OP *o) 7354 { 7355 register OP *kid; 7356 7357 PERL_ARGS_ASSERT_CK_LISTIOB; 7358 7359 kid = cLISTOPo->op_first; 7360 if (!kid) { 7361 o = force_list(o); 7362 kid = cLISTOPo->op_first; 7363 } 7364 if (kid->op_type == OP_PUSHMARK) 7365 kid = kid->op_sibling; 7366 if (kid && o->op_flags & OPf_STACKED) 7367 kid = kid->op_sibling; 7368 else if (kid && !kid->op_sibling) { /* print HANDLE; */ 7369 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) { 7370 o->op_flags |= OPf_STACKED; /* make it a filehandle */ 7371 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid)); 7372 cLISTOPo->op_first->op_sibling = kid; 7373 cLISTOPo->op_last = kid; 7374 kid = kid->op_sibling; 7375 } 7376 } 7377 7378 if (!kid) 7379 append_elem(o->op_type, o, newDEFSVOP()); 7380 7381 return listkids(o); 7382 } 7383 7384 OP * 7385 Perl_ck_smartmatch(pTHX_ OP *o) 7386 { 7387 dVAR; 7388 if (0 == (o->op_flags & OPf_SPECIAL)) { 7389 OP *first = cBINOPo->op_first; 7390 OP *second = first->op_sibling; 7391 7392 /* Implicitly take a reference to an array or hash */ 7393 first->op_sibling = NULL; 7394 first = cBINOPo->op_first = ref_array_or_hash(first); 7395 second = first->op_sibling = ref_array_or_hash(second); 7396 7397 /* Implicitly take a reference to a regular expression */ 7398 if (first->op_type == OP_MATCH) { 7399 first->op_type = OP_QR; 7400 first->op_ppaddr = PL_ppaddr[OP_QR]; 7401 } 7402 if (second->op_type == OP_MATCH) { 7403 second->op_type = OP_QR; 7404 second->op_ppaddr = PL_ppaddr[OP_QR]; 7405 } 7406 } 7407 7408 return o; 7409 } 7410 7411 7412 OP * 7413 Perl_ck_sassign(pTHX_ OP *o) 7414 { 7415 dVAR; 7416 OP * const kid = cLISTOPo->op_first; 7417 7418 PERL_ARGS_ASSERT_CK_SASSIGN; 7419 7420 /* has a disposable target? */ 7421 if ((PL_opargs[kid->op_type] & OA_TARGLEX) 7422 && !(kid->op_flags & OPf_STACKED) 7423 /* Cannot steal the second time! */ 7424 && !(kid->op_private & OPpTARGET_MY) 7425 /* Keep the full thing for madskills */ 7426 && !PL_madskills 7427 ) 7428 { 7429 OP * const kkid = kid->op_sibling; 7430 7431 /* Can just relocate the target. */ 7432 if (kkid && kkid->op_type == OP_PADSV 7433 && !(kkid->op_private & OPpLVAL_INTRO)) 7434 { 7435 kid->op_targ = kkid->op_targ; 7436 kkid->op_targ = 0; 7437 /* Now we do not need PADSV and SASSIGN. */ 7438 kid->op_sibling = o->op_sibling; /* NULL */ 7439 cLISTOPo->op_first = NULL; 7440 op_free(o); 7441 op_free(kkid); 7442 kid->op_private |= OPpTARGET_MY; /* Used for context settings */ 7443 return kid; 7444 } 7445 } 7446 if (kid->op_sibling) { 7447 OP *kkid = kid->op_sibling; 7448 if (kkid->op_type == OP_PADSV 7449 && (kkid->op_private & OPpLVAL_INTRO) 7450 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) { 7451 const PADOFFSET target = kkid->op_targ; 7452 OP *const other = newOP(OP_PADSV, 7453 kkid->op_flags 7454 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8)); 7455 OP *const first = newOP(OP_NULL, 0); 7456 OP *const nullop = newCONDOP(0, first, o, other); 7457 OP *const condop = first->op_next; 7458 /* hijacking PADSTALE for uninitialized state variables */ 7459 SvPADSTALE_on(PAD_SVl(target)); 7460 7461 condop->op_type = OP_ONCE; 7462 condop->op_ppaddr = PL_ppaddr[OP_ONCE]; 7463 condop->op_targ = target; 7464 other->op_targ = target; 7465 7466 /* Because we change the type of the op here, we will skip the 7467 assinment binop->op_last = binop->op_first->op_sibling; at the 7468 end of Perl_newBINOP(). So need to do it here. */ 7469 cBINOPo->op_last = cBINOPo->op_first->op_sibling; 7470 7471 return nullop; 7472 } 7473 } 7474 return o; 7475 } 7476 7477 OP * 7478 Perl_ck_match(pTHX_ OP *o) 7479 { 7480 dVAR; 7481 7482 PERL_ARGS_ASSERT_CK_MATCH; 7483 7484 if (o->op_type != OP_QR && PL_compcv) { 7485 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0); 7486 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) { 7487 o->op_targ = offset; 7488 o->op_private |= OPpTARGET_MY; 7489 } 7490 } 7491 if (o->op_type == OP_MATCH || o->op_type == OP_QR) 7492 o->op_private |= OPpRUNTIME; 7493 return o; 7494 } 7495 7496 OP * 7497 Perl_ck_method(pTHX_ OP *o) 7498 { 7499 OP * const kid = cUNOPo->op_first; 7500 7501 PERL_ARGS_ASSERT_CK_METHOD; 7502 7503 if (kid->op_type == OP_CONST) { 7504 SV* sv = kSVOP->op_sv; 7505 const char * const method = SvPVX_const(sv); 7506 if (!(strchr(method, ':') || strchr(method, '\''))) { 7507 OP *cmop; 7508 if (!SvREADONLY(sv) || !SvFAKE(sv)) { 7509 sv = newSVpvn_share(method, SvCUR(sv), 0); 7510 } 7511 else { 7512 kSVOP->op_sv = NULL; 7513 } 7514 cmop = newSVOP(OP_METHOD_NAMED, 0, sv); 7515 #ifdef PERL_MAD 7516 op_getmad(o,cmop,'O'); 7517 #else 7518 op_free(o); 7519 #endif 7520 return cmop; 7521 } 7522 } 7523 return o; 7524 } 7525 7526 OP * 7527 Perl_ck_null(pTHX_ OP *o) 7528 { 7529 PERL_ARGS_ASSERT_CK_NULL; 7530 PERL_UNUSED_CONTEXT; 7531 return o; 7532 } 7533 7534 OP * 7535 Perl_ck_open(pTHX_ OP *o) 7536 { 7537 dVAR; 7538 HV * const table = GvHV(PL_hintgv); 7539 7540 PERL_ARGS_ASSERT_CK_OPEN; 7541 7542 if (table) { 7543 SV **svp = hv_fetchs(table, "open_IN", FALSE); 7544 if (svp && *svp) { 7545 STRLEN len = 0; 7546 const char *d = SvPV_const(*svp, len); 7547 const I32 mode = mode_from_discipline(d, len); 7548 if (mode & O_BINARY) 7549 o->op_private |= OPpOPEN_IN_RAW; 7550 else if (mode & O_TEXT) 7551 o->op_private |= OPpOPEN_IN_CRLF; 7552 } 7553 7554 svp = hv_fetchs(table, "open_OUT", FALSE); 7555 if (svp && *svp) { 7556 STRLEN len = 0; 7557 const char *d = SvPV_const(*svp, len); 7558 const I32 mode = mode_from_discipline(d, len); 7559 if (mode & O_BINARY) 7560 o->op_private |= OPpOPEN_OUT_RAW; 7561 else if (mode & O_TEXT) 7562 o->op_private |= OPpOPEN_OUT_CRLF; 7563 } 7564 } 7565 if (o->op_type == OP_BACKTICK) { 7566 if (!(o->op_flags & OPf_KIDS)) { 7567 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP()); 7568 #ifdef PERL_MAD 7569 op_getmad(o,newop,'O'); 7570 #else 7571 op_free(o); 7572 #endif 7573 return newop; 7574 } 7575 return o; 7576 } 7577 { 7578 /* In case of three-arg dup open remove strictness 7579 * from the last arg if it is a bareword. */ 7580 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */ 7581 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */ 7582 OP *oa; 7583 const char *mode; 7584 7585 if ((last->op_type == OP_CONST) && /* The bareword. */ 7586 (last->op_private & OPpCONST_BARE) && 7587 (last->op_private & OPpCONST_STRICT) && 7588 (oa = first->op_sibling) && /* The fh. */ 7589 (oa = oa->op_sibling) && /* The mode. */ 7590 (oa->op_type == OP_CONST) && 7591 SvPOK(((SVOP*)oa)->op_sv) && 7592 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) && 7593 mode[0] == '>' && mode[1] == '&' && /* A dup open. */ 7594 (last == oa->op_sibling)) /* The bareword. */ 7595 last->op_private &= ~OPpCONST_STRICT; 7596 } 7597 return ck_fun(o); 7598 } 7599 7600 OP * 7601 Perl_ck_repeat(pTHX_ OP *o) 7602 { 7603 PERL_ARGS_ASSERT_CK_REPEAT; 7604 7605 if (cBINOPo->op_first->op_flags & OPf_PARENS) { 7606 o->op_private |= OPpREPEAT_DOLIST; 7607 cBINOPo->op_first = force_list(cBINOPo->op_first); 7608 } 7609 else 7610 scalar(o); 7611 return o; 7612 } 7613 7614 OP * 7615 Perl_ck_require(pTHX_ OP *o) 7616 { 7617 dVAR; 7618 GV* gv = NULL; 7619 7620 PERL_ARGS_ASSERT_CK_REQUIRE; 7621 7622 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */ 7623 SVOP * const kid = (SVOP*)cUNOPo->op_first; 7624 7625 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { 7626 SV * const sv = kid->op_sv; 7627 U32 was_readonly = SvREADONLY(sv); 7628 char *s; 7629 STRLEN len; 7630 const char *end; 7631 7632 if (was_readonly) { 7633 if (SvFAKE(sv)) { 7634 sv_force_normal_flags(sv, 0); 7635 assert(!SvREADONLY(sv)); 7636 was_readonly = 0; 7637 } else { 7638 SvREADONLY_off(sv); 7639 } 7640 } 7641 7642 s = SvPVX(sv); 7643 len = SvCUR(sv); 7644 end = s + len; 7645 for (; s < end; s++) { 7646 if (*s == ':' && s[1] == ':') { 7647 *s = '/'; 7648 Move(s+2, s+1, end - s - 1, char); 7649 --end; 7650 } 7651 } 7652 SvEND_set(sv, end); 7653 sv_catpvs(sv, ".pm"); 7654 SvFLAGS(sv) |= was_readonly; 7655 } 7656 } 7657 7658 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */ 7659 /* handle override, if any */ 7660 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV); 7661 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) { 7662 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE); 7663 gv = gvp ? *gvp : NULL; 7664 } 7665 } 7666 7667 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) { 7668 OP * const kid = cUNOPo->op_first; 7669 OP * newop; 7670 7671 cUNOPo->op_first = 0; 7672 #ifndef PERL_MAD 7673 op_free(o); 7674 #endif 7675 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED, 7676 append_elem(OP_LIST, kid, 7677 scalar(newUNOP(OP_RV2CV, 0, 7678 newGVOP(OP_GV, 0, 7679 gv)))))); 7680 op_getmad(o,newop,'O'); 7681 return newop; 7682 } 7683 7684 return scalar(ck_fun(o)); 7685 } 7686 7687 OP * 7688 Perl_ck_return(pTHX_ OP *o) 7689 { 7690 dVAR; 7691 OP *kid; 7692 7693 PERL_ARGS_ASSERT_CK_RETURN; 7694 7695 kid = cLISTOPo->op_first->op_sibling; 7696 if (CvLVALUE(PL_compcv)) { 7697 for (; kid; kid = kid->op_sibling) 7698 mod(kid, OP_LEAVESUBLV); 7699 } else { 7700 for (; kid; kid = kid->op_sibling) 7701 if ((kid->op_type == OP_NULL) 7702 && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) { 7703 /* This is a do block */ 7704 OP *op = kUNOP->op_first; 7705 if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) { 7706 op = cUNOPx(op)->op_first; 7707 assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL)); 7708 /* Force the use of the caller's context */ 7709 op->op_flags |= OPf_SPECIAL; 7710 } 7711 } 7712 } 7713 7714 return o; 7715 } 7716 7717 OP * 7718 Perl_ck_select(pTHX_ OP *o) 7719 { 7720 dVAR; 7721 OP* kid; 7722 7723 PERL_ARGS_ASSERT_CK_SELECT; 7724 7725 if (o->op_flags & OPf_KIDS) { 7726 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ 7727 if (kid && kid->op_sibling) { 7728 o->op_type = OP_SSELECT; 7729 o->op_ppaddr = PL_ppaddr[OP_SSELECT]; 7730 o = ck_fun(o); 7731 return fold_constants(o); 7732 } 7733 } 7734 o = ck_fun(o); 7735 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ 7736 if (kid && kid->op_type == OP_RV2GV) 7737 kid->op_private &= ~HINT_STRICT_REFS; 7738 return o; 7739 } 7740 7741 OP * 7742 Perl_ck_shift(pTHX_ OP *o) 7743 { 7744 dVAR; 7745 const I32 type = o->op_type; 7746 7747 PERL_ARGS_ASSERT_CK_SHIFT; 7748 7749 if (!(o->op_flags & OPf_KIDS)) { 7750 OP *argop = newUNOP(OP_RV2AV, 0, 7751 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv))); 7752 #ifdef PERL_MAD 7753 OP * const oldo = o; 7754 o = newUNOP(type, 0, scalar(argop)); 7755 op_getmad(oldo,o,'O'); 7756 return o; 7757 #else 7758 op_free(o); 7759 return newUNOP(type, 0, scalar(argop)); 7760 #endif 7761 } 7762 return scalar(modkids(ck_fun(o), type)); 7763 } 7764 7765 OP * 7766 Perl_ck_sort(pTHX_ OP *o) 7767 { 7768 dVAR; 7769 OP *firstkid; 7770 7771 PERL_ARGS_ASSERT_CK_SORT; 7772 7773 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) { 7774 HV * const hinthv = GvHV(PL_hintgv); 7775 if (hinthv) { 7776 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE); 7777 if (svp) { 7778 const I32 sorthints = (I32)SvIV(*svp); 7779 if ((sorthints & HINT_SORT_QUICKSORT) != 0) 7780 o->op_private |= OPpSORT_QSORT; 7781 if ((sorthints & HINT_SORT_STABLE) != 0) 7782 o->op_private |= OPpSORT_STABLE; 7783 } 7784 } 7785 } 7786 7787 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED) 7788 simplify_sort(o); 7789 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ 7790 if (o->op_flags & OPf_STACKED) { /* may have been cleared */ 7791 OP *k = NULL; 7792 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */ 7793 7794 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) { 7795 linklist(kid); 7796 if (kid->op_type == OP_SCOPE) { 7797 k = kid->op_next; 7798 kid->op_next = 0; 7799 } 7800 else if (kid->op_type == OP_LEAVE) { 7801 if (o->op_type == OP_SORT) { 7802 op_null(kid); /* wipe out leave */ 7803 kid->op_next = kid; 7804 7805 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) { 7806 if (k->op_next == kid) 7807 k->op_next = 0; 7808 /* don't descend into loops */ 7809 else if (k->op_type == OP_ENTERLOOP 7810 || k->op_type == OP_ENTERITER) 7811 { 7812 k = cLOOPx(k)->op_lastop; 7813 } 7814 } 7815 } 7816 else 7817 kid->op_next = 0; /* just disconnect the leave */ 7818 k = kLISTOP->op_first; 7819 } 7820 CALL_PEEP(k); 7821 7822 kid = firstkid; 7823 if (o->op_type == OP_SORT) { 7824 /* provide scalar context for comparison function/block */ 7825 kid = scalar(kid); 7826 kid->op_next = kid; 7827 } 7828 else 7829 kid->op_next = k; 7830 o->op_flags |= OPf_SPECIAL; 7831 } 7832 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV) 7833 op_null(firstkid); 7834 7835 firstkid = firstkid->op_sibling; 7836 } 7837 7838 /* provide list context for arguments */ 7839 if (o->op_type == OP_SORT) 7840 list(firstkid); 7841 7842 return o; 7843 } 7844 7845 STATIC void 7846 S_simplify_sort(pTHX_ OP *o) 7847 { 7848 dVAR; 7849 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ 7850 OP *k; 7851 int descending; 7852 GV *gv; 7853 const char *gvname; 7854 7855 PERL_ARGS_ASSERT_SIMPLIFY_SORT; 7856 7857 if (!(o->op_flags & OPf_STACKED)) 7858 return; 7859 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV)); 7860 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV)); 7861 kid = kUNOP->op_first; /* get past null */ 7862 if (kid->op_type != OP_SCOPE) 7863 return; 7864 kid = kLISTOP->op_last; /* get past scope */ 7865 switch(kid->op_type) { 7866 case OP_NCMP: 7867 case OP_I_NCMP: 7868 case OP_SCMP: 7869 break; 7870 default: 7871 return; 7872 } 7873 k = kid; /* remember this node*/ 7874 if (kBINOP->op_first->op_type != OP_RV2SV) 7875 return; 7876 kid = kBINOP->op_first; /* get past cmp */ 7877 if (kUNOP->op_first->op_type != OP_GV) 7878 return; 7879 kid = kUNOP->op_first; /* get past rv2sv */ 7880 gv = kGVOP_gv; 7881 if (GvSTASH(gv) != PL_curstash) 7882 return; 7883 gvname = GvNAME(gv); 7884 if (*gvname == 'a' && gvname[1] == '\0') 7885 descending = 0; 7886 else if (*gvname == 'b' && gvname[1] == '\0') 7887 descending = 1; 7888 else 7889 return; 7890 7891 kid = k; /* back to cmp */ 7892 if (kBINOP->op_last->op_type != OP_RV2SV) 7893 return; 7894 kid = kBINOP->op_last; /* down to 2nd arg */ 7895 if (kUNOP->op_first->op_type != OP_GV) 7896 return; 7897 kid = kUNOP->op_first; /* get past rv2sv */ 7898 gv = kGVOP_gv; 7899 if (GvSTASH(gv) != PL_curstash) 7900 return; 7901 gvname = GvNAME(gv); 7902 if ( descending 7903 ? !(*gvname == 'a' && gvname[1] == '\0') 7904 : !(*gvname == 'b' && gvname[1] == '\0')) 7905 return; 7906 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL); 7907 if (descending) 7908 o->op_private |= OPpSORT_DESCEND; 7909 if (k->op_type == OP_NCMP) 7910 o->op_private |= OPpSORT_NUMERIC; 7911 if (k->op_type == OP_I_NCMP) 7912 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER; 7913 kid = cLISTOPo->op_first->op_sibling; 7914 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */ 7915 #ifdef PERL_MAD 7916 op_getmad(kid,o,'S'); /* then delete it */ 7917 #else 7918 op_free(kid); /* then delete it */ 7919 #endif 7920 } 7921 7922 OP * 7923 Perl_ck_split(pTHX_ OP *o) 7924 { 7925 dVAR; 7926 register OP *kid; 7927 7928 PERL_ARGS_ASSERT_CK_SPLIT; 7929 7930 if (o->op_flags & OPf_STACKED) 7931 return no_fh_allowed(o); 7932 7933 kid = cLISTOPo->op_first; 7934 if (kid->op_type != OP_NULL) 7935 Perl_croak(aTHX_ "panic: ck_split"); 7936 kid = kid->op_sibling; 7937 op_free(cLISTOPo->op_first); 7938 cLISTOPo->op_first = kid; 7939 if (!kid) { 7940 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" ")); 7941 cLISTOPo->op_last = kid; /* There was only one element previously */ 7942 } 7943 7944 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) { 7945 OP * const sibl = kid->op_sibling; 7946 kid->op_sibling = 0; 7947 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0); 7948 if (cLISTOPo->op_first == cLISTOPo->op_last) 7949 cLISTOPo->op_last = kid; 7950 cLISTOPo->op_first = kid; 7951 kid->op_sibling = sibl; 7952 } 7953 7954 kid->op_type = OP_PUSHRE; 7955 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE]; 7956 scalar(kid); 7957 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) { 7958 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), 7959 "Use of /g modifier is meaningless in split"); 7960 } 7961 7962 if (!kid->op_sibling) 7963 append_elem(OP_SPLIT, o, newDEFSVOP()); 7964 7965 kid = kid->op_sibling; 7966 scalar(kid); 7967 7968 if (!kid->op_sibling) 7969 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0))); 7970 assert(kid->op_sibling); 7971 7972 kid = kid->op_sibling; 7973 scalar(kid); 7974 7975 if (kid->op_sibling) 7976 return too_many_arguments(o,OP_DESC(o)); 7977 7978 return o; 7979 } 7980 7981 OP * 7982 Perl_ck_join(pTHX_ OP *o) 7983 { 7984 const OP * const kid = cLISTOPo->op_first->op_sibling; 7985 7986 PERL_ARGS_ASSERT_CK_JOIN; 7987 7988 if (kid && kid->op_type == OP_MATCH) { 7989 if (ckWARN(WARN_SYNTAX)) { 7990 const REGEXP *re = PM_GETRE(kPMOP); 7991 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING"; 7992 const STRLEN len = re ? RX_PRELEN(re) : 6; 7993 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 7994 "/%.*s/ should probably be written as \"%.*s\"", 7995 (int)len, pmstr, (int)len, pmstr); 7996 } 7997 } 7998 return ck_fun(o); 7999 } 8000 8001 OP * 8002 Perl_ck_subr(pTHX_ OP *o) 8003 { 8004 dVAR; 8005 OP *prev = ((cUNOPo->op_first->op_sibling) 8006 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first; 8007 OP *o2 = prev->op_sibling; 8008 OP *cvop; 8009 const char *proto = NULL; 8010 const char *proto_end = NULL; 8011 CV *cv = NULL; 8012 GV *namegv = NULL; 8013 int optional = 0; 8014 I32 arg = 0; 8015 I32 contextclass = 0; 8016 const char *e = NULL; 8017 bool delete_op = 0; 8018 8019 PERL_ARGS_ASSERT_CK_SUBR; 8020 8021 o->op_private |= OPpENTERSUB_HASTARG; 8022 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ; 8023 if (cvop->op_type == OP_RV2CV) { 8024 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER); 8025 op_null(cvop); /* disable rv2cv */ 8026 if (!(o->op_private & OPpENTERSUB_AMPER)) { 8027 SVOP *tmpop = (SVOP*)((UNOP*)cvop)->op_first; 8028 GV *gv = NULL; 8029 switch (tmpop->op_type) { 8030 case OP_GV: { 8031 gv = cGVOPx_gv(tmpop); 8032 cv = GvCVu(gv); 8033 if (!cv) 8034 tmpop->op_private |= OPpEARLY_CV; 8035 } break; 8036 case OP_CONST: { 8037 SV *sv = cSVOPx_sv(tmpop); 8038 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) 8039 cv = (CV*)SvRV(sv); 8040 } break; 8041 } 8042 if (cv && SvPOK(cv)) { 8043 STRLEN len; 8044 namegv = gv && CvANON(cv) ? gv : CvGV(cv); 8045 proto = SvPV(MUTABLE_SV(cv), len); 8046 proto_end = proto + len; 8047 } 8048 } 8049 } 8050 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) { 8051 if (o2->op_type == OP_CONST) 8052 o2->op_private &= ~OPpCONST_STRICT; 8053 else if (o2->op_type == OP_LIST) { 8054 OP * const sib = ((UNOP*)o2)->op_first->op_sibling; 8055 if (sib && sib->op_type == OP_CONST) 8056 sib->op_private &= ~OPpCONST_STRICT; 8057 } 8058 } 8059 o->op_private |= (PL_hints & HINT_STRICT_REFS); 8060 if (PERLDB_SUB && PL_curstash != PL_debstash) 8061 o->op_private |= OPpENTERSUB_DB; 8062 while (o2 != cvop) { 8063 OP* o3; 8064 if (PL_madskills && o2->op_type == OP_STUB) { 8065 o2 = o2->op_sibling; 8066 continue; 8067 } 8068 if (PL_madskills && o2->op_type == OP_NULL) 8069 o3 = ((UNOP*)o2)->op_first; 8070 else 8071 o3 = o2; 8072 if (proto) { 8073 if (proto >= proto_end) 8074 return too_many_arguments(o, gv_ename(namegv)); 8075 8076 switch (*proto) { 8077 case ';': 8078 optional = 1; 8079 proto++; 8080 continue; 8081 case '_': 8082 /* _ must be at the end */ 8083 if (proto[1] && proto[1] != ';') 8084 goto oops; 8085 case '$': 8086 proto++; 8087 arg++; 8088 scalar(o2); 8089 break; 8090 case '%': 8091 case '@': 8092 list(o2); 8093 arg++; 8094 break; 8095 case '&': 8096 proto++; 8097 arg++; 8098 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF) 8099 bad_type(arg, 8100 arg == 1 ? "block or sub {}" : "sub {}", 8101 gv_ename(namegv), o3); 8102 break; 8103 case '*': 8104 /* '*' allows any scalar type, including bareword */ 8105 proto++; 8106 arg++; 8107 if (o3->op_type == OP_RV2GV) 8108 goto wrapref; /* autoconvert GLOB -> GLOBref */ 8109 else if (o3->op_type == OP_CONST) 8110 o3->op_private &= ~OPpCONST_STRICT; 8111 else if (o3->op_type == OP_ENTERSUB) { 8112 /* accidental subroutine, revert to bareword */ 8113 OP *gvop = ((UNOP*)o3)->op_first; 8114 if (gvop && gvop->op_type == OP_NULL) { 8115 gvop = ((UNOP*)gvop)->op_first; 8116 if (gvop) { 8117 for (; gvop->op_sibling; gvop = gvop->op_sibling) 8118 ; 8119 if (gvop && 8120 (gvop->op_private & OPpENTERSUB_NOPAREN) && 8121 (gvop = ((UNOP*)gvop)->op_first) && 8122 gvop->op_type == OP_GV) 8123 { 8124 GV * const gv = cGVOPx_gv(gvop); 8125 OP * const sibling = o2->op_sibling; 8126 SV * const n = newSVpvs(""); 8127 #ifdef PERL_MAD 8128 OP * const oldo2 = o2; 8129 #else 8130 op_free(o2); 8131 #endif 8132 gv_fullname4(n, gv, "", FALSE); 8133 o2 = newSVOP(OP_CONST, 0, n); 8134 op_getmad(oldo2,o2,'O'); 8135 prev->op_sibling = o2; 8136 o2->op_sibling = sibling; 8137 } 8138 } 8139 } 8140 } 8141 scalar(o2); 8142 break; 8143 case '[': case ']': 8144 goto oops; 8145 break; 8146 case '\\': 8147 proto++; 8148 arg++; 8149 again: 8150 switch (*proto++) { 8151 case '[': 8152 if (contextclass++ == 0) { 8153 e = strchr(proto, ']'); 8154 if (!e || e == proto) 8155 goto oops; 8156 } 8157 else 8158 goto oops; 8159 goto again; 8160 break; 8161 case ']': 8162 if (contextclass) { 8163 const char *p = proto; 8164 const char *const end = proto; 8165 contextclass = 0; 8166 while (*--p != '[') {} 8167 bad_type(arg, Perl_form(aTHX_ "one of %.*s", 8168 (int)(end - p), p), 8169 gv_ename(namegv), o3); 8170 } else 8171 goto oops; 8172 break; 8173 case '*': 8174 if (o3->op_type == OP_RV2GV) 8175 goto wrapref; 8176 if (!contextclass) 8177 bad_type(arg, "symbol", gv_ename(namegv), o3); 8178 break; 8179 case '&': 8180 if (o3->op_type == OP_ENTERSUB) 8181 goto wrapref; 8182 if (!contextclass) 8183 bad_type(arg, "subroutine entry", gv_ename(namegv), 8184 o3); 8185 break; 8186 case '$': 8187 if (o3->op_type == OP_RV2SV || 8188 o3->op_type == OP_PADSV || 8189 o3->op_type == OP_HELEM || 8190 o3->op_type == OP_AELEM) 8191 goto wrapref; 8192 if (!contextclass) 8193 bad_type(arg, "scalar", gv_ename(namegv), o3); 8194 break; 8195 case '@': 8196 if (o3->op_type == OP_RV2AV || 8197 o3->op_type == OP_PADAV) 8198 goto wrapref; 8199 if (!contextclass) 8200 bad_type(arg, "array", gv_ename(namegv), o3); 8201 break; 8202 case '%': 8203 if (o3->op_type == OP_RV2HV || 8204 o3->op_type == OP_PADHV) 8205 goto wrapref; 8206 if (!contextclass) 8207 bad_type(arg, "hash", gv_ename(namegv), o3); 8208 break; 8209 wrapref: 8210 { 8211 OP* const kid = o2; 8212 OP* const sib = kid->op_sibling; 8213 kid->op_sibling = 0; 8214 o2 = newUNOP(OP_REFGEN, 0, kid); 8215 o2->op_sibling = sib; 8216 prev->op_sibling = o2; 8217 } 8218 if (contextclass && e) { 8219 proto = e + 1; 8220 contextclass = 0; 8221 } 8222 break; 8223 default: goto oops; 8224 } 8225 if (contextclass) 8226 goto again; 8227 break; 8228 case ' ': 8229 proto++; 8230 continue; 8231 default: 8232 oops: 8233 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf, 8234 gv_ename(namegv), SVfARG(cv)); 8235 } 8236 } 8237 else 8238 list(o2); 8239 mod(o2, OP_ENTERSUB); 8240 prev = o2; 8241 o2 = o2->op_sibling; 8242 } /* while */ 8243 if (o2 == cvop && proto && *proto == '_') { 8244 /* generate an access to $_ */ 8245 o2 = newDEFSVOP(); 8246 o2->op_sibling = prev->op_sibling; 8247 prev->op_sibling = o2; /* instead of cvop */ 8248 } 8249 if (proto && !optional && proto_end > proto && 8250 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_')) 8251 return too_few_arguments(o, gv_ename(namegv)); 8252 if(delete_op) { 8253 #ifdef PERL_MAD 8254 OP * const oldo = o; 8255 #else 8256 op_free(o); 8257 #endif 8258 o=newSVOP(OP_CONST, 0, newSViv(0)); 8259 op_getmad(oldo,o,'O'); 8260 } 8261 return o; 8262 } 8263 8264 OP * 8265 Perl_ck_svconst(pTHX_ OP *o) 8266 { 8267 PERL_ARGS_ASSERT_CK_SVCONST; 8268 PERL_UNUSED_CONTEXT; 8269 SvREADONLY_on(cSVOPo->op_sv); 8270 return o; 8271 } 8272 8273 OP * 8274 Perl_ck_chdir(pTHX_ OP *o) 8275 { 8276 if (o->op_flags & OPf_KIDS) { 8277 SVOP * const kid = (SVOP*)cUNOPo->op_first; 8278 8279 if (kid && kid->op_type == OP_CONST && 8280 (kid->op_private & OPpCONST_BARE)) 8281 { 8282 o->op_flags |= OPf_SPECIAL; 8283 kid->op_private &= ~OPpCONST_STRICT; 8284 } 8285 } 8286 return ck_fun(o); 8287 } 8288 8289 OP * 8290 Perl_ck_trunc(pTHX_ OP *o) 8291 { 8292 PERL_ARGS_ASSERT_CK_TRUNC; 8293 8294 if (o->op_flags & OPf_KIDS) { 8295 SVOP *kid = (SVOP*)cUNOPo->op_first; 8296 8297 if (kid->op_type == OP_NULL) 8298 kid = (SVOP*)kid->op_sibling; 8299 if (kid && kid->op_type == OP_CONST && 8300 (kid->op_private & OPpCONST_BARE)) 8301 { 8302 o->op_flags |= OPf_SPECIAL; 8303 kid->op_private &= ~OPpCONST_STRICT; 8304 } 8305 } 8306 return ck_fun(o); 8307 } 8308 8309 OP * 8310 Perl_ck_unpack(pTHX_ OP *o) 8311 { 8312 OP *kid = cLISTOPo->op_first; 8313 8314 PERL_ARGS_ASSERT_CK_UNPACK; 8315 8316 if (kid->op_sibling) { 8317 kid = kid->op_sibling; 8318 if (!kid->op_sibling) 8319 kid->op_sibling = newDEFSVOP(); 8320 } 8321 return ck_fun(o); 8322 } 8323 8324 OP * 8325 Perl_ck_substr(pTHX_ OP *o) 8326 { 8327 PERL_ARGS_ASSERT_CK_SUBSTR; 8328 8329 o = ck_fun(o); 8330 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) { 8331 OP *kid = cLISTOPo->op_first; 8332 8333 if (kid->op_type == OP_NULL) 8334 kid = kid->op_sibling; 8335 if (kid) 8336 kid->op_flags |= OPf_MOD; 8337 8338 } 8339 return o; 8340 } 8341 8342 OP * 8343 Perl_ck_each(pTHX_ OP *o) 8344 { 8345 dVAR; 8346 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL; 8347 8348 PERL_ARGS_ASSERT_CK_EACH; 8349 8350 if (kid) { 8351 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) { 8352 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH 8353 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES; 8354 o->op_type = new_type; 8355 o->op_ppaddr = PL_ppaddr[new_type]; 8356 } 8357 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV 8358 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) 8359 )) { 8360 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid); 8361 return o; 8362 } 8363 } 8364 return ck_fun(o); 8365 } 8366 8367 /* caller is supposed to assign the return to the 8368 container of the rep_op var */ 8369 STATIC OP * 8370 S_opt_scalarhv(pTHX_ OP *rep_op) { 8371 dVAR; 8372 UNOP *unop; 8373 8374 PERL_ARGS_ASSERT_OPT_SCALARHV; 8375 8376 NewOp(1101, unop, 1, UNOP); 8377 unop->op_type = (OPCODE)OP_BOOLKEYS; 8378 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS]; 8379 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS ); 8380 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8)); 8381 unop->op_first = rep_op; 8382 unop->op_next = rep_op->op_next; 8383 rep_op->op_next = (OP*)unop; 8384 rep_op->op_flags|=(OPf_REF | OPf_MOD); 8385 unop->op_sibling = rep_op->op_sibling; 8386 rep_op->op_sibling = NULL; 8387 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */ 8388 if (rep_op->op_type == OP_PADHV) { 8389 rep_op->op_flags &= ~OPf_WANT_SCALAR; 8390 rep_op->op_flags |= OPf_WANT_LIST; 8391 } 8392 return (OP*)unop; 8393 } 8394 8395 /* Checks if o acts as an in-place operator on an array. oright points to the 8396 * beginning of the right-hand side. Returns the left-hand side of the 8397 * assignment if o acts in-place, or NULL otherwise. */ 8398 8399 STATIC OP * 8400 S_is_inplace_av(pTHX_ OP *o, OP *oright) { 8401 OP *o2; 8402 OP *oleft = NULL; 8403 8404 PERL_ARGS_ASSERT_IS_INPLACE_AV; 8405 8406 if (!oright || 8407 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV) 8408 || oright->op_next != o 8409 || (oright->op_private & OPpLVAL_INTRO) 8410 ) 8411 return NULL; 8412 8413 /* o2 follows the chain of op_nexts through the LHS of the 8414 * assign (if any) to the aassign op itself */ 8415 o2 = o->op_next; 8416 if (!o2 || o2->op_type != OP_NULL) 8417 return NULL; 8418 o2 = o2->op_next; 8419 if (!o2 || o2->op_type != OP_PUSHMARK) 8420 return NULL; 8421 o2 = o2->op_next; 8422 if (o2 && o2->op_type == OP_GV) 8423 o2 = o2->op_next; 8424 if (!o2 8425 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV) 8426 || (o2->op_private & OPpLVAL_INTRO) 8427 ) 8428 return NULL; 8429 oleft = o2; 8430 o2 = o2->op_next; 8431 if (!o2 || o2->op_type != OP_NULL) 8432 return NULL; 8433 o2 = o2->op_next; 8434 if (!o2 || o2->op_type != OP_AASSIGN 8435 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID) 8436 return NULL; 8437 8438 /* check that the sort is the first arg on RHS of assign */ 8439 8440 o2 = cUNOPx(o2)->op_first; 8441 if (!o2 || o2->op_type != OP_NULL) 8442 return NULL; 8443 o2 = cUNOPx(o2)->op_first; 8444 if (!o2 || o2->op_type != OP_PUSHMARK) 8445 return NULL; 8446 if (o2->op_sibling != o) 8447 return NULL; 8448 8449 /* check the array is the same on both sides */ 8450 if (oleft->op_type == OP_RV2AV) { 8451 if (oright->op_type != OP_RV2AV 8452 || !cUNOPx(oright)->op_first 8453 || cUNOPx(oright)->op_first->op_type != OP_GV 8454 || cGVOPx_gv(cUNOPx(oleft)->op_first) != 8455 cGVOPx_gv(cUNOPx(oright)->op_first) 8456 ) 8457 return NULL; 8458 } 8459 else if (oright->op_type != OP_PADAV 8460 || oright->op_targ != oleft->op_targ 8461 ) 8462 return NULL; 8463 8464 return oleft; 8465 } 8466 8467 /* A peephole optimizer. We visit the ops in the order they're to execute. 8468 * See the comments at the top of this file for more details about when 8469 * peep() is called */ 8470 8471 void 8472 Perl_peep(pTHX_ register OP *o) 8473 { 8474 dVAR; 8475 register OP* oldop = NULL; 8476 8477 if (!o || o->op_opt) 8478 return; 8479 ENTER; 8480 SAVEOP(); 8481 SAVEVPTR(PL_curcop); 8482 for (; o; o = o->op_next) { 8483 if (o->op_opt) 8484 break; 8485 /* By default, this op has now been optimised. A couple of cases below 8486 clear this again. */ 8487 o->op_opt = 1; 8488 PL_op = o; 8489 switch (o->op_type) { 8490 case OP_NEXTSTATE: 8491 case OP_DBSTATE: 8492 PL_curcop = ((COP*)o); /* for warnings */ 8493 break; 8494 8495 case OP_CONST: 8496 if (cSVOPo->op_private & OPpCONST_STRICT) 8497 no_bareword_allowed(o); 8498 #ifdef USE_ITHREADS 8499 case OP_HINTSEVAL: 8500 case OP_METHOD_NAMED: 8501 /* Relocate sv to the pad for thread safety. 8502 * Despite being a "constant", the SV is written to, 8503 * for reference counts, sv_upgrade() etc. */ 8504 if (cSVOP->op_sv) { 8505 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP); 8506 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) { 8507 /* If op_sv is already a PADTMP then it is being used by 8508 * some pad, so make a copy. */ 8509 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv); 8510 SvREADONLY_on(PAD_SVl(ix)); 8511 SvREFCNT_dec(cSVOPo->op_sv); 8512 } 8513 else if (o->op_type != OP_METHOD_NAMED 8514 && cSVOPo->op_sv == &PL_sv_undef) { 8515 /* PL_sv_undef is hack - it's unsafe to store it in the 8516 AV that is the pad, because av_fetch treats values of 8517 PL_sv_undef as a "free" AV entry and will merrily 8518 replace them with a new SV, causing pad_alloc to think 8519 that this pad slot is free. (When, clearly, it is not) 8520 */ 8521 SvOK_off(PAD_SVl(ix)); 8522 SvPADTMP_on(PAD_SVl(ix)); 8523 SvREADONLY_on(PAD_SVl(ix)); 8524 } 8525 else { 8526 SvREFCNT_dec(PAD_SVl(ix)); 8527 SvPADTMP_on(cSVOPo->op_sv); 8528 PAD_SETSV(ix, cSVOPo->op_sv); 8529 /* XXX I don't know how this isn't readonly already. */ 8530 SvREADONLY_on(PAD_SVl(ix)); 8531 } 8532 cSVOPo->op_sv = NULL; 8533 o->op_targ = ix; 8534 } 8535 #endif 8536 break; 8537 8538 case OP_CONCAT: 8539 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) { 8540 if (o->op_next->op_private & OPpTARGET_MY) { 8541 if (o->op_flags & OPf_STACKED) /* chained concats */ 8542 break; /* ignore_optimization */ 8543 else { 8544 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */ 8545 o->op_targ = o->op_next->op_targ; 8546 o->op_next->op_targ = 0; 8547 o->op_private |= OPpTARGET_MY; 8548 } 8549 } 8550 op_null(o->op_next); 8551 } 8552 break; 8553 case OP_STUB: 8554 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) { 8555 break; /* Scalar stub must produce undef. List stub is noop */ 8556 } 8557 goto nothin; 8558 case OP_NULL: 8559 if (o->op_targ == OP_NEXTSTATE 8560 || o->op_targ == OP_DBSTATE) 8561 { 8562 PL_curcop = ((COP*)o); 8563 } 8564 /* XXX: We avoid setting op_seq here to prevent later calls 8565 to peep() from mistakenly concluding that optimisation 8566 has already occurred. This doesn't fix the real problem, 8567 though (See 20010220.007). AMS 20010719 */ 8568 /* op_seq functionality is now replaced by op_opt */ 8569 o->op_opt = 0; 8570 /* FALL THROUGH */ 8571 case OP_SCALAR: 8572 case OP_LINESEQ: 8573 case OP_SCOPE: 8574 nothin: 8575 if (oldop && o->op_next) { 8576 oldop->op_next = o->op_next; 8577 o->op_opt = 0; 8578 continue; 8579 } 8580 break; 8581 8582 case OP_PADAV: 8583 case OP_GV: 8584 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) { 8585 OP* const pop = (o->op_type == OP_PADAV) ? 8586 o->op_next : o->op_next->op_next; 8587 IV i; 8588 if (pop && pop->op_type == OP_CONST && 8589 ((PL_op = pop->op_next)) && 8590 pop->op_next->op_type == OP_AELEM && 8591 !(pop->op_next->op_private & 8592 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) && 8593 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop)) 8594 <= 255 && 8595 i >= 0) 8596 { 8597 GV *gv; 8598 if (cSVOPx(pop)->op_private & OPpCONST_STRICT) 8599 no_bareword_allowed(pop); 8600 if (o->op_type == OP_GV) 8601 op_null(o->op_next); 8602 op_null(pop->op_next); 8603 op_null(pop); 8604 o->op_flags |= pop->op_next->op_flags & OPf_MOD; 8605 o->op_next = pop->op_next->op_next; 8606 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST]; 8607 o->op_private = (U8)i; 8608 if (o->op_type == OP_GV) { 8609 gv = cGVOPo_gv; 8610 GvAVn(gv); 8611 } 8612 else 8613 o->op_flags |= OPf_SPECIAL; 8614 o->op_type = OP_AELEMFAST; 8615 } 8616 break; 8617 } 8618 8619 if (o->op_next->op_type == OP_RV2SV) { 8620 if (!(o->op_next->op_private & OPpDEREF)) { 8621 op_null(o->op_next); 8622 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO 8623 | OPpOUR_INTRO); 8624 o->op_next = o->op_next->op_next; 8625 o->op_type = OP_GVSV; 8626 o->op_ppaddr = PL_ppaddr[OP_GVSV]; 8627 } 8628 } 8629 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) { 8630 GV * const gv = cGVOPo_gv; 8631 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) { 8632 /* XXX could check prototype here instead of just carping */ 8633 SV * const sv = sv_newmortal(); 8634 gv_efullname3(sv, gv, NULL); 8635 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), 8636 "%"SVf"() called too early to check prototype", 8637 SVfARG(sv)); 8638 } 8639 } 8640 else if (o->op_next->op_type == OP_READLINE 8641 && o->op_next->op_next->op_type == OP_CONCAT 8642 && (o->op_next->op_next->op_flags & OPf_STACKED)) 8643 { 8644 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */ 8645 o->op_type = OP_RCATLINE; 8646 o->op_flags |= OPf_STACKED; 8647 o->op_ppaddr = PL_ppaddr[OP_RCATLINE]; 8648 op_null(o->op_next->op_next); 8649 op_null(o->op_next); 8650 } 8651 8652 break; 8653 8654 { 8655 OP *fop; 8656 OP *sop; 8657 8658 case OP_NOT: 8659 fop = cUNOP->op_first; 8660 sop = NULL; 8661 goto stitch_keys; 8662 break; 8663 8664 case OP_AND: 8665 case OP_OR: 8666 case OP_DOR: 8667 fop = cLOGOP->op_first; 8668 sop = fop->op_sibling; 8669 while (cLOGOP->op_other->op_type == OP_NULL) 8670 cLOGOP->op_other = cLOGOP->op_other->op_next; 8671 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */ 8672 8673 stitch_keys: 8674 o->op_opt = 1; 8675 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV) 8676 || ( sop && 8677 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV) 8678 ) 8679 ){ 8680 OP * nop = o; 8681 OP * lop = o; 8682 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) { 8683 while (nop && nop->op_next) { 8684 switch (nop->op_next->op_type) { 8685 case OP_NOT: 8686 case OP_AND: 8687 case OP_OR: 8688 case OP_DOR: 8689 lop = nop = nop->op_next; 8690 break; 8691 case OP_NULL: 8692 nop = nop->op_next; 8693 break; 8694 default: 8695 nop = NULL; 8696 break; 8697 } 8698 } 8699 } 8700 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) { 8701 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV) 8702 cLOGOP->op_first = opt_scalarhv(fop); 8703 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)) 8704 cLOGOP->op_first->op_sibling = opt_scalarhv(sop); 8705 } 8706 } 8707 8708 8709 break; 8710 } 8711 8712 case OP_MAPWHILE: 8713 case OP_GREPWHILE: 8714 case OP_ANDASSIGN: 8715 case OP_ORASSIGN: 8716 case OP_DORASSIGN: 8717 case OP_COND_EXPR: 8718 case OP_RANGE: 8719 case OP_ONCE: 8720 while (cLOGOP->op_other->op_type == OP_NULL) 8721 cLOGOP->op_other = cLOGOP->op_other->op_next; 8722 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */ 8723 break; 8724 8725 case OP_ENTERLOOP: 8726 case OP_ENTERITER: 8727 while (cLOOP->op_redoop->op_type == OP_NULL) 8728 cLOOP->op_redoop = cLOOP->op_redoop->op_next; 8729 peep(cLOOP->op_redoop); 8730 while (cLOOP->op_nextop->op_type == OP_NULL) 8731 cLOOP->op_nextop = cLOOP->op_nextop->op_next; 8732 peep(cLOOP->op_nextop); 8733 while (cLOOP->op_lastop->op_type == OP_NULL) 8734 cLOOP->op_lastop = cLOOP->op_lastop->op_next; 8735 peep(cLOOP->op_lastop); 8736 break; 8737 8738 case OP_SUBST: 8739 assert(!(cPMOP->op_pmflags & PMf_ONCE)); 8740 while (cPMOP->op_pmstashstartu.op_pmreplstart && 8741 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL) 8742 cPMOP->op_pmstashstartu.op_pmreplstart 8743 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next; 8744 peep(cPMOP->op_pmstashstartu.op_pmreplstart); 8745 break; 8746 8747 case OP_EXEC: 8748 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE 8749 && ckWARN(WARN_SYNTAX)) 8750 { 8751 if (o->op_next->op_sibling) { 8752 const OPCODE type = o->op_next->op_sibling->op_type; 8753 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) { 8754 const line_t oldline = CopLINE(PL_curcop); 8755 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next)); 8756 Perl_warner(aTHX_ packWARN(WARN_EXEC), 8757 "Statement unlikely to be reached"); 8758 Perl_warner(aTHX_ packWARN(WARN_EXEC), 8759 "\t(Maybe you meant system() when you said exec()?)\n"); 8760 CopLINE_set(PL_curcop, oldline); 8761 } 8762 } 8763 } 8764 break; 8765 8766 case OP_HELEM: { 8767 UNOP *rop; 8768 SV *lexname; 8769 GV **fields; 8770 SV **svp, *sv; 8771 const char *key = NULL; 8772 STRLEN keylen; 8773 8774 if (((BINOP*)o)->op_last->op_type != OP_CONST) 8775 break; 8776 8777 /* Make the CONST have a shared SV */ 8778 svp = cSVOPx_svp(((BINOP*)o)->op_last); 8779 if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) { 8780 key = SvPV_const(sv, keylen); 8781 lexname = newSVpvn_share(key, 8782 SvUTF8(sv) ? -(I32)keylen : (I32)keylen, 8783 0); 8784 SvREFCNT_dec(sv); 8785 *svp = lexname; 8786 } 8787 8788 if ((o->op_private & (OPpLVAL_INTRO))) 8789 break; 8790 8791 rop = (UNOP*)((BINOP*)o)->op_first; 8792 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV) 8793 break; 8794 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE); 8795 if (!SvPAD_TYPED(lexname)) 8796 break; 8797 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE); 8798 if (!fields || !GvHV(*fields)) 8799 break; 8800 key = SvPV_const(*svp, keylen); 8801 if (!hv_fetch(GvHV(*fields), key, 8802 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) 8803 { 8804 Perl_croak(aTHX_ "No such class field \"%s\" " 8805 "in variable %s of type %s", 8806 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname))); 8807 } 8808 8809 break; 8810 } 8811 8812 case OP_HSLICE: { 8813 UNOP *rop; 8814 SV *lexname; 8815 GV **fields; 8816 SV **svp; 8817 const char *key; 8818 STRLEN keylen; 8819 SVOP *first_key_op, *key_op; 8820 8821 if ((o->op_private & (OPpLVAL_INTRO)) 8822 /* I bet there's always a pushmark... */ 8823 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST) 8824 /* hmmm, no optimization if list contains only one key. */ 8825 break; 8826 rop = (UNOP*)((LISTOP*)o)->op_last; 8827 if (rop->op_type != OP_RV2HV) 8828 break; 8829 if (rop->op_first->op_type == OP_PADSV) 8830 /* @$hash{qw(keys here)} */ 8831 rop = (UNOP*)rop->op_first; 8832 else { 8833 /* @{$hash}{qw(keys here)} */ 8834 if (rop->op_first->op_type == OP_SCOPE 8835 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV) 8836 { 8837 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last; 8838 } 8839 else 8840 break; 8841 } 8842 8843 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE); 8844 if (!SvPAD_TYPED(lexname)) 8845 break; 8846 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE); 8847 if (!fields || !GvHV(*fields)) 8848 break; 8849 /* Again guessing that the pushmark can be jumped over.... */ 8850 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling) 8851 ->op_first->op_sibling; 8852 for (key_op = first_key_op; key_op; 8853 key_op = (SVOP*)key_op->op_sibling) { 8854 if (key_op->op_type != OP_CONST) 8855 continue; 8856 svp = cSVOPx_svp(key_op); 8857 key = SvPV_const(*svp, keylen); 8858 if (!hv_fetch(GvHV(*fields), key, 8859 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) 8860 { 8861 Perl_croak(aTHX_ "No such class field \"%s\" " 8862 "in variable %s of type %s", 8863 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname))); 8864 } 8865 } 8866 break; 8867 } 8868 8869 case OP_SORT: { 8870 /* will point to RV2AV or PADAV op on LHS/RHS of assign */ 8871 OP *oleft; 8872 OP *o2; 8873 8874 /* check that RHS of sort is a single plain array */ 8875 OP *oright = cUNOPo->op_first; 8876 if (!oright || oright->op_type != OP_PUSHMARK) 8877 break; 8878 8879 /* reverse sort ... can be optimised. */ 8880 if (!cUNOPo->op_sibling) { 8881 /* Nothing follows us on the list. */ 8882 OP * const reverse = o->op_next; 8883 8884 if (reverse->op_type == OP_REVERSE && 8885 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) { 8886 OP * const pushmark = cUNOPx(reverse)->op_first; 8887 if (pushmark && (pushmark->op_type == OP_PUSHMARK) 8888 && (cUNOPx(pushmark)->op_sibling == o)) { 8889 /* reverse -> pushmark -> sort */ 8890 o->op_private |= OPpSORT_REVERSE; 8891 op_null(reverse); 8892 pushmark->op_next = oright->op_next; 8893 op_null(oright); 8894 } 8895 } 8896 } 8897 8898 /* make @a = sort @a act in-place */ 8899 8900 oright = cUNOPx(oright)->op_sibling; 8901 if (!oright) 8902 break; 8903 if (oright->op_type == OP_NULL) { /* skip sort block/sub */ 8904 oright = cUNOPx(oright)->op_sibling; 8905 } 8906 8907 oleft = is_inplace_av(o, oright); 8908 if (!oleft) 8909 break; 8910 8911 /* transfer MODishness etc from LHS arg to RHS arg */ 8912 oright->op_flags = oleft->op_flags; 8913 o->op_private |= OPpSORT_INPLACE; 8914 8915 /* excise push->gv->rv2av->null->aassign */ 8916 o2 = o->op_next->op_next; 8917 op_null(o2); /* PUSHMARK */ 8918 o2 = o2->op_next; 8919 if (o2->op_type == OP_GV) { 8920 op_null(o2); /* GV */ 8921 o2 = o2->op_next; 8922 } 8923 op_null(o2); /* RV2AV or PADAV */ 8924 o2 = o2->op_next->op_next; 8925 op_null(o2); /* AASSIGN */ 8926 8927 o->op_next = o2->op_next; 8928 8929 break; 8930 } 8931 8932 case OP_REVERSE: { 8933 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av; 8934 OP *gvop = NULL; 8935 OP *oleft, *oright; 8936 LISTOP *enter, *exlist; 8937 8938 /* @a = reverse @a */ 8939 if ((oright = cLISTOPo->op_first) 8940 && (oright->op_type == OP_PUSHMARK) 8941 && (oright = oright->op_sibling) 8942 && (oleft = is_inplace_av(o, oright))) { 8943 OP *o2; 8944 8945 /* transfer MODishness etc from LHS arg to RHS arg */ 8946 oright->op_flags = oleft->op_flags; 8947 o->op_private |= OPpREVERSE_INPLACE; 8948 8949 /* excise push->gv->rv2av->null->aassign */ 8950 o2 = o->op_next->op_next; 8951 op_null(o2); /* PUSHMARK */ 8952 o2 = o2->op_next; 8953 if (o2->op_type == OP_GV) { 8954 op_null(o2); /* GV */ 8955 o2 = o2->op_next; 8956 } 8957 op_null(o2); /* RV2AV or PADAV */ 8958 o2 = o2->op_next->op_next; 8959 op_null(o2); /* AASSIGN */ 8960 8961 o->op_next = o2->op_next; 8962 break; 8963 } 8964 8965 enter = (LISTOP *) o->op_next; 8966 if (!enter) 8967 break; 8968 if (enter->op_type == OP_NULL) { 8969 enter = (LISTOP *) enter->op_next; 8970 if (!enter) 8971 break; 8972 } 8973 /* for $a (...) will have OP_GV then OP_RV2GV here. 8974 for (...) just has an OP_GV. */ 8975 if (enter->op_type == OP_GV) { 8976 gvop = (OP *) enter; 8977 enter = (LISTOP *) enter->op_next; 8978 if (!enter) 8979 break; 8980 if (enter->op_type == OP_RV2GV) { 8981 enter = (LISTOP *) enter->op_next; 8982 if (!enter) 8983 break; 8984 } 8985 } 8986 8987 if (enter->op_type != OP_ENTERITER) 8988 break; 8989 8990 iter = enter->op_next; 8991 if (!iter || iter->op_type != OP_ITER) 8992 break; 8993 8994 expushmark = enter->op_first; 8995 if (!expushmark || expushmark->op_type != OP_NULL 8996 || expushmark->op_targ != OP_PUSHMARK) 8997 break; 8998 8999 exlist = (LISTOP *) expushmark->op_sibling; 9000 if (!exlist || exlist->op_type != OP_NULL 9001 || exlist->op_targ != OP_LIST) 9002 break; 9003 9004 if (exlist->op_last != o) { 9005 /* Mmm. Was expecting to point back to this op. */ 9006 break; 9007 } 9008 theirmark = exlist->op_first; 9009 if (!theirmark || theirmark->op_type != OP_PUSHMARK) 9010 break; 9011 9012 if (theirmark->op_sibling != o) { 9013 /* There's something between the mark and the reverse, eg 9014 for (1, reverse (...)) 9015 so no go. */ 9016 break; 9017 } 9018 9019 ourmark = ((LISTOP *)o)->op_first; 9020 if (!ourmark || ourmark->op_type != OP_PUSHMARK) 9021 break; 9022 9023 ourlast = ((LISTOP *)o)->op_last; 9024 if (!ourlast || ourlast->op_next != o) 9025 break; 9026 9027 rv2av = ourmark->op_sibling; 9028 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0 9029 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS) 9030 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) { 9031 /* We're just reversing a single array. */ 9032 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF; 9033 enter->op_flags |= OPf_STACKED; 9034 } 9035 9036 /* We don't have control over who points to theirmark, so sacrifice 9037 ours. */ 9038 theirmark->op_next = ourmark->op_next; 9039 theirmark->op_flags = ourmark->op_flags; 9040 ourlast->op_next = gvop ? gvop : (OP *) enter; 9041 op_null(ourmark); 9042 op_null(o); 9043 enter->op_private |= OPpITER_REVERSED; 9044 iter->op_private |= OPpITER_REVERSED; 9045 9046 break; 9047 } 9048 9049 case OP_SASSIGN: { 9050 OP *rv2gv; 9051 UNOP *refgen, *rv2cv; 9052 LISTOP *exlist; 9053 9054 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID) 9055 break; 9056 9057 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2) 9058 break; 9059 9060 rv2gv = ((BINOP *)o)->op_last; 9061 if (!rv2gv || rv2gv->op_type != OP_RV2GV) 9062 break; 9063 9064 refgen = (UNOP *)((BINOP *)o)->op_first; 9065 9066 if (!refgen || refgen->op_type != OP_REFGEN) 9067 break; 9068 9069 exlist = (LISTOP *)refgen->op_first; 9070 if (!exlist || exlist->op_type != OP_NULL 9071 || exlist->op_targ != OP_LIST) 9072 break; 9073 9074 if (exlist->op_first->op_type != OP_PUSHMARK) 9075 break; 9076 9077 rv2cv = (UNOP*)exlist->op_last; 9078 9079 if (rv2cv->op_type != OP_RV2CV) 9080 break; 9081 9082 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0); 9083 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0); 9084 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0); 9085 9086 o->op_private |= OPpASSIGN_CV_TO_GV; 9087 rv2gv->op_private |= OPpDONT_INIT_GV; 9088 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT; 9089 9090 break; 9091 } 9092 9093 9094 case OP_QR: 9095 case OP_MATCH: 9096 if (!(cPMOP->op_pmflags & PMf_ONCE)) { 9097 assert (!cPMOP->op_pmstashstartu.op_pmreplstart); 9098 } 9099 break; 9100 } 9101 oldop = o; 9102 } 9103 LEAVE; 9104 } 9105 9106 const char* 9107 Perl_custom_op_name(pTHX_ const OP* o) 9108 { 9109 dVAR; 9110 const IV index = PTR2IV(o->op_ppaddr); 9111 SV* keysv; 9112 HE* he; 9113 9114 PERL_ARGS_ASSERT_CUSTOM_OP_NAME; 9115 9116 if (!PL_custom_op_names) /* This probably shouldn't happen */ 9117 return (char *)PL_op_name[OP_CUSTOM]; 9118 9119 keysv = sv_2mortal(newSViv(index)); 9120 9121 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0); 9122 if (!he) 9123 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */ 9124 9125 return SvPV_nolen(HeVAL(he)); 9126 } 9127 9128 const char* 9129 Perl_custom_op_desc(pTHX_ const OP* o) 9130 { 9131 dVAR; 9132 const IV index = PTR2IV(o->op_ppaddr); 9133 SV* keysv; 9134 HE* he; 9135 9136 PERL_ARGS_ASSERT_CUSTOM_OP_DESC; 9137 9138 if (!PL_custom_op_descs) 9139 return (char *)PL_op_desc[OP_CUSTOM]; 9140 9141 keysv = sv_2mortal(newSViv(index)); 9142 9143 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0); 9144 if (!he) 9145 return (char *)PL_op_desc[OP_CUSTOM]; 9146 9147 return SvPV_nolen(HeVAL(he)); 9148 } 9149 9150 #include "XSUB.h" 9151 9152 /* Efficient sub that returns a constant scalar value. */ 9153 static void 9154 const_sv_xsub(pTHX_ CV* cv) 9155 { 9156 dVAR; 9157 dXSARGS; 9158 SV *const sv = MUTABLE_SV(XSANY.any_ptr); 9159 if (items != 0) { 9160 NOOP; 9161 #if 0 9162 /* diag_listed_as: SKIPME */ 9163 Perl_croak(aTHX_ "usage: %s::%s()", 9164 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv))); 9165 #endif 9166 } 9167 if (!sv) { 9168 XSRETURN(0); 9169 } 9170 EXTEND(sp, 1); 9171 ST(0) = sv; 9172 XSRETURN(1); 9173 } 9174 9175 /* 9176 * Local variables: 9177 * c-indentation-style: bsd 9178 * c-basic-offset: 4 9179 * indent-tabs-mode: t 9180 * End: 9181 * 9182 * ex: set ts=8 sts=4 sw=4 noet: 9183 */ 9184