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