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