1 /* op.c 2 * 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 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 #include "EXTERN.h" 77 #define PERL_IN_OP_C 78 #include "perl.h" 79 #include "keywords.h" 80 81 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o) 82 83 #if defined(PL_OP_SLAB_ALLOC) 84 85 #ifndef PERL_SLAB_SIZE 86 #define PERL_SLAB_SIZE 2048 87 #endif 88 89 void * 90 Perl_Slab_Alloc(pTHX_ int m, size_t sz) 91 { 92 /* 93 * To make incrementing use count easy PL_OpSlab is an I32 * 94 * To make inserting the link to slab PL_OpPtr is I32 ** 95 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments 96 * Add an overhead for pointer to slab and round up as a number of pointers 97 */ 98 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *); 99 if ((PL_OpSpace -= sz) < 0) { 100 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*)); 101 if (!PL_OpPtr) { 102 return NULL; 103 } 104 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **); 105 /* We reserve the 0'th I32 sized chunk as a use count */ 106 PL_OpSlab = (I32 *) PL_OpPtr; 107 /* Reduce size by the use count word, and by the size we need. 108 * Latter is to mimic the '-=' in the if() above 109 */ 110 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz; 111 /* Allocation pointer starts at the top. 112 Theory: because we build leaves before trunk allocating at end 113 means that at run time access is cache friendly upward 114 */ 115 PL_OpPtr += PERL_SLAB_SIZE; 116 } 117 assert( PL_OpSpace >= 0 ); 118 /* Move the allocation pointer down */ 119 PL_OpPtr -= sz; 120 assert( PL_OpPtr > (I32 **) PL_OpSlab ); 121 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */ 122 (*PL_OpSlab)++; /* Increment use count of slab */ 123 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) ); 124 assert( *PL_OpSlab > 0 ); 125 return (void *)(PL_OpPtr + 1); 126 } 127 128 void 129 Perl_Slab_Free(pTHX_ void *op) 130 { 131 I32 * const * const ptr = (I32 **) op; 132 I32 * const slab = ptr[-1]; 133 assert( ptr-1 > (I32 **) slab ); 134 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) ); 135 assert( *slab > 0 ); 136 if (--(*slab) == 0) { 137 # ifdef NETWARE 138 # define PerlMemShared PerlMem 139 # endif 140 141 PerlMemShared_free(slab); 142 if (slab == PL_OpSlab) { 143 PL_OpSpace = 0; 144 } 145 } 146 } 147 #endif 148 /* 149 * In the following definition, the ", Nullop" is just to make the compiler 150 * think the expression is of the right type: croak actually does a Siglongjmp. 151 */ 152 #define CHECKOP(type,o) \ 153 ((PL_op_mask && PL_op_mask[type]) \ 154 ? ( op_free((OP*)o), \ 155 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \ 156 Nullop ) \ 157 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o)) 158 159 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2) 160 161 STATIC const char* 162 S_gv_ename(pTHX_ GV *gv) 163 { 164 SV* const tmpsv = sv_newmortal(); 165 gv_efullname3(tmpsv, gv, Nullch); 166 return SvPV_nolen_const(tmpsv); 167 } 168 169 STATIC OP * 170 S_no_fh_allowed(pTHX_ OP *o) 171 { 172 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function", 173 OP_DESC(o))); 174 return o; 175 } 176 177 STATIC OP * 178 S_too_few_arguments(pTHX_ OP *o, const char *name) 179 { 180 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name)); 181 return o; 182 } 183 184 STATIC OP * 185 S_too_many_arguments(pTHX_ OP *o, const char *name) 186 { 187 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name)); 188 return o; 189 } 190 191 STATIC void 192 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid) 193 { 194 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)", 195 (int)n, name, t, OP_DESC((OP *)kid))); 196 } 197 198 STATIC void 199 S_no_bareword_allowed(pTHX_ const OP *o) 200 { 201 qerror(Perl_mess(aTHX_ 202 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use", 203 cSVOPo_sv)); 204 } 205 206 /* "register" allocation */ 207 208 PADOFFSET 209 Perl_allocmy(pTHX_ char *name) 210 { 211 PADOFFSET off; 212 213 /* complain about "my $_" etc etc */ 214 if (!(PL_in_my == KEY_our || 215 isALPHA(name[1]) || 216 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) || 217 (name[1] == '_' && (int)strlen(name) > 2))) 218 { 219 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) { 220 /* 1999-02-27 mjd@plover.com */ 221 char *p; 222 p = strchr(name, '\0'); 223 /* The next block assumes the buffer is at least 205 chars 224 long. At present, it's always at least 256 chars. */ 225 if (p-name > 200) { 226 strcpy(name+200, "..."); 227 p = name+199; 228 } 229 else { 230 p[1] = '\0'; 231 } 232 /* Move everything else down one character */ 233 for (; p-name > 2; p--) 234 *p = *(p-1); 235 name[2] = toCTRL(name[1]); 236 name[1] = '^'; 237 } 238 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name)); 239 } 240 /* check for duplicate declaration */ 241 pad_check_dup(name, 242 (bool)(PL_in_my == KEY_our), 243 (PL_curstash ? PL_curstash : PL_defstash) 244 ); 245 246 if (PL_in_my_stash && *name != '$') { 247 yyerror(Perl_form(aTHX_ 248 "Can't declare class for non-scalar %s in \"%s\"", 249 name, PL_in_my == KEY_our ? "our" : "my")); 250 } 251 252 /* allocate a spare slot and store the name in that slot */ 253 254 off = pad_add_name(name, 255 PL_in_my_stash, 256 (PL_in_my == KEY_our 257 ? (PL_curstash ? PL_curstash : PL_defstash) 258 : Nullhv 259 ), 260 0 /* not fake */ 261 ); 262 return off; 263 } 264 265 266 #ifdef USE_5005THREADS 267 /* find_threadsv is not reentrant */ 268 PADOFFSET 269 Perl_find_threadsv(pTHX_ const char *name) 270 { 271 char *p; 272 PADOFFSET key; 273 SV **svp; 274 /* We currently only handle names of a single character */ 275 p = strchr(PL_threadsv_names, *name); 276 if (!p) 277 return NOT_IN_PAD; 278 key = p - PL_threadsv_names; 279 MUTEX_LOCK(&thr->mutex); 280 svp = av_fetch(thr->threadsv, key, FALSE); 281 if (svp) 282 MUTEX_UNLOCK(&thr->mutex); 283 else { 284 SV *sv = NEWSV(0, 0); 285 av_store(thr->threadsv, key, sv); 286 thr->threadsvp = AvARRAY(thr->threadsv); 287 MUTEX_UNLOCK(&thr->mutex); 288 /* 289 * Some magic variables used to be automagically initialised 290 * in gv_fetchpv. Those which are now per-thread magicals get 291 * initialised here instead. 292 */ 293 switch (*name) { 294 case '_': 295 break; 296 case ';': 297 sv_setpv(sv, "\034"); 298 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1); 299 break; 300 case '&': 301 case '`': 302 case '\'': 303 PL_sawampersand = TRUE; 304 /* FALL THROUGH */ 305 case '1': 306 case '2': 307 case '3': 308 case '4': 309 case '5': 310 case '6': 311 case '7': 312 case '8': 313 case '9': 314 SvREADONLY_on(sv); 315 /* FALL THROUGH */ 316 317 /* XXX %! tied to Errno.pm needs to be added here. 318 * See gv_fetchpv(). */ 319 /* case '!': */ 320 321 default: 322 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1); 323 } 324 DEBUG_S(PerlIO_printf(Perl_error_log, 325 "find_threadsv: new SV %p for $%s%c\n", 326 sv, (*name < 32) ? "^" : "", 327 (*name < 32) ? toCTRL(*name) : *name)); 328 } 329 return key; 330 } 331 #endif /* USE_5005THREADS */ 332 333 /* Destructor */ 334 335 void 336 Perl_op_free(pTHX_ OP *o) 337 { 338 OPCODE type; 339 PADOFFSET refcnt; 340 341 if (!o || o->op_seq == (U16)-1) 342 return; 343 344 if (o->op_private & OPpREFCOUNTED) { 345 switch (o->op_type) { 346 case OP_LEAVESUB: 347 case OP_LEAVESUBLV: 348 case OP_LEAVEEVAL: 349 case OP_LEAVE: 350 case OP_SCOPE: 351 case OP_LEAVEWRITE: 352 OP_REFCNT_LOCK; 353 refcnt = OpREFCNT_dec(o); 354 OP_REFCNT_UNLOCK; 355 if (refcnt) 356 return; 357 break; 358 default: 359 break; 360 } 361 } 362 363 if (o->op_flags & OPf_KIDS) { 364 register OP *kid, *nextkid; 365 for (kid = cUNOPo->op_first; kid; kid = nextkid) { 366 nextkid = kid->op_sibling; /* Get before next freeing kid */ 367 op_free(kid); 368 } 369 } 370 type = o->op_type; 371 if (type == OP_NULL) 372 type = (OPCODE)o->op_targ; 373 374 /* COP* is not cleared by op_clear() so that we may track line 375 * numbers etc even after null() */ 376 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE) 377 cop_free((COP*)o); 378 379 op_clear(o); 380 FreeOp(o); 381 } 382 383 void 384 Perl_op_clear(pTHX_ OP *o) 385 { 386 387 switch (o->op_type) { 388 case OP_NULL: /* Was holding old type, if any. */ 389 case OP_ENTEREVAL: /* Was holding hints. */ 390 #ifdef USE_5005THREADS 391 case OP_THREADSV: /* Was holding index into thr->threadsv AV. */ 392 #endif 393 o->op_targ = 0; 394 break; 395 #ifdef USE_5005THREADS 396 case OP_ENTERITER: 397 if (!(o->op_flags & OPf_SPECIAL)) 398 break; 399 /* FALL THROUGH */ 400 #endif /* USE_5005THREADS */ 401 default: 402 if (!(o->op_flags & OPf_REF) 403 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst))) 404 break; 405 /* FALL THROUGH */ 406 case OP_GVSV: 407 case OP_GV: 408 case OP_AELEMFAST: 409 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) { 410 /* not an OP_PADAV replacement */ 411 #ifdef USE_ITHREADS 412 if (cPADOPo->op_padix > 0) { 413 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references 414 * may still exist on the pad */ 415 pad_swipe(cPADOPo->op_padix, TRUE); 416 cPADOPo->op_padix = 0; 417 } 418 #else 419 SvREFCNT_dec(cSVOPo->op_sv); 420 cSVOPo->op_sv = Nullsv; 421 #endif 422 } 423 break; 424 case OP_METHOD_NAMED: 425 case OP_CONST: 426 SvREFCNT_dec(cSVOPo->op_sv); 427 cSVOPo->op_sv = Nullsv; 428 #ifdef USE_ITHREADS 429 /** Bug #15654 430 Even if op_clear does a pad_free for the target of the op, 431 pad_free doesn't actually remove the sv that exists in the pad; 432 instead it lives on. This results in that it could be reused as 433 a target later on when the pad was reallocated. 434 **/ 435 if(o->op_targ) { 436 pad_swipe(o->op_targ,1); 437 o->op_targ = 0; 438 } 439 #endif 440 break; 441 case OP_GOTO: 442 case OP_NEXT: 443 case OP_LAST: 444 case OP_REDO: 445 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS)) 446 break; 447 /* FALL THROUGH */ 448 case OP_TRANS: 449 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) { 450 SvREFCNT_dec(cSVOPo->op_sv); 451 cSVOPo->op_sv = Nullsv; 452 } 453 else { 454 Safefree(cPVOPo->op_pv); 455 cPVOPo->op_pv = Nullch; 456 } 457 break; 458 case OP_SUBST: 459 op_free(cPMOPo->op_pmreplroot); 460 goto clear_pmop; 461 case OP_PUSHRE: 462 #ifdef USE_ITHREADS 463 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) { 464 /* No GvIN_PAD_off here, because other references may still 465 * exist on the pad */ 466 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE); 467 } 468 #else 469 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot); 470 #endif 471 /* FALL THROUGH */ 472 case OP_MATCH: 473 case OP_QR: 474 clear_pmop: 475 { 476 HV * const pmstash = PmopSTASH(cPMOPo); 477 if (pmstash && SvREFCNT(pmstash)) { 478 PMOP *pmop = HvPMROOT(pmstash); 479 PMOP *lastpmop = NULL; 480 while (pmop) { 481 if (cPMOPo == pmop) { 482 if (lastpmop) 483 lastpmop->op_pmnext = pmop->op_pmnext; 484 else 485 HvPMROOT(pmstash) = pmop->op_pmnext; 486 break; 487 } 488 lastpmop = pmop; 489 pmop = pmop->op_pmnext; 490 } 491 } 492 PmopSTASH_free(cPMOPo); 493 } 494 cPMOPo->op_pmreplroot = Nullop; 495 /* we use the "SAFE" version of the PM_ macros here 496 * since sv_clean_all might release some PMOPs 497 * after PL_regex_padav has been cleared 498 * and the clearing of PL_regex_padav needs to 499 * happen before sv_clean_all 500 */ 501 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo)); 502 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL); 503 #ifdef USE_ITHREADS 504 if(PL_regex_pad) { /* We could be in destruction */ 505 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]); 506 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]); 507 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset); 508 } 509 #endif 510 511 break; 512 } 513 514 if (o->op_targ > 0) { 515 pad_free(o->op_targ); 516 o->op_targ = 0; 517 } 518 } 519 520 STATIC void 521 S_cop_free(pTHX_ COP* cop) 522 { 523 Safefree(cop->cop_label); /* FIXME: treaddead ??? */ 524 CopFILE_free(cop); 525 CopSTASH_free(cop); 526 if (! specialWARN(cop->cop_warnings)) 527 SvREFCNT_dec(cop->cop_warnings); 528 if (! specialCopIO(cop->cop_io)) { 529 #ifdef USE_ITHREADS 530 #if 0 531 STRLEN len; 532 char *s = SvPV(cop->cop_io,len); 533 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */ 534 #endif 535 #else 536 SvREFCNT_dec(cop->cop_io); 537 #endif 538 } 539 } 540 541 void 542 Perl_op_null(pTHX_ OP *o) 543 { 544 if (o->op_type == OP_NULL) 545 return; 546 op_clear(o); 547 o->op_targ = o->op_type; 548 o->op_type = OP_NULL; 549 o->op_ppaddr = PL_ppaddr[OP_NULL]; 550 } 551 552 void 553 Perl_op_refcnt_lock(pTHX) 554 { 555 OP_REFCNT_LOCK; 556 } 557 558 void 559 Perl_op_refcnt_unlock(pTHX) 560 { 561 OP_REFCNT_UNLOCK; 562 } 563 564 /* Contextualizers */ 565 566 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o)) 567 568 OP * 569 Perl_linklist(pTHX_ OP *o) 570 { 571 572 if (o->op_next) 573 return o->op_next; 574 575 /* establish postfix order */ 576 if (cUNOPo->op_first) { 577 register OP *kid; 578 o->op_next = LINKLIST(cUNOPo->op_first); 579 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { 580 if (kid->op_sibling) 581 kid->op_next = LINKLIST(kid->op_sibling); 582 else 583 kid->op_next = o; 584 } 585 } 586 else 587 o->op_next = o; 588 589 return o->op_next; 590 } 591 592 OP * 593 Perl_scalarkids(pTHX_ OP *o) 594 { 595 if (o && o->op_flags & OPf_KIDS) { 596 OP *kid; 597 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 598 scalar(kid); 599 } 600 return o; 601 } 602 603 STATIC OP * 604 S_scalarboolean(pTHX_ OP *o) 605 { 606 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) { 607 if (ckWARN(WARN_SYNTAX)) { 608 const line_t oldline = CopLINE(PL_curcop); 609 610 if (PL_copline != NOLINE) 611 CopLINE_set(PL_curcop, PL_copline); 612 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be =="); 613 CopLINE_set(PL_curcop, oldline); 614 } 615 } 616 return scalar(o); 617 } 618 619 OP * 620 Perl_scalar(pTHX_ OP *o) 621 { 622 OP *kid; 623 624 /* assumes no premature commitment */ 625 if (!o || PL_error_count || (o->op_flags & OPf_WANT) 626 || o->op_type == OP_RETURN) 627 { 628 return o; 629 } 630 631 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR; 632 633 switch (o->op_type) { 634 case OP_REPEAT: 635 scalar(cBINOPo->op_first); 636 break; 637 case OP_OR: 638 case OP_AND: 639 case OP_COND_EXPR: 640 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) 641 scalar(kid); 642 break; 643 case OP_SPLIT: 644 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) { 645 if (!kPMOP->op_pmreplroot) 646 deprecate_old("implicit split to @_"); 647 } 648 /* FALL THROUGH */ 649 case OP_MATCH: 650 case OP_QR: 651 case OP_SUBST: 652 case OP_NULL: 653 default: 654 if (o->op_flags & OPf_KIDS) { 655 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) 656 scalar(kid); 657 } 658 break; 659 case OP_LEAVE: 660 case OP_LEAVETRY: 661 kid = cLISTOPo->op_first; 662 scalar(kid); 663 while ((kid = kid->op_sibling)) { 664 if (kid->op_sibling) 665 scalarvoid(kid); 666 else 667 scalar(kid); 668 } 669 WITH_THR(PL_curcop = &PL_compiling); 670 break; 671 case OP_SCOPE: 672 case OP_LINESEQ: 673 case OP_LIST: 674 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { 675 if (kid->op_sibling) 676 scalarvoid(kid); 677 else 678 scalar(kid); 679 } 680 WITH_THR(PL_curcop = &PL_compiling); 681 break; 682 case OP_SORT: 683 if (ckWARN(WARN_VOID)) 684 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context"); 685 } 686 return o; 687 } 688 689 OP * 690 Perl_scalarvoid(pTHX_ OP *o) 691 { 692 OP *kid; 693 const char* useless = 0; 694 SV* sv; 695 U8 want; 696 697 if (o->op_type == OP_NEXTSTATE 698 || o->op_type == OP_SETSTATE 699 || o->op_type == OP_DBSTATE 700 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE 701 || o->op_targ == OP_SETSTATE 702 || o->op_targ == OP_DBSTATE))) 703 PL_curcop = (COP*)o; /* for warning below */ 704 705 /* assumes no premature commitment */ 706 want = o->op_flags & OPf_WANT; 707 if ((want && want != OPf_WANT_SCALAR) || PL_error_count 708 || o->op_type == OP_RETURN) 709 { 710 return o; 711 } 712 713 if ((o->op_private & OPpTARGET_MY) 714 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */ 715 { 716 return scalar(o); /* As if inside SASSIGN */ 717 } 718 719 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID; 720 721 switch (o->op_type) { 722 default: 723 if (!(PL_opargs[o->op_type] & OA_FOLDCONST)) 724 break; 725 /* FALL THROUGH */ 726 case OP_REPEAT: 727 if (o->op_flags & OPf_STACKED) 728 break; 729 goto func_ops; 730 case OP_SUBSTR: 731 if (o->op_private == 4) 732 break; 733 /* FALL THROUGH */ 734 case OP_GVSV: 735 case OP_WANTARRAY: 736 case OP_GV: 737 case OP_PADSV: 738 case OP_PADAV: 739 case OP_PADHV: 740 case OP_PADANY: 741 case OP_AV2ARYLEN: 742 case OP_REF: 743 case OP_REFGEN: 744 case OP_SREFGEN: 745 case OP_DEFINED: 746 case OP_HEX: 747 case OP_OCT: 748 case OP_LENGTH: 749 case OP_VEC: 750 case OP_INDEX: 751 case OP_RINDEX: 752 case OP_SPRINTF: 753 case OP_AELEM: 754 case OP_AELEMFAST: 755 case OP_ASLICE: 756 case OP_HELEM: 757 case OP_HSLICE: 758 case OP_UNPACK: 759 case OP_PACK: 760 case OP_JOIN: 761 case OP_LSLICE: 762 case OP_ANONLIST: 763 case OP_ANONHASH: 764 case OP_SORT: 765 case OP_REVERSE: 766 case OP_RANGE: 767 case OP_FLIP: 768 case OP_FLOP: 769 case OP_CALLER: 770 case OP_FILENO: 771 case OP_EOF: 772 case OP_TELL: 773 case OP_GETSOCKNAME: 774 case OP_GETPEERNAME: 775 case OP_READLINK: 776 case OP_TELLDIR: 777 case OP_GETPPID: 778 case OP_GETPGRP: 779 case OP_GETPRIORITY: 780 case OP_TIME: 781 case OP_TMS: 782 case OP_LOCALTIME: 783 case OP_GMTIME: 784 case OP_GHBYNAME: 785 case OP_GHBYADDR: 786 case OP_GHOSTENT: 787 case OP_GNBYNAME: 788 case OP_GNBYADDR: 789 case OP_GNETENT: 790 case OP_GPBYNAME: 791 case OP_GPBYNUMBER: 792 case OP_GPROTOENT: 793 case OP_GSBYNAME: 794 case OP_GSBYPORT: 795 case OP_GSERVENT: 796 case OP_GPWNAM: 797 case OP_GPWUID: 798 case OP_GGRNAM: 799 case OP_GGRGID: 800 case OP_GETLOGIN: 801 case OP_PROTOTYPE: 802 func_ops: 803 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO))) 804 useless = OP_DESC(o); 805 break; 806 807 case OP_RV2GV: 808 case OP_RV2SV: 809 case OP_RV2AV: 810 case OP_RV2HV: 811 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) && 812 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE)) 813 useless = "a variable"; 814 break; 815 816 case OP_CONST: 817 sv = cSVOPo_sv; 818 if (cSVOPo->op_private & OPpCONST_STRICT) 819 no_bareword_allowed(o); 820 else { 821 if (ckWARN(WARN_VOID)) { 822 useless = "a constant"; 823 /* don't warn on optimised away booleans, eg 824 * use constant Foo, 5; Foo || print; */ 825 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT) 826 useless = 0; 827 /* the constants 0 and 1 are permitted as they are 828 conventionally used as dummies in constructs like 829 1 while some_condition_with_side_effects; */ 830 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0)) 831 useless = 0; 832 else if (SvPOK(sv)) { 833 /* perl4's way of mixing documentation and code 834 (before the invention of POD) was based on a 835 trick to mix nroff and perl code. The trick was 836 built upon these three nroff macros being used in 837 void context. The pink camel has the details in 838 the script wrapman near page 319. */ 839 if (strnEQ(SvPVX_const(sv), "di", 2) || 840 strnEQ(SvPVX_const(sv), "ds", 2) || 841 strnEQ(SvPVX_const(sv), "ig", 2)) 842 useless = 0; 843 } 844 } 845 } 846 op_null(o); /* don't execute or even remember it */ 847 break; 848 849 case OP_POSTINC: 850 o->op_type = OP_PREINC; /* pre-increment is faster */ 851 o->op_ppaddr = PL_ppaddr[OP_PREINC]; 852 break; 853 854 case OP_POSTDEC: 855 o->op_type = OP_PREDEC; /* pre-decrement is faster */ 856 o->op_ppaddr = PL_ppaddr[OP_PREDEC]; 857 break; 858 859 case OP_I_POSTINC: 860 o->op_type = OP_I_PREINC; /* pre-increment is faster */ 861 o->op_ppaddr = PL_ppaddr[OP_I_PREINC]; 862 break; 863 864 case OP_I_POSTDEC: 865 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */ 866 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC]; 867 break; 868 869 case OP_OR: 870 case OP_AND: 871 case OP_COND_EXPR: 872 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) 873 scalarvoid(kid); 874 break; 875 876 case OP_NULL: 877 if (o->op_flags & OPf_STACKED) 878 break; 879 /* FALL THROUGH */ 880 case OP_NEXTSTATE: 881 case OP_DBSTATE: 882 case OP_ENTERTRY: 883 case OP_ENTER: 884 if (!(o->op_flags & OPf_KIDS)) 885 break; 886 /* FALL THROUGH */ 887 case OP_SCOPE: 888 case OP_LEAVE: 889 case OP_LEAVETRY: 890 case OP_LEAVELOOP: 891 case OP_LINESEQ: 892 case OP_LIST: 893 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 894 scalarvoid(kid); 895 break; 896 case OP_ENTEREVAL: 897 scalarkids(o); 898 break; 899 case OP_REQUIRE: 900 /* all requires must return a boolean value */ 901 o->op_flags &= ~OPf_WANT; 902 /* FALL THROUGH */ 903 case OP_SCALAR: 904 return scalar(o); 905 case OP_SPLIT: 906 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) { 907 if (!kPMOP->op_pmreplroot) 908 deprecate_old("implicit split to @_"); 909 } 910 break; 911 } 912 if (useless && ckWARN(WARN_VOID)) 913 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless); 914 return o; 915 } 916 917 OP * 918 Perl_listkids(pTHX_ OP *o) 919 { 920 if (o && o->op_flags & OPf_KIDS) { 921 OP *kid; 922 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 923 list(kid); 924 } 925 return o; 926 } 927 928 OP * 929 Perl_list(pTHX_ OP *o) 930 { 931 OP *kid; 932 933 /* assumes no premature commitment */ 934 if (!o || (o->op_flags & OPf_WANT) || PL_error_count 935 || o->op_type == OP_RETURN) 936 { 937 return o; 938 } 939 940 if ((o->op_private & OPpTARGET_MY) 941 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */ 942 { 943 return o; /* As if inside SASSIGN */ 944 } 945 946 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST; 947 948 switch (o->op_type) { 949 case OP_FLOP: 950 case OP_REPEAT: 951 list(cBINOPo->op_first); 952 break; 953 case OP_OR: 954 case OP_AND: 955 case OP_COND_EXPR: 956 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) 957 list(kid); 958 break; 959 default: 960 case OP_MATCH: 961 case OP_QR: 962 case OP_SUBST: 963 case OP_NULL: 964 if (!(o->op_flags & OPf_KIDS)) 965 break; 966 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) { 967 list(cBINOPo->op_first); 968 return gen_constant_list(o); 969 } 970 case OP_LIST: 971 listkids(o); 972 break; 973 case OP_LEAVE: 974 case OP_LEAVETRY: 975 kid = cLISTOPo->op_first; 976 list(kid); 977 while ((kid = kid->op_sibling)) { 978 if (kid->op_sibling) 979 scalarvoid(kid); 980 else 981 list(kid); 982 } 983 WITH_THR(PL_curcop = &PL_compiling); 984 break; 985 case OP_SCOPE: 986 case OP_LINESEQ: 987 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { 988 if (kid->op_sibling) 989 scalarvoid(kid); 990 else 991 list(kid); 992 } 993 WITH_THR(PL_curcop = &PL_compiling); 994 break; 995 case OP_REQUIRE: 996 /* all requires must return a boolean value */ 997 o->op_flags &= ~OPf_WANT; 998 return scalar(o); 999 } 1000 return o; 1001 } 1002 1003 OP * 1004 Perl_scalarseq(pTHX_ OP *o) 1005 { 1006 if (o) { 1007 if (o->op_type == OP_LINESEQ || 1008 o->op_type == OP_SCOPE || 1009 o->op_type == OP_LEAVE || 1010 o->op_type == OP_LEAVETRY) 1011 { 1012 OP *kid; 1013 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { 1014 if (kid->op_sibling) { 1015 scalarvoid(kid); 1016 } 1017 } 1018 PL_curcop = &PL_compiling; 1019 } 1020 o->op_flags &= ~OPf_PARENS; 1021 if (PL_hints & HINT_BLOCK_SCOPE) 1022 o->op_flags |= OPf_PARENS; 1023 } 1024 else 1025 o = newOP(OP_STUB, 0); 1026 return o; 1027 } 1028 1029 STATIC OP * 1030 S_modkids(pTHX_ OP *o, I32 type) 1031 { 1032 if (o && o->op_flags & OPf_KIDS) { 1033 OP *kid; 1034 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 1035 mod(kid, type); 1036 } 1037 return o; 1038 } 1039 1040 OP * 1041 Perl_mod(pTHX_ OP *o, I32 type) 1042 { 1043 OP *kid; 1044 1045 if (!o || PL_error_count) 1046 return o; 1047 1048 if ((o->op_private & OPpTARGET_MY) 1049 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */ 1050 { 1051 return o; 1052 } 1053 1054 switch (o->op_type) { 1055 case OP_UNDEF: 1056 PL_modcount++; 1057 return o; 1058 case OP_CONST: 1059 if (!(o->op_private & (OPpCONST_ARYBASE))) 1060 goto nomod; 1061 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) { 1062 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv); 1063 PL_eval_start = 0; 1064 } 1065 else if (!type) { 1066 SAVEI32(PL_compiling.cop_arybase); 1067 PL_compiling.cop_arybase = 0; 1068 } 1069 else if (type == OP_REFGEN) 1070 goto nomod; 1071 else 1072 Perl_croak(aTHX_ "That use of $[ is unsupported"); 1073 break; 1074 case OP_STUB: 1075 if (o->op_flags & OPf_PARENS) 1076 break; 1077 goto nomod; 1078 case OP_ENTERSUB: 1079 if ((type == OP_UNDEF || type == OP_REFGEN) && 1080 !(o->op_flags & OPf_STACKED)) { 1081 o->op_type = OP_RV2CV; /* entersub => rv2cv */ 1082 o->op_ppaddr = PL_ppaddr[OP_RV2CV]; 1083 assert(cUNOPo->op_first->op_type == OP_NULL); 1084 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */ 1085 break; 1086 } 1087 else if (o->op_private & OPpENTERSUB_NOMOD) 1088 return o; 1089 else { /* lvalue subroutine call */ 1090 o->op_private |= OPpLVAL_INTRO; 1091 PL_modcount = RETURN_UNLIMITED_NUMBER; 1092 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) { 1093 /* Backward compatibility mode: */ 1094 o->op_private |= OPpENTERSUB_INARGS; 1095 break; 1096 } 1097 else { /* Compile-time error message: */ 1098 OP *kid = cUNOPo->op_first; 1099 CV *cv; 1100 OP *okid; 1101 1102 if (kid->op_type == OP_PUSHMARK) 1103 goto skip_kids; 1104 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST) 1105 Perl_croak(aTHX_ 1106 "panic: unexpected lvalue entersub " 1107 "args: type/targ %ld:%"UVuf, 1108 (long)kid->op_type, (UV)kid->op_targ); 1109 kid = kLISTOP->op_first; 1110 skip_kids: 1111 while (kid->op_sibling) 1112 kid = kid->op_sibling; 1113 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) { 1114 /* Indirect call */ 1115 if (kid->op_type == OP_METHOD_NAMED 1116 || kid->op_type == OP_METHOD) 1117 { 1118 UNOP *newop; 1119 1120 NewOp(1101, newop, 1, UNOP); 1121 newop->op_type = OP_RV2CV; 1122 newop->op_ppaddr = PL_ppaddr[OP_RV2CV]; 1123 newop->op_first = Nullop; 1124 newop->op_next = (OP*)newop; 1125 kid->op_sibling = (OP*)newop; 1126 newop->op_private |= OPpLVAL_INTRO; 1127 break; 1128 } 1129 1130 if (kid->op_type != OP_RV2CV) 1131 Perl_croak(aTHX_ 1132 "panic: unexpected lvalue entersub " 1133 "entry via type/targ %ld:%"UVuf, 1134 (long)kid->op_type, (UV)kid->op_targ); 1135 kid->op_private |= OPpLVAL_INTRO; 1136 break; /* Postpone until runtime */ 1137 } 1138 1139 okid = kid; 1140 kid = kUNOP->op_first; 1141 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV) 1142 kid = kUNOP->op_first; 1143 if (kid->op_type == OP_NULL) 1144 Perl_croak(aTHX_ 1145 "Unexpected constant lvalue entersub " 1146 "entry via type/targ %ld:%"UVuf, 1147 (long)kid->op_type, (UV)kid->op_targ); 1148 if (kid->op_type != OP_GV) { 1149 /* Restore RV2CV to check lvalueness */ 1150 restore_2cv: 1151 if (kid->op_next && kid->op_next != kid) { /* Happens? */ 1152 okid->op_next = kid->op_next; 1153 kid->op_next = okid; 1154 } 1155 else 1156 okid->op_next = Nullop; 1157 okid->op_type = OP_RV2CV; 1158 okid->op_targ = 0; 1159 okid->op_ppaddr = PL_ppaddr[OP_RV2CV]; 1160 okid->op_private |= OPpLVAL_INTRO; 1161 break; 1162 } 1163 1164 cv = GvCV(kGVOP_gv); 1165 if (!cv) 1166 goto restore_2cv; 1167 if (CvLVALUE(cv)) 1168 break; 1169 } 1170 } 1171 /* FALL THROUGH */ 1172 default: 1173 nomod: 1174 /* grep, foreach, subcalls, refgen */ 1175 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) 1176 break; 1177 yyerror(Perl_form(aTHX_ "Can't modify %s in %s", 1178 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL) 1179 ? "do block" 1180 : (o->op_type == OP_ENTERSUB 1181 ? "non-lvalue subroutine call" 1182 : OP_DESC(o))), 1183 type ? PL_op_desc[type] : "local")); 1184 return o; 1185 1186 case OP_PREINC: 1187 case OP_PREDEC: 1188 case OP_POW: 1189 case OP_MULTIPLY: 1190 case OP_DIVIDE: 1191 case OP_MODULO: 1192 case OP_REPEAT: 1193 case OP_ADD: 1194 case OP_SUBTRACT: 1195 case OP_CONCAT: 1196 case OP_LEFT_SHIFT: 1197 case OP_RIGHT_SHIFT: 1198 case OP_BIT_AND: 1199 case OP_BIT_XOR: 1200 case OP_BIT_OR: 1201 case OP_I_MULTIPLY: 1202 case OP_I_DIVIDE: 1203 case OP_I_MODULO: 1204 case OP_I_ADD: 1205 case OP_I_SUBTRACT: 1206 if (!(o->op_flags & OPf_STACKED)) 1207 goto nomod; 1208 PL_modcount++; 1209 break; 1210 1211 case OP_COND_EXPR: 1212 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) 1213 mod(kid, type); 1214 break; 1215 1216 case OP_RV2AV: 1217 case OP_RV2HV: 1218 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) { 1219 PL_modcount = RETURN_UNLIMITED_NUMBER; 1220 return o; /* Treat \(@foo) like ordinary list. */ 1221 } 1222 /* FALL THROUGH */ 1223 case OP_RV2GV: 1224 if (scalar_mod_type(o, type)) 1225 goto nomod; 1226 ref(cUNOPo->op_first, o->op_type); 1227 /* FALL THROUGH */ 1228 case OP_ASLICE: 1229 case OP_HSLICE: 1230 if (type == OP_LEAVESUBLV) 1231 o->op_private |= OPpMAYBE_LVSUB; 1232 /* FALL THROUGH */ 1233 case OP_AASSIGN: 1234 case OP_NEXTSTATE: 1235 case OP_DBSTATE: 1236 PL_modcount = RETURN_UNLIMITED_NUMBER; 1237 break; 1238 case OP_RV2SV: 1239 ref(cUNOPo->op_first, o->op_type); 1240 /* FALL THROUGH */ 1241 case OP_GV: 1242 case OP_AV2ARYLEN: 1243 PL_hints |= HINT_BLOCK_SCOPE; 1244 case OP_SASSIGN: 1245 case OP_ANDASSIGN: 1246 case OP_ORASSIGN: 1247 case OP_AELEMFAST: 1248 /* Needed if maint gets patch 19588 1249 localize = -1; 1250 */ 1251 PL_modcount++; 1252 break; 1253 1254 case OP_PADAV: 1255 case OP_PADHV: 1256 PL_modcount = RETURN_UNLIMITED_NUMBER; 1257 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) 1258 return o; /* Treat \(@foo) like ordinary list. */ 1259 if (scalar_mod_type(o, type)) 1260 goto nomod; 1261 if (type == OP_LEAVESUBLV) 1262 o->op_private |= OPpMAYBE_LVSUB; 1263 /* FALL THROUGH */ 1264 case OP_PADSV: 1265 PL_modcount++; 1266 if (!type) 1267 { /* XXX DAPM 2002.08.25 tmp assert test */ 1268 /* XXX */ assert(av_fetch(PL_comppad_name, (o->op_targ), FALSE)); 1269 /* XXX */ assert(*av_fetch(PL_comppad_name, (o->op_targ), FALSE)); 1270 1271 Perl_croak(aTHX_ "Can't localize lexical variable %s", 1272 PAD_COMPNAME_PV(o->op_targ)); 1273 } 1274 break; 1275 1276 #ifdef USE_5005THREADS 1277 case OP_THREADSV: 1278 PL_modcount++; /* XXX ??? */ 1279 break; 1280 #endif /* USE_5005THREADS */ 1281 1282 case OP_PUSHMARK: 1283 break; 1284 1285 case OP_KEYS: 1286 if (type != OP_SASSIGN) 1287 goto nomod; 1288 goto lvalue_func; 1289 case OP_SUBSTR: 1290 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */ 1291 goto nomod; 1292 /* FALL THROUGH */ 1293 case OP_POS: 1294 case OP_VEC: 1295 if (type == OP_LEAVESUBLV) 1296 o->op_private |= OPpMAYBE_LVSUB; 1297 lvalue_func: 1298 pad_free(o->op_targ); 1299 o->op_targ = pad_alloc(o->op_type, SVs_PADMY); 1300 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL); 1301 if (o->op_flags & OPf_KIDS) 1302 mod(cBINOPo->op_first->op_sibling, type); 1303 break; 1304 1305 case OP_AELEM: 1306 case OP_HELEM: 1307 ref(cBINOPo->op_first, o->op_type); 1308 if (type == OP_ENTERSUB && 1309 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF))) 1310 o->op_private |= OPpLVAL_DEFER; 1311 if (type == OP_LEAVESUBLV) 1312 o->op_private |= OPpMAYBE_LVSUB; 1313 PL_modcount++; 1314 break; 1315 1316 case OP_SCOPE: 1317 case OP_LEAVE: 1318 case OP_ENTER: 1319 case OP_LINESEQ: 1320 if (o->op_flags & OPf_KIDS) 1321 mod(cLISTOPo->op_last, type); 1322 break; 1323 1324 case OP_NULL: 1325 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */ 1326 goto nomod; 1327 else if (!(o->op_flags & OPf_KIDS)) 1328 break; 1329 if (o->op_targ != OP_LIST) { 1330 mod(cBINOPo->op_first, type); 1331 break; 1332 } 1333 /* FALL THROUGH */ 1334 case OP_LIST: 1335 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 1336 mod(kid, type); 1337 break; 1338 1339 case OP_RETURN: 1340 if (type != OP_LEAVESUBLV) 1341 goto nomod; 1342 break; /* mod()ing was handled by ck_return() */ 1343 } 1344 1345 /* [20011101.069] File test operators interpret OPf_REF to mean that 1346 their argument is a filehandle; thus \stat(".") should not set 1347 it. AMS 20011102 */ 1348 if (type == OP_REFGEN && 1349 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)) 1350 return o; 1351 1352 if (type != OP_LEAVESUBLV) 1353 o->op_flags |= OPf_MOD; 1354 1355 if (type == OP_AASSIGN || type == OP_SASSIGN) 1356 o->op_flags |= OPf_SPECIAL|OPf_REF; 1357 else if (!type) { 1358 o->op_private |= OPpLVAL_INTRO; 1359 o->op_flags &= ~OPf_SPECIAL; 1360 PL_hints |= HINT_BLOCK_SCOPE; 1361 } 1362 else if (type != OP_GREPSTART && type != OP_ENTERSUB 1363 && type != OP_LEAVESUBLV) 1364 o->op_flags |= OPf_REF; 1365 return o; 1366 } 1367 1368 STATIC bool 1369 S_scalar_mod_type(pTHX_ const OP *o, I32 type) 1370 { 1371 switch (type) { 1372 case OP_SASSIGN: 1373 if (o->op_type == OP_RV2GV) 1374 return FALSE; 1375 /* FALL THROUGH */ 1376 case OP_PREINC: 1377 case OP_PREDEC: 1378 case OP_POSTINC: 1379 case OP_POSTDEC: 1380 case OP_I_PREINC: 1381 case OP_I_PREDEC: 1382 case OP_I_POSTINC: 1383 case OP_I_POSTDEC: 1384 case OP_POW: 1385 case OP_MULTIPLY: 1386 case OP_DIVIDE: 1387 case OP_MODULO: 1388 case OP_REPEAT: 1389 case OP_ADD: 1390 case OP_SUBTRACT: 1391 case OP_I_MULTIPLY: 1392 case OP_I_DIVIDE: 1393 case OP_I_MODULO: 1394 case OP_I_ADD: 1395 case OP_I_SUBTRACT: 1396 case OP_LEFT_SHIFT: 1397 case OP_RIGHT_SHIFT: 1398 case OP_BIT_AND: 1399 case OP_BIT_XOR: 1400 case OP_BIT_OR: 1401 case OP_CONCAT: 1402 case OP_SUBST: 1403 case OP_TRANS: 1404 case OP_READ: 1405 case OP_SYSREAD: 1406 case OP_RECV: 1407 case OP_ANDASSIGN: 1408 case OP_ORASSIGN: 1409 return TRUE; 1410 default: 1411 return FALSE; 1412 } 1413 } 1414 1415 STATIC bool 1416 S_is_handle_constructor(pTHX_ const OP *o, I32 numargs) 1417 { 1418 switch (o->op_type) { 1419 case OP_PIPE_OP: 1420 case OP_SOCKPAIR: 1421 if (numargs == 2) 1422 return TRUE; 1423 /* FALL THROUGH */ 1424 case OP_SYSOPEN: 1425 case OP_OPEN: 1426 case OP_SELECT: /* XXX c.f. SelectSaver.pm */ 1427 case OP_SOCKET: 1428 case OP_OPEN_DIR: 1429 case OP_ACCEPT: 1430 if (numargs == 1) 1431 return TRUE; 1432 /* FALL THROUGH */ 1433 default: 1434 return FALSE; 1435 } 1436 } 1437 1438 OP * 1439 Perl_refkids(pTHX_ OP *o, I32 type) 1440 { 1441 if (o && o->op_flags & OPf_KIDS) { 1442 OP *kid; 1443 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 1444 ref(kid, type); 1445 } 1446 return o; 1447 } 1448 1449 OP * 1450 Perl_ref(pTHX_ OP *o, I32 type) 1451 { 1452 OP *kid; 1453 1454 if (!o || PL_error_count) 1455 return o; 1456 1457 switch (o->op_type) { 1458 case OP_ENTERSUB: 1459 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) && 1460 !(o->op_flags & OPf_STACKED)) { 1461 o->op_type = OP_RV2CV; /* entersub => rv2cv */ 1462 o->op_ppaddr = PL_ppaddr[OP_RV2CV]; 1463 assert(cUNOPo->op_first->op_type == OP_NULL); 1464 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */ 1465 o->op_flags |= OPf_SPECIAL; 1466 } 1467 break; 1468 1469 case OP_COND_EXPR: 1470 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) 1471 ref(kid, type); 1472 break; 1473 case OP_RV2SV: 1474 if (type == OP_DEFINED) 1475 o->op_flags |= OPf_SPECIAL; /* don't create GV */ 1476 ref(cUNOPo->op_first, o->op_type); 1477 /* FALL THROUGH */ 1478 case OP_PADSV: 1479 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) { 1480 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV 1481 : type == OP_RV2HV ? OPpDEREF_HV 1482 : OPpDEREF_SV); 1483 o->op_flags |= OPf_MOD; 1484 } 1485 break; 1486 1487 case OP_THREADSV: 1488 o->op_flags |= OPf_MOD; /* XXX ??? */ 1489 break; 1490 1491 case OP_RV2AV: 1492 case OP_RV2HV: 1493 o->op_flags |= OPf_REF; 1494 /* FALL THROUGH */ 1495 case OP_RV2GV: 1496 if (type == OP_DEFINED) 1497 o->op_flags |= OPf_SPECIAL; /* don't create GV */ 1498 ref(cUNOPo->op_first, o->op_type); 1499 break; 1500 1501 case OP_PADAV: 1502 case OP_PADHV: 1503 o->op_flags |= OPf_REF; 1504 break; 1505 1506 case OP_SCALAR: 1507 case OP_NULL: 1508 if (!(o->op_flags & OPf_KIDS)) 1509 break; 1510 ref(cBINOPo->op_first, type); 1511 break; 1512 case OP_AELEM: 1513 case OP_HELEM: 1514 ref(cBINOPo->op_first, o->op_type); 1515 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) { 1516 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV 1517 : type == OP_RV2HV ? OPpDEREF_HV 1518 : OPpDEREF_SV); 1519 o->op_flags |= OPf_MOD; 1520 } 1521 break; 1522 1523 case OP_SCOPE: 1524 case OP_LEAVE: 1525 case OP_ENTER: 1526 case OP_LIST: 1527 if (!(o->op_flags & OPf_KIDS)) 1528 break; 1529 ref(cLISTOPo->op_last, type); 1530 break; 1531 default: 1532 break; 1533 } 1534 return scalar(o); 1535 1536 } 1537 1538 STATIC OP * 1539 S_dup_attrlist(pTHX_ OP *o) 1540 { 1541 OP *rop = Nullop; 1542 1543 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids, 1544 * where the first kid is OP_PUSHMARK and the remaining ones 1545 * are OP_CONST. We need to push the OP_CONST values. 1546 */ 1547 if (o->op_type == OP_CONST) 1548 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv)); 1549 else { 1550 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS)); 1551 for (o = cLISTOPo->op_first; o; o=o->op_sibling) { 1552 if (o->op_type == OP_CONST) 1553 rop = append_elem(OP_LIST, rop, 1554 newSVOP(OP_CONST, o->op_flags, 1555 SvREFCNT_inc(cSVOPo->op_sv))); 1556 } 1557 } 1558 return rop; 1559 } 1560 1561 STATIC void 1562 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my) 1563 { 1564 SV *stashsv; 1565 1566 /* fake up C<use attributes $pkg,$rv,@attrs> */ 1567 ENTER; /* need to protect against side-effects of 'use' */ 1568 SAVEINT(PL_expect); 1569 if (stash) 1570 stashsv = newSVpv(HvNAME_get(stash), 0); 1571 else 1572 stashsv = &PL_sv_no; 1573 1574 #define ATTRSMODULE "attributes" 1575 #define ATTRSMODULE_PM "attributes.pm" 1576 1577 if (for_my) { 1578 /* Don't force the C<use> if we don't need it. */ 1579 SV * const * const svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM, 1580 sizeof(ATTRSMODULE_PM)-1, 0); 1581 if (svp && *svp != &PL_sv_undef) 1582 ; /* already in %INC */ 1583 else 1584 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, 1585 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1), 1586 Nullsv); 1587 } 1588 else { 1589 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS, 1590 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1), 1591 Nullsv, 1592 prepend_elem(OP_LIST, 1593 newSVOP(OP_CONST, 0, stashsv), 1594 prepend_elem(OP_LIST, 1595 newSVOP(OP_CONST, 0, 1596 newRV(target)), 1597 dup_attrlist(attrs)))); 1598 } 1599 LEAVE; 1600 } 1601 1602 STATIC void 1603 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) 1604 { 1605 OP *pack, *imop, *arg; 1606 SV *meth, *stashsv; 1607 1608 if (!attrs) 1609 return; 1610 1611 assert(target->op_type == OP_PADSV || 1612 target->op_type == OP_PADHV || 1613 target->op_type == OP_PADAV); 1614 1615 /* Ensure that attributes.pm is loaded. */ 1616 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE); 1617 1618 /* Need package name for method call. */ 1619 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1)); 1620 1621 /* Build up the real arg-list. */ 1622 if (stash) 1623 stashsv = newSVpv(HvNAME_get(stash), 0); 1624 else 1625 stashsv = &PL_sv_no; 1626 arg = newOP(OP_PADSV, 0); 1627 arg->op_targ = target->op_targ; 1628 arg = prepend_elem(OP_LIST, 1629 newSVOP(OP_CONST, 0, stashsv), 1630 prepend_elem(OP_LIST, 1631 newUNOP(OP_REFGEN, 0, 1632 mod(arg, OP_REFGEN)), 1633 dup_attrlist(attrs))); 1634 1635 /* Fake up a method call to import */ 1636 meth = newSVpvn("import", 6); 1637 (void)SvUPGRADE(meth, SVt_PVIV); 1638 (void)SvIOK_on(meth); 1639 { 1640 U32 hash; 1641 PERL_HASH(hash, SvPVX_const(meth), SvCUR(meth)); 1642 SvUV_set(meth, hash); 1643 } 1644 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID, 1645 append_elem(OP_LIST, 1646 prepend_elem(OP_LIST, pack, list(arg)), 1647 newSVOP(OP_METHOD_NAMED, 0, meth))); 1648 imop->op_private |= OPpENTERSUB_NOMOD; 1649 1650 /* Combine the ops. */ 1651 *imopsp = append_elem(OP_LIST, *imopsp, imop); 1652 } 1653 1654 /* 1655 =notfor apidoc apply_attrs_string 1656 1657 Attempts to apply a list of attributes specified by the C<attrstr> and 1658 C<len> arguments to the subroutine identified by the C<cv> argument which 1659 is expected to be associated with the package identified by the C<stashpv> 1660 argument (see L<attributes>). It gets this wrong, though, in that it 1661 does not correctly identify the boundaries of the individual attribute 1662 specifications within C<attrstr>. This is not really intended for the 1663 public API, but has to be listed here for systems such as AIX which 1664 need an explicit export list for symbols. (It's called from XS code 1665 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it 1666 to respect attribute syntax properly would be welcome. 1667 1668 =cut 1669 */ 1670 1671 void 1672 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv, 1673 char *attrstr, STRLEN len) 1674 { 1675 OP *attrs = Nullop; 1676 1677 if (!len) { 1678 len = strlen(attrstr); 1679 } 1680 1681 while (len) { 1682 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ; 1683 if (len) { 1684 const char * const sstr = attrstr; 1685 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ; 1686 attrs = append_elem(OP_LIST, attrs, 1687 newSVOP(OP_CONST, 0, 1688 newSVpvn(sstr, attrstr-sstr))); 1689 } 1690 } 1691 1692 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS, 1693 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1), 1694 Nullsv, prepend_elem(OP_LIST, 1695 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)), 1696 prepend_elem(OP_LIST, 1697 newSVOP(OP_CONST, 0, 1698 newRV((SV*)cv)), 1699 attrs))); 1700 } 1701 1702 STATIC OP * 1703 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) 1704 { 1705 I32 type; 1706 1707 if (!o || PL_error_count) 1708 return o; 1709 1710 type = o->op_type; 1711 if (type == OP_LIST) { 1712 OP *kid; 1713 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 1714 my_kid(kid, attrs, imopsp); 1715 } else if (type == OP_UNDEF) { 1716 return o; 1717 } else if (type == OP_RV2SV || /* "our" declaration */ 1718 type == OP_RV2AV || 1719 type == OP_RV2HV) { /* XXX does this let anything illegal in? */ 1720 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */ 1721 yyerror(Perl_form(aTHX_ "Can't declare %s in %s", 1722 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my")); 1723 } else if (attrs) { 1724 GV * const gv = cGVOPx_gv(cUNOPo->op_first); 1725 PL_in_my = FALSE; 1726 PL_in_my_stash = Nullhv; 1727 apply_attrs(GvSTASH(gv), 1728 (type == OP_RV2SV ? GvSV(gv) : 1729 type == OP_RV2AV ? (SV*)GvAV(gv) : 1730 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv), 1731 attrs, FALSE); 1732 } 1733 o->op_private |= OPpOUR_INTRO; 1734 return o; 1735 } 1736 else if (type != OP_PADSV && 1737 type != OP_PADAV && 1738 type != OP_PADHV && 1739 type != OP_PUSHMARK) 1740 { 1741 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"", 1742 OP_DESC(o), 1743 PL_in_my == KEY_our ? "our" : "my")); 1744 return o; 1745 } 1746 else if (attrs && type != OP_PUSHMARK) { 1747 HV *stash; 1748 1749 PL_in_my = FALSE; 1750 PL_in_my_stash = Nullhv; 1751 1752 /* check for C<my Dog $spot> when deciding package */ 1753 stash = PAD_COMPNAME_TYPE(o->op_targ); 1754 if (!stash) 1755 stash = PL_curstash; 1756 apply_attrs_my(stash, o, attrs, imopsp); 1757 } 1758 o->op_flags |= OPf_MOD; 1759 o->op_private |= OPpLVAL_INTRO; 1760 return o; 1761 } 1762 1763 OP * 1764 Perl_my_attrs(pTHX_ OP *o, OP *attrs) 1765 { 1766 OP *rops = Nullop; 1767 int maybe_scalar = 0; 1768 1769 /* [perl #17376]: this appears to be premature, and results in code such as 1770 C< our(%x); > executing in list mode rather than void mode */ 1771 #if 0 1772 if (o->op_flags & OPf_PARENS) 1773 list(o); 1774 else 1775 maybe_scalar = 1; 1776 #else 1777 maybe_scalar = 1; 1778 #endif 1779 if (attrs) 1780 SAVEFREEOP(attrs); 1781 o = my_kid(o, attrs, &rops); 1782 if (rops) { 1783 if (maybe_scalar && o->op_type == OP_PADSV) { 1784 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o)); 1785 o->op_private |= OPpLVAL_INTRO; 1786 } 1787 else 1788 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops); 1789 } 1790 PL_in_my = FALSE; 1791 PL_in_my_stash = Nullhv; 1792 return o; 1793 } 1794 1795 OP * 1796 Perl_my(pTHX_ OP *o) 1797 { 1798 return my_attrs(o, Nullop); 1799 } 1800 1801 OP * 1802 Perl_sawparens(pTHX_ OP *o) 1803 { 1804 if (o) 1805 o->op_flags |= OPf_PARENS; 1806 return o; 1807 } 1808 1809 OP * 1810 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) 1811 { 1812 OP *o; 1813 1814 if ( (left->op_type == OP_RV2AV || 1815 left->op_type == OP_RV2HV || 1816 left->op_type == OP_PADAV || 1817 left->op_type == OP_PADHV) 1818 && ckWARN(WARN_MISC)) 1819 { 1820 const char * const desc = PL_op_desc[(right->op_type == OP_SUBST || 1821 right->op_type == OP_TRANS) 1822 ? right->op_type : OP_MATCH]; 1823 const char * const sample = ((left->op_type == OP_RV2AV || 1824 left->op_type == OP_PADAV) 1825 ? "@array" : "%hash"); 1826 Perl_warner(aTHX_ packWARN(WARN_MISC), 1827 "Applying %s to %s will act on scalar(%s)", 1828 desc, sample, sample); 1829 } 1830 1831 if (right->op_type == OP_CONST && 1832 cSVOPx(right)->op_private & OPpCONST_BARE && 1833 cSVOPx(right)->op_private & OPpCONST_STRICT) 1834 { 1835 no_bareword_allowed(right); 1836 } 1837 1838 if (!(right->op_flags & OPf_STACKED) && 1839 (right->op_type == OP_MATCH || 1840 right->op_type == OP_SUBST || 1841 right->op_type == OP_TRANS)) { 1842 right->op_flags |= OPf_STACKED; 1843 if (right->op_type != OP_MATCH && 1844 ! (right->op_type == OP_TRANS && 1845 right->op_private & OPpTRANS_IDENTICAL)) 1846 left = mod(left, right->op_type); 1847 if (right->op_type == OP_TRANS) 1848 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right); 1849 else 1850 o = prepend_elem(right->op_type, scalar(left), right); 1851 if (type == OP_NOT) 1852 return newUNOP(OP_NOT, 0, scalar(o)); 1853 return o; 1854 } 1855 else 1856 return bind_match(type, left, 1857 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop)); 1858 } 1859 1860 OP * 1861 Perl_invert(pTHX_ OP *o) 1862 { 1863 if (!o) 1864 return o; 1865 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */ 1866 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o)); 1867 } 1868 1869 OP * 1870 Perl_scope(pTHX_ OP *o) 1871 { 1872 if (o) { 1873 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) { 1874 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o); 1875 o->op_type = OP_LEAVE; 1876 o->op_ppaddr = PL_ppaddr[OP_LEAVE]; 1877 } 1878 else if (o->op_type == OP_LINESEQ) { 1879 OP *kid; 1880 o->op_type = OP_SCOPE; 1881 o->op_ppaddr = PL_ppaddr[OP_SCOPE]; 1882 kid = ((LISTOP*)o)->op_first; 1883 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) { 1884 op_null(kid); 1885 1886 /* The following deals with things like 'do {1 for 1}' */ 1887 kid = kid->op_sibling; 1888 if (kid && 1889 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)) 1890 op_null(kid); 1891 } 1892 } 1893 else 1894 o = newLISTOP(OP_SCOPE, 0, o, Nullop); 1895 } 1896 return o; 1897 } 1898 1899 /* XXX kept for BINCOMPAT only */ 1900 void 1901 Perl_save_hints(pTHX) 1902 { 1903 Perl_croak(aTHX_ "internal error: obsolete function save_hints() called"); 1904 } 1905 1906 int 1907 Perl_block_start(pTHX_ int full) 1908 { 1909 const int retval = PL_savestack_ix; 1910 /* If there were syntax errors, don't try to start a block */ 1911 if (PL_yynerrs) return retval; 1912 1913 pad_block_start(full); 1914 SAVEHINTS(); 1915 PL_hints &= ~HINT_BLOCK_SCOPE; 1916 SAVESPTR(PL_compiling.cop_warnings); 1917 if (! specialWARN(PL_compiling.cop_warnings)) { 1918 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ; 1919 SAVEFREESV(PL_compiling.cop_warnings) ; 1920 } 1921 SAVESPTR(PL_compiling.cop_io); 1922 if (! specialCopIO(PL_compiling.cop_io)) { 1923 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ; 1924 SAVEFREESV(PL_compiling.cop_io) ; 1925 } 1926 return retval; 1927 } 1928 1929 OP* 1930 Perl_block_end(pTHX_ I32 floor, OP *seq) 1931 { 1932 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE; 1933 OP* const retval = scalarseq(seq); 1934 /* If there were syntax errors, don't try to close a block */ 1935 if (PL_yynerrs) return retval; 1936 LEAVE_SCOPE(floor); 1937 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); 1938 if (needblockscope) 1939 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */ 1940 pad_leavemy(); 1941 return retval; 1942 } 1943 1944 STATIC OP * 1945 S_newDEFSVOP(pTHX) 1946 { 1947 #ifdef USE_5005THREADS 1948 OP *const o = newOP(OP_THREADSV, 0); 1949 o->op_targ = find_threadsv("_"); 1950 return o; 1951 #else 1952 return newSVREF(newGVOP(OP_GV, 0, PL_defgv)); 1953 #endif /* USE_5005THREADS */ 1954 } 1955 1956 void 1957 Perl_newPROG(pTHX_ OP *o) 1958 { 1959 if (PL_in_eval) { 1960 if (PL_eval_root) 1961 return; 1962 PL_eval_root = newUNOP(OP_LEAVEEVAL, 1963 ((PL_in_eval & EVAL_KEEPERR) 1964 ? OPf_SPECIAL : 0), o); 1965 PL_eval_start = linklist(PL_eval_root); 1966 PL_eval_root->op_private |= OPpREFCOUNTED; 1967 OpREFCNT_set(PL_eval_root, 1); 1968 PL_eval_root->op_next = 0; 1969 CALL_PEEP(PL_eval_start); 1970 } 1971 else { 1972 if (o->op_type == OP_STUB) { 1973 PL_comppad_name = 0; 1974 PL_compcv = 0; 1975 FreeOp(o); 1976 return; 1977 } 1978 PL_main_root = scope(sawparens(scalarvoid(o))); 1979 PL_curcop = &PL_compiling; 1980 PL_main_start = LINKLIST(PL_main_root); 1981 PL_main_root->op_private |= OPpREFCOUNTED; 1982 OpREFCNT_set(PL_main_root, 1); 1983 PL_main_root->op_next = 0; 1984 CALL_PEEP(PL_main_start); 1985 PL_compcv = 0; 1986 1987 /* Register with debugger */ 1988 if (PERLDB_INTER) { 1989 CV * const cv = get_cv("DB::postponed", FALSE); 1990 if (cv) { 1991 dSP; 1992 PUSHMARK(SP); 1993 XPUSHs((SV*)CopFILEGV(&PL_compiling)); 1994 PUTBACK; 1995 call_sv((SV*)cv, G_DISCARD); 1996 } 1997 } 1998 } 1999 } 2000 2001 OP * 2002 Perl_localize(pTHX_ OP *o, I32 lex) 2003 { 2004 if (o->op_flags & OPf_PARENS) 2005 /* [perl #17376]: this appears to be premature, and results in code such as 2006 C< our(%x); > executing in list mode rather than void mode */ 2007 #if 0 2008 list(o); 2009 #else 2010 ; 2011 #endif 2012 else { 2013 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',' 2014 && ckWARN(WARN_PARENTHESIS)) 2015 { 2016 char *s = PL_bufptr; 2017 bool sigil = FALSE; 2018 2019 /* some heuristics to detect a potential error */ 2020 while (*s && (strchr(", \t\n", *s))) 2021 s++; 2022 2023 while (1) { 2024 if (*s && strchr("@$%*", *s) && *++s 2025 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) { 2026 s++; 2027 sigil = TRUE; 2028 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) 2029 s++; 2030 while (*s && (strchr(", \t\n", *s))) 2031 s++; 2032 } 2033 else 2034 break; 2035 } 2036 if (sigil && (*s == ';' || *s == '=')) { 2037 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS), 2038 "Parentheses missing around \"%s\" list", 2039 lex ? (PL_in_my == KEY_our ? "our" : "my") 2040 : "local"); 2041 } 2042 } 2043 } 2044 if (lex) 2045 o = my(o); 2046 else 2047 o = mod(o, OP_NULL); /* a bit kludgey */ 2048 PL_in_my = FALSE; 2049 PL_in_my_stash = Nullhv; 2050 return o; 2051 } 2052 2053 OP * 2054 Perl_jmaybe(pTHX_ OP *o) 2055 { 2056 if (o->op_type == OP_LIST) { 2057 OP *o2; 2058 #ifdef USE_5005THREADS 2059 o2 = newOP(OP_THREADSV, 0); 2060 o2->op_targ = find_threadsv(";"); 2061 #else 2062 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))), 2063 #endif /* USE_5005THREADS */ 2064 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o)); 2065 } 2066 return o; 2067 } 2068 2069 OP * 2070 Perl_fold_constants(pTHX_ register OP *o) 2071 { 2072 register OP *curop; 2073 I32 type = o->op_type; 2074 SV *sv; 2075 2076 if (PL_opargs[type] & OA_RETSCALAR) 2077 scalar(o); 2078 if (PL_opargs[type] & OA_TARGET && !o->op_targ) 2079 o->op_targ = pad_alloc(type, SVs_PADTMP); 2080 2081 /* integerize op, unless it happens to be C<-foo>. 2082 * XXX should pp_i_negate() do magic string negation instead? */ 2083 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER) 2084 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST 2085 && (cUNOPo->op_first->op_private & OPpCONST_BARE))) 2086 { 2087 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)]; 2088 } 2089 2090 if (!(PL_opargs[type] & OA_FOLDCONST)) 2091 goto nope; 2092 2093 switch (type) { 2094 case OP_NEGATE: 2095 /* XXX might want a ck_negate() for this */ 2096 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT; 2097 break; 2098 case OP_UCFIRST: 2099 case OP_LCFIRST: 2100 case OP_UC: 2101 case OP_LC: 2102 case OP_SLT: 2103 case OP_SGT: 2104 case OP_SLE: 2105 case OP_SGE: 2106 case OP_SCMP: 2107 /* XXX what about the numeric ops? */ 2108 if (PL_hints & HINT_LOCALE) 2109 goto nope; 2110 } 2111 2112 if (PL_error_count) 2113 goto nope; /* Don't try to run w/ errors */ 2114 2115 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) { 2116 if ((curop->op_type != OP_CONST || 2117 (curop->op_private & OPpCONST_BARE)) && 2118 curop->op_type != OP_LIST && 2119 curop->op_type != OP_SCALAR && 2120 curop->op_type != OP_NULL && 2121 curop->op_type != OP_PUSHMARK) 2122 { 2123 goto nope; 2124 } 2125 } 2126 2127 curop = LINKLIST(o); 2128 o->op_next = 0; 2129 PL_op = curop; 2130 CALLRUNOPS(aTHX); 2131 sv = *(PL_stack_sp--); 2132 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */ 2133 pad_swipe(o->op_targ, FALSE); 2134 else if (SvTEMP(sv)) { /* grab mortal temp? */ 2135 (void)SvREFCNT_inc(sv); 2136 SvTEMP_off(sv); 2137 } 2138 op_free(o); 2139 if (type == OP_RV2GV) 2140 return newGVOP(OP_GV, 0, (GV*)sv); 2141 return newSVOP(OP_CONST, 0, sv); 2142 2143 nope: 2144 return o; 2145 } 2146 2147 OP * 2148 Perl_gen_constant_list(pTHX_ register OP *o) 2149 { 2150 register OP *curop; 2151 const I32 oldtmps_floor = PL_tmps_floor; 2152 2153 list(o); 2154 if (PL_error_count) 2155 return o; /* Don't attempt to run with errors */ 2156 2157 PL_op = curop = LINKLIST(o); 2158 o->op_next = 0; 2159 CALL_PEEP(curop); 2160 pp_pushmark(); 2161 CALLRUNOPS(aTHX); 2162 PL_op = curop; 2163 pp_anonlist(); 2164 PL_tmps_floor = oldtmps_floor; 2165 2166 o->op_type = OP_RV2AV; 2167 o->op_ppaddr = PL_ppaddr[OP_RV2AV]; 2168 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */ 2169 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */ 2170 o->op_seq = 0; /* needs to be revisited in peep() */ 2171 curop = ((UNOP*)o)->op_first; 2172 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--)); 2173 op_free(curop); 2174 linklist(o); 2175 return list(o); 2176 } 2177 2178 OP * 2179 Perl_convert(pTHX_ I32 type, I32 flags, OP *o) 2180 { 2181 if (!o || o->op_type != OP_LIST) 2182 o = newLISTOP(OP_LIST, 0, o, Nullop); 2183 else 2184 o->op_flags &= ~OPf_WANT; 2185 2186 if (!(PL_opargs[type] & OA_MARK)) 2187 op_null(cLISTOPo->op_first); 2188 2189 o->op_type = (OPCODE)type; 2190 o->op_ppaddr = PL_ppaddr[type]; 2191 o->op_flags |= flags; 2192 2193 o = CHECKOP(type, o); 2194 if (o->op_type != (unsigned)type) 2195 return o; 2196 2197 return fold_constants(o); 2198 } 2199 2200 /* List constructors */ 2201 2202 OP * 2203 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last) 2204 { 2205 if (!first) 2206 return last; 2207 2208 if (!last) 2209 return first; 2210 2211 if (first->op_type != (unsigned)type 2212 || (type == OP_LIST && (first->op_flags & OPf_PARENS))) 2213 { 2214 return newLISTOP(type, 0, first, last); 2215 } 2216 2217 if (first->op_flags & OPf_KIDS) 2218 ((LISTOP*)first)->op_last->op_sibling = last; 2219 else { 2220 first->op_flags |= OPf_KIDS; 2221 ((LISTOP*)first)->op_first = last; 2222 } 2223 ((LISTOP*)first)->op_last = last; 2224 return first; 2225 } 2226 2227 OP * 2228 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last) 2229 { 2230 if (!first) 2231 return (OP*)last; 2232 2233 if (!last) 2234 return (OP*)first; 2235 2236 if (first->op_type != (unsigned)type) 2237 return prepend_elem(type, (OP*)first, (OP*)last); 2238 2239 if (last->op_type != (unsigned)type) 2240 return append_elem(type, (OP*)first, (OP*)last); 2241 2242 first->op_last->op_sibling = last->op_first; 2243 first->op_last = last->op_last; 2244 first->op_flags |= (last->op_flags & OPf_KIDS); 2245 2246 FreeOp(last); 2247 2248 return (OP*)first; 2249 } 2250 2251 OP * 2252 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last) 2253 { 2254 if (!first) 2255 return last; 2256 2257 if (!last) 2258 return first; 2259 2260 if (last->op_type == (unsigned)type) { 2261 if (type == OP_LIST) { /* already a PUSHMARK there */ 2262 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling; 2263 ((LISTOP*)last)->op_first->op_sibling = first; 2264 if (!(first->op_flags & OPf_PARENS)) 2265 last->op_flags &= ~OPf_PARENS; 2266 } 2267 else { 2268 if (!(last->op_flags & OPf_KIDS)) { 2269 ((LISTOP*)last)->op_last = first; 2270 last->op_flags |= OPf_KIDS; 2271 } 2272 first->op_sibling = ((LISTOP*)last)->op_first; 2273 ((LISTOP*)last)->op_first = first; 2274 } 2275 last->op_flags |= OPf_KIDS; 2276 return last; 2277 } 2278 2279 return newLISTOP(type, 0, first, last); 2280 } 2281 2282 /* Constructors */ 2283 2284 OP * 2285 Perl_newNULLLIST(pTHX) 2286 { 2287 return newOP(OP_STUB, 0); 2288 } 2289 2290 OP * 2291 Perl_force_list(pTHX_ OP *o) 2292 { 2293 if (!o || o->op_type != OP_LIST) 2294 o = newLISTOP(OP_LIST, 0, o, Nullop); 2295 op_null(o); 2296 return o; 2297 } 2298 2299 OP * 2300 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) 2301 { 2302 LISTOP *listop; 2303 2304 NewOp(1101, listop, 1, LISTOP); 2305 2306 listop->op_type = (OPCODE)type; 2307 listop->op_ppaddr = PL_ppaddr[type]; 2308 if (first || last) 2309 flags |= OPf_KIDS; 2310 listop->op_flags = (U8)flags; 2311 2312 if (!last && first) 2313 last = first; 2314 else if (!first && last) 2315 first = last; 2316 else if (first) 2317 first->op_sibling = last; 2318 listop->op_first = first; 2319 listop->op_last = last; 2320 if (type == OP_LIST) { 2321 OP* const pushop = newOP(OP_PUSHMARK, 0); 2322 pushop->op_sibling = first; 2323 listop->op_first = pushop; 2324 listop->op_flags |= OPf_KIDS; 2325 if (!last) 2326 listop->op_last = pushop; 2327 } 2328 2329 return CHECKOP(type, listop); 2330 } 2331 2332 OP * 2333 Perl_newOP(pTHX_ I32 type, I32 flags) 2334 { 2335 OP *o; 2336 NewOp(1101, o, 1, OP); 2337 o->op_type = (OPCODE)type; 2338 o->op_ppaddr = PL_ppaddr[type]; 2339 o->op_flags = (U8)flags; 2340 2341 o->op_next = o; 2342 o->op_private = (U8)(0 | (flags >> 8)); 2343 if (PL_opargs[type] & OA_RETSCALAR) 2344 scalar(o); 2345 if (PL_opargs[type] & OA_TARGET) 2346 o->op_targ = pad_alloc(type, SVs_PADTMP); 2347 return CHECKOP(type, o); 2348 } 2349 2350 OP * 2351 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) 2352 { 2353 UNOP *unop; 2354 2355 if (!first) 2356 first = newOP(OP_STUB, 0); 2357 if (PL_opargs[type] & OA_MARK) 2358 first = force_list(first); 2359 2360 NewOp(1101, unop, 1, UNOP); 2361 unop->op_type = (OPCODE)type; 2362 unop->op_ppaddr = PL_ppaddr[type]; 2363 unop->op_first = first; 2364 unop->op_flags = (U8)(flags | OPf_KIDS); 2365 unop->op_private = (U8)(1 | (flags >> 8)); 2366 unop = (UNOP*) CHECKOP(type, unop); 2367 if (unop->op_next) 2368 return (OP*)unop; 2369 2370 return fold_constants((OP *) unop); 2371 } 2372 2373 OP * 2374 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) 2375 { 2376 BINOP *binop; 2377 NewOp(1101, binop, 1, BINOP); 2378 2379 if (!first) 2380 first = newOP(OP_NULL, 0); 2381 2382 binop->op_type = (OPCODE)type; 2383 binop->op_ppaddr = PL_ppaddr[type]; 2384 binop->op_first = first; 2385 binop->op_flags = (U8)(flags | OPf_KIDS); 2386 if (!last) { 2387 last = first; 2388 binop->op_private = (U8)(1 | (flags >> 8)); 2389 } 2390 else { 2391 binop->op_private = (U8)(2 | (flags >> 8)); 2392 first->op_sibling = last; 2393 } 2394 2395 binop = (BINOP*)CHECKOP(type, binop); 2396 if (binop->op_next || binop->op_type != (OPCODE)type) 2397 return (OP*)binop; 2398 2399 binop->op_last = binop->op_first->op_sibling; 2400 2401 return fold_constants((OP *)binop); 2402 } 2403 2404 static int uvcompare(const void *a, const void *b) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__pure__; 2405 static int uvcompare(const void *a, const void *b) 2406 { 2407 if (*((const UV *)a) < (*(const UV *)b)) 2408 return -1; 2409 if (*((const UV *)a) > (*(const UV *)b)) 2410 return 1; 2411 if (*((const UV *)a+1) < (*(const UV *)b+1)) 2412 return -1; 2413 if (*((const UV *)a+1) > (*(const UV *)b+1)) 2414 return 1; 2415 return 0; 2416 } 2417 2418 OP * 2419 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) 2420 { 2421 SV * const tstr = ((SVOP*)expr)->op_sv; 2422 SV * const rstr = ((SVOP*)repl)->op_sv; 2423 STRLEN tlen; 2424 STRLEN rlen; 2425 const U8 *t = (U8*)SvPV_const(tstr, tlen); 2426 const U8 *r = (U8*)SvPV_const(rstr, rlen); 2427 register I32 i; 2428 register I32 j; 2429 I32 grows = 0; 2430 register short *tbl; 2431 2432 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT; 2433 const I32 squash = o->op_private & OPpTRANS_SQUASH; 2434 I32 del = o->op_private & OPpTRANS_DELETE; 2435 PL_hints |= HINT_BLOCK_SCOPE; 2436 2437 if (SvUTF8(tstr)) 2438 o->op_private |= OPpTRANS_FROM_UTF; 2439 2440 if (SvUTF8(rstr)) 2441 o->op_private |= OPpTRANS_TO_UTF; 2442 2443 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) { 2444 SV* const listsv = newSVpvn("# comment\n",10); 2445 SV* transv = 0; 2446 const U8* tend = t + tlen; 2447 const U8* rend = r + rlen; 2448 STRLEN ulen; 2449 UV tfirst = 1; 2450 UV tlast = 0; 2451 IV tdiff; 2452 UV rfirst = 1; 2453 UV rlast = 0; 2454 IV rdiff; 2455 IV diff; 2456 I32 none = 0; 2457 U32 max = 0; 2458 I32 bits; 2459 I32 havefinal = 0; 2460 U32 final = 0; 2461 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF; 2462 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF; 2463 U8* tsave = NULL; 2464 U8* rsave = NULL; 2465 2466 if (!from_utf) { 2467 STRLEN len = tlen; 2468 t = tsave = bytes_to_utf8((U8 *)t, &len); 2469 tend = t + len; 2470 } 2471 if (!to_utf && rlen) { 2472 STRLEN len = rlen; 2473 r = rsave = bytes_to_utf8((U8 *)r, &len); 2474 rend = r + len; 2475 } 2476 2477 /* There are several snags with this code on EBCDIC: 2478 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes). 2479 2. scan_const() in toke.c has encoded chars in native encoding which makes 2480 ranges at least in EBCDIC 0..255 range the bottom odd. 2481 */ 2482 2483 if (complement) { 2484 U8 tmpbuf[UTF8_MAXBYTES+1]; 2485 UV *cp; 2486 UV nextmin = 0; 2487 Newx(cp, 2*tlen, UV); 2488 i = 0; 2489 transv = newSVpvn("",0); 2490 while (t < tend) { 2491 cp[2*i] = utf8n_to_uvuni((U8 *)t, tend-t, &ulen, 0); 2492 t += ulen; 2493 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { 2494 t++; 2495 cp[2*i+1] = utf8n_to_uvuni((U8 *)t, tend-t, &ulen, 0); 2496 t += ulen; 2497 } 2498 else { 2499 cp[2*i+1] = cp[2*i]; 2500 } 2501 i++; 2502 } 2503 qsort(cp, i, 2*sizeof(UV), uvcompare); 2504 for (j = 0; j < i; j++) { 2505 UV val = cp[2*j]; 2506 diff = val - nextmin; 2507 if (diff > 0) { 2508 t = uvuni_to_utf8(tmpbuf,nextmin); 2509 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); 2510 if (diff > 1) { 2511 U8 range_mark = UTF_TO_NATIVE(0xff); 2512 t = uvuni_to_utf8(tmpbuf, val - 1); 2513 sv_catpvn(transv, (char *)&range_mark, 1); 2514 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); 2515 } 2516 } 2517 val = cp[2*j+1]; 2518 if (val >= nextmin) 2519 nextmin = val + 1; 2520 } 2521 t = uvuni_to_utf8(tmpbuf,nextmin); 2522 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); 2523 { 2524 U8 range_mark = UTF_TO_NATIVE(0xff); 2525 sv_catpvn(transv, (char *)&range_mark, 1); 2526 } 2527 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff, 2528 UNICODE_ALLOW_SUPER); 2529 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); 2530 t = (const U8*)SvPVX_const(transv); 2531 tlen = SvCUR(transv); 2532 tend = t + tlen; 2533 Safefree(cp); 2534 } 2535 else if (!rlen && !del) { 2536 r = t; rlen = tlen; rend = tend; 2537 } 2538 if (!squash) { 2539 if ((!rlen && !del) || t == r || 2540 (tlen == rlen && memEQ((char *)t, (char *)r, tlen))) 2541 { 2542 o->op_private |= OPpTRANS_IDENTICAL; 2543 } 2544 } 2545 2546 while (t < tend || tfirst <= tlast) { 2547 /* see if we need more "t" chars */ 2548 if (tfirst > tlast) { 2549 tfirst = (I32)utf8n_to_uvuni((U8 *)t, tend - t, &ulen, 0); 2550 t += ulen; 2551 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */ 2552 t++; 2553 tlast = (I32)utf8n_to_uvuni((U8 *)t, tend - t, &ulen, 0); 2554 t += ulen; 2555 } 2556 else 2557 tlast = tfirst; 2558 } 2559 2560 /* now see if we need more "r" chars */ 2561 if (rfirst > rlast) { 2562 if (r < rend) { 2563 rfirst = (I32)utf8n_to_uvuni((U8 *)r, rend - r, &ulen, 0); 2564 r += ulen; 2565 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */ 2566 r++; 2567 rlast = (I32)utf8n_to_uvuni((U8 *)r, rend - r, &ulen, 2568 0); 2569 r += ulen; 2570 } 2571 else 2572 rlast = rfirst; 2573 } 2574 else { 2575 if (!havefinal++) 2576 final = rlast; 2577 rfirst = rlast = 0xffffffff; 2578 } 2579 } 2580 2581 /* now see which range will peter our first, if either. */ 2582 tdiff = tlast - tfirst; 2583 rdiff = rlast - rfirst; 2584 2585 if (tdiff <= rdiff) 2586 diff = tdiff; 2587 else 2588 diff = rdiff; 2589 2590 if (rfirst == 0xffffffff) { 2591 diff = tdiff; /* oops, pretend rdiff is infinite */ 2592 if (diff > 0) 2593 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n", 2594 (long)tfirst, (long)tlast); 2595 else 2596 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst); 2597 } 2598 else { 2599 if (diff > 0) 2600 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n", 2601 (long)tfirst, (long)(tfirst + diff), 2602 (long)rfirst); 2603 else 2604 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n", 2605 (long)tfirst, (long)rfirst); 2606 2607 if (rfirst + diff > max) 2608 max = rfirst + diff; 2609 if (!grows) 2610 grows = (tfirst < rfirst && 2611 UNISKIP(tfirst) < UNISKIP(rfirst + diff)); 2612 rfirst += diff + 1; 2613 } 2614 tfirst += diff + 1; 2615 } 2616 2617 none = ++max; 2618 if (del) 2619 del = ++max; 2620 2621 if (max > 0xffff) 2622 bits = 32; 2623 else if (max > 0xff) 2624 bits = 16; 2625 else 2626 bits = 8; 2627 2628 Safefree(cPVOPo->op_pv); 2629 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none); 2630 SvREFCNT_dec(listsv); 2631 if (transv) 2632 SvREFCNT_dec(transv); 2633 2634 if (!del && havefinal && rlen) 2635 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5, 2636 newSVuv((UV)final), 0); 2637 2638 if (grows) 2639 o->op_private |= OPpTRANS_GROWS; 2640 2641 if (tsave) 2642 Safefree(tsave); 2643 if (rsave) 2644 Safefree(rsave); 2645 2646 op_free(expr); 2647 op_free(repl); 2648 return o; 2649 } 2650 2651 tbl = (short*)cPVOPo->op_pv; 2652 if (complement) { 2653 Zero(tbl, 256, short); 2654 for (i = 0; i < (I32)tlen; i++) 2655 tbl[t[i]] = -1; 2656 for (i = 0, j = 0; i < 256; i++) { 2657 if (!tbl[i]) { 2658 if (j >= (I32)rlen) { 2659 if (del) 2660 tbl[i] = -2; 2661 else if (rlen) 2662 tbl[i] = r[j-1]; 2663 else 2664 tbl[i] = (short)i; 2665 } 2666 else { 2667 if (i < 128 && r[j] >= 128) 2668 grows = 1; 2669 tbl[i] = r[j++]; 2670 } 2671 } 2672 } 2673 if (!del) { 2674 if (!rlen) { 2675 j = rlen; 2676 if (!squash) 2677 o->op_private |= OPpTRANS_IDENTICAL; 2678 } 2679 else if (j >= (I32)rlen) 2680 j = rlen - 1; 2681 else 2682 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short); 2683 tbl[0x100] = (short)(rlen - j); 2684 for (i=0; i < (I32)rlen - j; i++) 2685 tbl[0x101+i] = r[j+i]; 2686 } 2687 } 2688 else { 2689 if (!rlen && !del) { 2690 r = t; rlen = tlen; 2691 if (!squash) 2692 o->op_private |= OPpTRANS_IDENTICAL; 2693 } 2694 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) { 2695 o->op_private |= OPpTRANS_IDENTICAL; 2696 } 2697 for (i = 0; i < 256; i++) 2698 tbl[i] = -1; 2699 for (i = 0, j = 0; i < (I32)tlen; i++,j++) { 2700 if (j >= (I32)rlen) { 2701 if (del) { 2702 if (tbl[t[i]] == -1) 2703 tbl[t[i]] = -2; 2704 continue; 2705 } 2706 --j; 2707 } 2708 if (tbl[t[i]] == -1) { 2709 if (t[i] < 128 && r[j] >= 128) 2710 grows = 1; 2711 tbl[t[i]] = r[j]; 2712 } 2713 } 2714 } 2715 if (grows) 2716 o->op_private |= OPpTRANS_GROWS; 2717 op_free(expr); 2718 op_free(repl); 2719 2720 return o; 2721 } 2722 2723 OP * 2724 Perl_newPMOP(pTHX_ I32 type, I32 flags) 2725 { 2726 PMOP *pmop; 2727 2728 NewOp(1101, pmop, 1, PMOP); 2729 pmop->op_type = (OPCODE)type; 2730 pmop->op_ppaddr = PL_ppaddr[type]; 2731 pmop->op_flags = (U8)flags; 2732 pmop->op_private = (U8)(0 | (flags >> 8)); 2733 2734 if (PL_hints & HINT_RE_TAINT) 2735 pmop->op_pmpermflags |= PMf_RETAINT; 2736 if (PL_hints & HINT_LOCALE) 2737 pmop->op_pmpermflags |= PMf_LOCALE; 2738 pmop->op_pmflags = pmop->op_pmpermflags; 2739 2740 #ifdef USE_ITHREADS 2741 if (av_len((AV*) PL_regex_pad[0]) > -1) { 2742 SV * const repointer = av_pop((AV*)PL_regex_pad[0]); 2743 pmop->op_pmoffset = SvIV(repointer); 2744 SvREPADTMP_off(repointer); 2745 sv_setiv(repointer,0); 2746 } else { 2747 SV * const repointer = newSViv(0); 2748 av_push(PL_regex_padav,SvREFCNT_inc(repointer)); 2749 pmop->op_pmoffset = av_len(PL_regex_padav); 2750 PL_regex_pad = AvARRAY(PL_regex_padav); 2751 } 2752 #endif 2753 2754 /* link into pm list */ 2755 if (type != OP_TRANS && PL_curstash) { 2756 pmop->op_pmnext = HvPMROOT(PL_curstash); 2757 HvPMROOT(PL_curstash) = pmop; 2758 PmopSTASH_set(pmop,PL_curstash); 2759 } 2760 2761 return CHECKOP(type, pmop); 2762 } 2763 2764 OP * 2765 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl) 2766 { 2767 PMOP *pm; 2768 LOGOP *rcop; 2769 I32 repl_has_vars = 0; 2770 2771 if (o->op_type == OP_TRANS) 2772 return pmtrans(o, expr, repl); 2773 2774 PL_hints |= HINT_BLOCK_SCOPE; 2775 pm = (PMOP*)o; 2776 2777 if (expr->op_type == OP_CONST) { 2778 STRLEN plen; 2779 SV *pat = ((SVOP*)expr)->op_sv; 2780 const char *p = SvPV_const(pat, plen); 2781 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) { 2782 U32 was_readonly = SvREADONLY(pat); 2783 2784 if (was_readonly) { 2785 if (SvFAKE(pat)) { 2786 sv_force_normal_flags(pat, 0); 2787 assert(!SvREADONLY(pat)); 2788 was_readonly = 0; 2789 } else { 2790 SvREADONLY_off(pat); 2791 } 2792 } 2793 2794 sv_setpvn(pat, "\\s+", 3); 2795 2796 SvFLAGS(pat) |= was_readonly; 2797 2798 p = SvPV_const(pat, plen); 2799 pm->op_pmflags |= PMf_SKIPWHITE; 2800 } 2801 if (DO_UTF8(pat)) 2802 pm->op_pmdynflags |= PMdf_UTF8; 2803 /* FIXME - can we make this function take const char * args? */ 2804 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm)); 2805 if (strEQ("\\s+", PM_GETRE(pm)->precomp)) 2806 pm->op_pmflags |= PMf_WHITE; 2807 op_free(expr); 2808 } 2809 else { 2810 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) 2811 expr = newUNOP((!(PL_hints & HINT_RE_EVAL) 2812 ? OP_REGCRESET 2813 : OP_REGCMAYBE),0,expr); 2814 2815 NewOp(1101, rcop, 1, LOGOP); 2816 rcop->op_type = OP_REGCOMP; 2817 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP]; 2818 rcop->op_first = scalar(expr); 2819 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) 2820 ? (OPf_SPECIAL | OPf_KIDS) 2821 : OPf_KIDS); 2822 rcop->op_private = 1; 2823 rcop->op_other = o; 2824 2825 /* establish postfix order */ 2826 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) { 2827 LINKLIST(expr); 2828 rcop->op_next = expr; 2829 ((UNOP*)expr)->op_first->op_next = (OP*)rcop; 2830 } 2831 else { 2832 rcop->op_next = LINKLIST(expr); 2833 expr->op_next = (OP*)rcop; 2834 } 2835 2836 prepend_elem(o->op_type, scalar((OP*)rcop), o); 2837 } 2838 2839 if (repl) { 2840 OP *curop; 2841 if (pm->op_pmflags & PMf_EVAL) { 2842 curop = 0; 2843 if (CopLINE(PL_curcop) < (line_t)PL_multi_end) 2844 CopLINE_set(PL_curcop, (line_t)PL_multi_end); 2845 } 2846 #ifdef USE_5005THREADS 2847 else if (repl->op_type == OP_THREADSV 2848 && strchr("&`'123456789+", 2849 PL_threadsv_names[repl->op_targ])) 2850 { 2851 curop = 0; 2852 } 2853 #endif /* USE_5005THREADS */ 2854 else if (repl->op_type == OP_CONST) 2855 curop = repl; 2856 else { 2857 OP *lastop = 0; 2858 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) { 2859 if (PL_opargs[curop->op_type] & OA_DANGEROUS) { 2860 #ifdef USE_5005THREADS 2861 if (curop->op_type == OP_THREADSV) { 2862 repl_has_vars = 1; 2863 if (strchr("&`'123456789+", curop->op_private)) 2864 break; 2865 } 2866 #else 2867 if (curop->op_type == OP_GV) { 2868 GV *gv = cGVOPx_gv(curop); 2869 repl_has_vars = 1; 2870 if (strchr("&`'123456789+-\016\022", *GvENAME(gv))) 2871 break; 2872 } 2873 #endif /* USE_5005THREADS */ 2874 else if (curop->op_type == OP_RV2CV) 2875 break; 2876 else if (curop->op_type == OP_RV2SV || 2877 curop->op_type == OP_RV2AV || 2878 curop->op_type == OP_RV2HV || 2879 curop->op_type == OP_RV2GV) { 2880 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/ 2881 break; 2882 } 2883 else if (curop->op_type == OP_PADSV || 2884 curop->op_type == OP_PADAV || 2885 curop->op_type == OP_PADHV || 2886 curop->op_type == OP_PADANY) { 2887 repl_has_vars = 1; 2888 } 2889 else if (curop->op_type == OP_PUSHRE) 2890 ; /* Okay here, dangerous in newASSIGNOP */ 2891 else 2892 break; 2893 } 2894 lastop = curop; 2895 } 2896 } 2897 if (curop == repl 2898 && !(repl_has_vars 2899 && (!PM_GETRE(pm) 2900 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) { 2901 pm->op_pmflags |= PMf_CONST; /* const for long enough */ 2902 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */ 2903 prepend_elem(o->op_type, scalar(repl), o); 2904 } 2905 else { 2906 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */ 2907 pm->op_pmflags |= PMf_MAYBE_CONST; 2908 pm->op_pmpermflags |= PMf_MAYBE_CONST; 2909 } 2910 NewOp(1101, rcop, 1, LOGOP); 2911 rcop->op_type = OP_SUBSTCONT; 2912 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT]; 2913 rcop->op_first = scalar(repl); 2914 rcop->op_flags |= OPf_KIDS; 2915 rcop->op_private = 1; 2916 rcop->op_other = o; 2917 2918 /* establish postfix order */ 2919 rcop->op_next = LINKLIST(repl); 2920 repl->op_next = (OP*)rcop; 2921 2922 pm->op_pmreplroot = scalar((OP*)rcop); 2923 pm->op_pmreplstart = LINKLIST(rcop); 2924 rcop->op_next = 0; 2925 } 2926 } 2927 2928 return (OP*)pm; 2929 } 2930 2931 OP * 2932 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv) 2933 { 2934 SVOP *svop; 2935 NewOp(1101, svop, 1, SVOP); 2936 svop->op_type = (OPCODE)type; 2937 svop->op_ppaddr = PL_ppaddr[type]; 2938 svop->op_sv = sv; 2939 svop->op_next = (OP*)svop; 2940 svop->op_flags = (U8)flags; 2941 if (PL_opargs[type] & OA_RETSCALAR) 2942 scalar((OP*)svop); 2943 if (PL_opargs[type] & OA_TARGET) 2944 svop->op_targ = pad_alloc(type, SVs_PADTMP); 2945 return CHECKOP(type, svop); 2946 } 2947 2948 OP * 2949 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) 2950 { 2951 PADOP *padop; 2952 NewOp(1101, padop, 1, PADOP); 2953 padop->op_type = (OPCODE)type; 2954 padop->op_ppaddr = PL_ppaddr[type]; 2955 padop->op_padix = pad_alloc(type, SVs_PADTMP); 2956 SvREFCNT_dec(PAD_SVl(padop->op_padix)); 2957 PAD_SETSV(padop->op_padix, sv); 2958 if (sv) 2959 SvPADTMP_on(sv); 2960 padop->op_next = (OP*)padop; 2961 padop->op_flags = (U8)flags; 2962 if (PL_opargs[type] & OA_RETSCALAR) 2963 scalar((OP*)padop); 2964 if (PL_opargs[type] & OA_TARGET) 2965 padop->op_targ = pad_alloc(type, SVs_PADTMP); 2966 return CHECKOP(type, padop); 2967 } 2968 2969 OP * 2970 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv) 2971 { 2972 #ifdef USE_ITHREADS 2973 if (gv) 2974 GvIN_PAD_on(gv); 2975 return newPADOP(type, flags, SvREFCNT_inc(gv)); 2976 #else 2977 return newSVOP(type, flags, SvREFCNT_inc(gv)); 2978 #endif 2979 } 2980 2981 OP * 2982 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv) 2983 { 2984 PVOP *pvop; 2985 NewOp(1101, pvop, 1, PVOP); 2986 pvop->op_type = (OPCODE)type; 2987 pvop->op_ppaddr = PL_ppaddr[type]; 2988 pvop->op_pv = pv; 2989 pvop->op_next = (OP*)pvop; 2990 pvop->op_flags = (U8)flags; 2991 if (PL_opargs[type] & OA_RETSCALAR) 2992 scalar((OP*)pvop); 2993 if (PL_opargs[type] & OA_TARGET) 2994 pvop->op_targ = pad_alloc(type, SVs_PADTMP); 2995 return CHECKOP(type, pvop); 2996 } 2997 2998 void 2999 Perl_package(pTHX_ OP *o) 3000 { 3001 SV *sv; 3002 3003 save_hptr(&PL_curstash); 3004 save_item(PL_curstname); 3005 if (o) { 3006 STRLEN len; 3007 const char *name; 3008 sv = cSVOPo->op_sv; 3009 name = SvPV_const(sv, len); 3010 PL_curstash = gv_stashpvn(name,len,TRUE); 3011 sv_setpvn(PL_curstname, name, len); 3012 op_free(o); 3013 } 3014 else { 3015 deprecate("\"package\" with no arguments"); 3016 sv_setpv(PL_curstname,"<none>"); 3017 PL_curstash = Nullhv; 3018 } 3019 PL_hints |= HINT_BLOCK_SCOPE; 3020 PL_copline = NOLINE; 3021 PL_expect = XSTATE; 3022 } 3023 3024 void 3025 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) 3026 { 3027 OP *pack; 3028 OP *imop; 3029 OP *veop; 3030 3031 if (idop->op_type != OP_CONST) 3032 Perl_croak(aTHX_ "Module name must be constant"); 3033 3034 veop = Nullop; 3035 3036 if (version) { 3037 SV * const vesv = ((SVOP*)version)->op_sv; 3038 3039 if (!arg && !SvNIOKp(vesv)) { 3040 arg = version; 3041 } 3042 else { 3043 OP *pack; 3044 SV *meth; 3045 3046 if (version->op_type != OP_CONST || !SvNIOKp(vesv)) 3047 Perl_croak(aTHX_ "Version number must be constant number"); 3048 3049 /* Make copy of idop so we don't free it twice */ 3050 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv)); 3051 3052 /* Fake up a method call to VERSION */ 3053 meth = newSVpvn("VERSION",7); 3054 sv_upgrade(meth, SVt_PVIV); 3055 (void)SvIOK_on(meth); 3056 { 3057 U32 hash; 3058 PERL_HASH(hash, SvPVX_const(meth), SvCUR(meth)); 3059 SvUV_set(meth, hash); 3060 } 3061 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, 3062 append_elem(OP_LIST, 3063 prepend_elem(OP_LIST, pack, list(version)), 3064 newSVOP(OP_METHOD_NAMED, 0, meth))); 3065 } 3066 } 3067 3068 /* Fake up an import/unimport */ 3069 if (arg && arg->op_type == OP_STUB) 3070 imop = arg; /* no import on explicit () */ 3071 else if (SvNIOKp(((SVOP*)idop)->op_sv)) { 3072 imop = Nullop; /* use 5.0; */ 3073 } 3074 else { 3075 SV *meth; 3076 3077 /* Make copy of idop so we don't free it twice */ 3078 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv)); 3079 3080 /* Fake up a method call to import/unimport */ 3081 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8); 3082 (void)SvUPGRADE(meth, SVt_PVIV); 3083 (void)SvIOK_on(meth); 3084 { 3085 U32 hash; 3086 PERL_HASH(hash, SvPVX_const(meth), SvCUR(meth)); 3087 SvUV_set(meth, hash); 3088 } 3089 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, 3090 append_elem(OP_LIST, 3091 prepend_elem(OP_LIST, pack, list(arg)), 3092 newSVOP(OP_METHOD_NAMED, 0, meth))); 3093 } 3094 3095 /* Fake up the BEGIN {}, which does its thing immediately. */ 3096 newATTRSUB(floor, 3097 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)), 3098 Nullop, 3099 Nullop, 3100 append_elem(OP_LINESEQ, 3101 append_elem(OP_LINESEQ, 3102 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)), 3103 newSTATEOP(0, Nullch, veop)), 3104 newSTATEOP(0, Nullch, imop) )); 3105 3106 /* The "did you use incorrect case?" warning used to be here. 3107 * The problem is that on case-insensitive filesystems one 3108 * might get false positives for "use" (and "require"): 3109 * "use Strict" or "require CARP" will work. This causes 3110 * portability problems for the script: in case-strict 3111 * filesystems the script will stop working. 3112 * 3113 * The "incorrect case" warning checked whether "use Foo" 3114 * imported "Foo" to your namespace, but that is wrong, too: 3115 * there is no requirement nor promise in the language that 3116 * a Foo.pm should or would contain anything in package "Foo". 3117 * 3118 * There is very little Configure-wise that can be done, either: 3119 * the case-sensitivity of the build filesystem of Perl does not 3120 * help in guessing the case-sensitivity of the runtime environment. 3121 */ 3122 3123 PL_hints |= HINT_BLOCK_SCOPE; 3124 PL_copline = NOLINE; 3125 PL_expect = XSTATE; 3126 PL_cop_seqmax++; /* Purely for B::*'s benefit */ 3127 } 3128 3129 /* 3130 =head1 Embedding Functions 3131 3132 =for apidoc load_module 3133 3134 Loads the module whose name is pointed to by the string part of name. 3135 Note that the actual module name, not its filename, should be given. 3136 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of 3137 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS 3138 (or 0 for no flags). ver, if specified, provides version semantics 3139 similar to C<use Foo::Bar VERSION>. The optional trailing SV* 3140 arguments can be used to specify arguments to the module's import() 3141 method, similar to C<use Foo::Bar VERSION LIST>. 3142 3143 =cut */ 3144 3145 void 3146 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...) 3147 { 3148 va_list args; 3149 va_start(args, ver); 3150 vload_module(flags, name, ver, &args); 3151 va_end(args); 3152 } 3153 3154 #ifdef PERL_IMPLICIT_CONTEXT 3155 void 3156 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...) 3157 { 3158 dTHX; 3159 va_list args; 3160 va_start(args, ver); 3161 vload_module(flags, name, ver, &args); 3162 va_end(args); 3163 } 3164 #endif 3165 3166 void 3167 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args) 3168 { 3169 OP *veop, *imop; 3170 3171 OP * const modname = newSVOP(OP_CONST, 0, name); 3172 modname->op_private |= OPpCONST_BARE; 3173 if (ver) { 3174 veop = newSVOP(OP_CONST, 0, ver); 3175 } 3176 else 3177 veop = Nullop; 3178 if (flags & PERL_LOADMOD_NOIMPORT) { 3179 imop = sawparens(newNULLLIST()); 3180 } 3181 else if (flags & PERL_LOADMOD_IMPORT_OPS) { 3182 imop = va_arg(*args, OP*); 3183 } 3184 else { 3185 SV *sv; 3186 imop = Nullop; 3187 sv = va_arg(*args, SV*); 3188 while (sv) { 3189 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv)); 3190 sv = va_arg(*args, SV*); 3191 } 3192 } 3193 { 3194 const line_t ocopline = PL_copline; 3195 COP * const ocurcop = PL_curcop; 3196 const int oexpect = PL_expect; 3197 3198 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), 3199 veop, modname, imop); 3200 PL_expect = oexpect; 3201 PL_copline = ocopline; 3202 PL_curcop = ocurcop; 3203 } 3204 } 3205 3206 OP * 3207 Perl_dofile(pTHX_ OP *term) 3208 { 3209 OP *doop; 3210 GV *gv; 3211 3212 gv = gv_fetchpv("do", FALSE, SVt_PVCV); 3213 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) 3214 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV); 3215 3216 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) { 3217 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED, 3218 append_elem(OP_LIST, term, 3219 scalar(newUNOP(OP_RV2CV, 0, 3220 newGVOP(OP_GV, 0, 3221 gv)))))); 3222 } 3223 else { 3224 doop = newUNOP(OP_DOFILE, 0, scalar(term)); 3225 } 3226 return doop; 3227 } 3228 3229 OP * 3230 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval) 3231 { 3232 return newBINOP(OP_LSLICE, flags, 3233 list(force_list(subscript)), 3234 list(force_list(listval)) ); 3235 } 3236 3237 STATIC I32 3238 S_is_list_assignment(pTHX_ register const OP *o) 3239 { 3240 if (!o) 3241 return TRUE; 3242 3243 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS) 3244 o = cUNOPo->op_first; 3245 3246 if (o->op_type == OP_COND_EXPR) { 3247 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling); 3248 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling); 3249 3250 if (t && f) 3251 return TRUE; 3252 if (t || f) 3253 yyerror("Assignment to both a list and a scalar"); 3254 return FALSE; 3255 } 3256 3257 if (o->op_type == OP_LIST && 3258 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR && 3259 o->op_private & OPpLVAL_INTRO) 3260 return FALSE; 3261 3262 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS || 3263 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV || 3264 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE) 3265 return TRUE; 3266 3267 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) 3268 return TRUE; 3269 3270 if (o->op_type == OP_RV2SV) 3271 return FALSE; 3272 3273 return FALSE; 3274 } 3275 3276 OP * 3277 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) 3278 { 3279 OP *o; 3280 3281 if (optype) { 3282 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) { 3283 return newLOGOP(optype, 0, 3284 mod(scalar(left), optype), 3285 newUNOP(OP_SASSIGN, 0, scalar(right))); 3286 } 3287 else { 3288 return newBINOP(optype, OPf_STACKED, 3289 mod(scalar(left), optype), scalar(right)); 3290 } 3291 } 3292 3293 if (is_list_assignment(left)) { 3294 OP *curop; 3295 3296 PL_modcount = 0; 3297 /* Grandfathering $[ assignment here. Bletch.*/ 3298 /* Only simple assignments like C<< ($[) = 1 >> are allowed */ 3299 PL_eval_start = (left->op_type == OP_CONST) ? right : 0; 3300 left = mod(left, OP_AASSIGN); 3301 if (PL_eval_start) 3302 PL_eval_start = 0; 3303 else if (left->op_type == OP_CONST) { 3304 /* Result of assignment is always 1 (or we'd be dead already) */ 3305 return newSVOP(OP_CONST, 0, newSViv(1)); 3306 } 3307 curop = list(force_list(left)); 3308 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop); 3309 o->op_private = (U8)(0 | (flags >> 8)); 3310 for (curop = ((LISTOP*)curop)->op_first; 3311 curop; curop = curop->op_sibling) 3312 { 3313 if (curop->op_type == OP_RV2HV && 3314 ((UNOP*)curop)->op_first->op_type != OP_GV) { 3315 o->op_private |= OPpASSIGN_HASH; 3316 break; 3317 } 3318 } 3319 3320 /* PL_generation sorcery: 3321 * an assignment like ($a,$b) = ($c,$d) is easier than 3322 * ($a,$b) = ($c,$a), since there is no need for temporary vars. 3323 * To detect whether there are common vars, the global var 3324 * PL_generation is incremented for each assign op we compile. 3325 * Then, while compiling the assign op, we run through all the 3326 * variables on both sides of the assignment, setting a spare slot 3327 * in each of them to PL_generation. If any of them already have 3328 * that value, we know we've got commonality. We could use a 3329 * single bit marker, but then we'd have to make 2 passes, first 3330 * to clear the flag, then to test and set it. To find somewhere 3331 * to store these values, evil chicanery is done with SvCUR(). 3332 */ 3333 3334 if (!(left->op_private & OPpLVAL_INTRO)) { 3335 OP *lastop = o; 3336 PL_generation++; 3337 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) { 3338 if (PL_opargs[curop->op_type] & OA_DANGEROUS) { 3339 if (curop->op_type == OP_GV) { 3340 GV *gv = cGVOPx_gv(curop); 3341 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation) 3342 break; 3343 SvCUR_set(gv, PL_generation); 3344 } 3345 else if (curop->op_type == OP_PADSV || 3346 curop->op_type == OP_PADAV || 3347 curop->op_type == OP_PADHV || 3348 curop->op_type == OP_PADANY) 3349 { 3350 if ((int)PAD_COMPNAME_GEN(curop->op_targ) 3351 == PL_generation) 3352 break; 3353 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation); 3354 3355 } 3356 else if (curop->op_type == OP_RV2CV) 3357 break; 3358 else if (curop->op_type == OP_RV2SV || 3359 curop->op_type == OP_RV2AV || 3360 curop->op_type == OP_RV2HV || 3361 curop->op_type == OP_RV2GV) { 3362 if (lastop->op_type != OP_GV) /* funny deref? */ 3363 break; 3364 } 3365 else if (curop->op_type == OP_PUSHRE) { 3366 if (((PMOP*)curop)->op_pmreplroot) { 3367 #ifdef USE_ITHREADS 3368 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET, 3369 ((PMOP*)curop)->op_pmreplroot)); 3370 #else 3371 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot; 3372 #endif 3373 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation) 3374 break; 3375 SvCUR_set(gv, PL_generation); 3376 } 3377 } 3378 else 3379 break; 3380 } 3381 lastop = curop; 3382 } 3383 if (curop != o) 3384 o->op_private |= OPpASSIGN_COMMON; 3385 } 3386 if (right && right->op_type == OP_SPLIT) { 3387 OP* tmpop; 3388 if ((tmpop = ((LISTOP*)right)->op_first) && 3389 tmpop->op_type == OP_PUSHRE) 3390 { 3391 PMOP * const pm = (PMOP*)tmpop; 3392 if (left->op_type == OP_RV2AV && 3393 !(left->op_private & OPpLVAL_INTRO) && 3394 !(o->op_private & OPpASSIGN_COMMON) ) 3395 { 3396 tmpop = ((UNOP*)left)->op_first; 3397 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) { 3398 #ifdef USE_ITHREADS 3399 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix); 3400 cPADOPx(tmpop)->op_padix = 0; /* steal it */ 3401 #else 3402 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv; 3403 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */ 3404 #endif 3405 pm->op_pmflags |= PMf_ONCE; 3406 tmpop = cUNOPo->op_first; /* to list (nulled) */ 3407 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */ 3408 tmpop->op_sibling = Nullop; /* don't free split */ 3409 right->op_next = tmpop->op_next; /* fix starting loc */ 3410 op_free(o); /* blow off assign */ 3411 right->op_flags &= ~OPf_WANT; 3412 /* "I don't know and I don't care." */ 3413 return right; 3414 } 3415 } 3416 else { 3417 if (PL_modcount < RETURN_UNLIMITED_NUMBER && 3418 ((LISTOP*)right)->op_last->op_type == OP_CONST) 3419 { 3420 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv; 3421 if (SvIVX(sv) == 0) 3422 sv_setiv(sv, PL_modcount+1); 3423 } 3424 } 3425 } 3426 } 3427 return o; 3428 } 3429 if (!right) 3430 right = newOP(OP_UNDEF, 0); 3431 if (right->op_type == OP_READLINE) { 3432 right->op_flags |= OPf_STACKED; 3433 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right)); 3434 } 3435 else { 3436 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/ 3437 o = newBINOP(OP_SASSIGN, flags, 3438 scalar(right), mod(scalar(left), OP_SASSIGN) ); 3439 if (PL_eval_start) 3440 PL_eval_start = 0; 3441 else { 3442 o = newSVOP(OP_CONST, 0, newSViv(PL_compiling.cop_arybase)); 3443 } 3444 } 3445 return o; 3446 } 3447 3448 OP * 3449 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) 3450 { 3451 const U32 seq = intro_my(); 3452 register COP *cop; 3453 3454 NewOp(1101, cop, 1, COP); 3455 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) { 3456 cop->op_type = OP_DBSTATE; 3457 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ]; 3458 } 3459 else { 3460 cop->op_type = OP_NEXTSTATE; 3461 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ]; 3462 } 3463 cop->op_flags = (U8)flags; 3464 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); 3465 #ifdef NATIVE_HINTS 3466 cop->op_private |= NATIVE_HINTS; 3467 #endif 3468 PL_compiling.op_private = cop->op_private; 3469 cop->op_next = (OP*)cop; 3470 3471 if (label) { 3472 cop->cop_label = label; 3473 PL_hints |= HINT_BLOCK_SCOPE; 3474 } 3475 cop->cop_seq = seq; 3476 cop->cop_arybase = PL_curcop->cop_arybase; 3477 if (specialWARN(PL_curcop->cop_warnings)) 3478 cop->cop_warnings = PL_curcop->cop_warnings ; 3479 else 3480 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ; 3481 if (specialCopIO(PL_curcop->cop_io)) 3482 cop->cop_io = PL_curcop->cop_io; 3483 else 3484 cop->cop_io = newSVsv(PL_curcop->cop_io) ; 3485 3486 3487 if (PL_copline == NOLINE) 3488 CopLINE_set(cop, CopLINE(PL_curcop)); 3489 else { 3490 CopLINE_set(cop, PL_copline); 3491 PL_copline = NOLINE; 3492 } 3493 #ifdef USE_ITHREADS 3494 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */ 3495 #else 3496 CopFILEGV_set(cop, CopFILEGV(PL_curcop)); 3497 #endif 3498 CopSTASH_set(cop, PL_curstash); 3499 3500 if (PERLDB_LINE && PL_curstash != PL_debstash) { 3501 SV * const * const svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE); 3502 if (svp && *svp != &PL_sv_undef ) { 3503 (void)SvIOK_on(*svp); 3504 SvIV_set(*svp, PTR2IV(cop)); 3505 } 3506 } 3507 3508 return prepend_elem(OP_LINESEQ, (OP*)cop, o); 3509 } 3510 3511 3512 OP * 3513 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other) 3514 { 3515 return new_logop(type, flags, &first, &other); 3516 } 3517 3518 STATIC OP * 3519 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) 3520 { 3521 LOGOP *logop; 3522 OP *o; 3523 OP *first = *firstp; 3524 OP * const other = *otherp; 3525 3526 if (type == OP_XOR) /* Not short circuit, but here by precedence. */ 3527 return newBINOP(type, flags, scalar(first), scalar(other)); 3528 3529 scalarboolean(first); 3530 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */ 3531 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) { 3532 if (type == OP_AND || type == OP_OR) { 3533 if (type == OP_AND) 3534 type = OP_OR; 3535 else 3536 type = OP_AND; 3537 o = first; 3538 first = *firstp = cUNOPo->op_first; 3539 if (o->op_next) 3540 first->op_next = o->op_next; 3541 cUNOPo->op_first = Nullop; 3542 op_free(o); 3543 } 3544 } 3545 if (first->op_type == OP_CONST) { 3546 if (first->op_private & OPpCONST_STRICT) 3547 no_bareword_allowed(first); 3548 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD)) 3549 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional"); 3550 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) { 3551 op_free(first); 3552 *firstp = Nullop; 3553 if (other->op_type == OP_CONST) 3554 other->op_private |= OPpCONST_SHORTCIRCUIT; 3555 return other; 3556 } 3557 else { 3558 op_free(other); 3559 *otherp = Nullop; 3560 if (first->op_type == OP_CONST) 3561 first->op_private |= OPpCONST_SHORTCIRCUIT; 3562 return first; 3563 } 3564 } 3565 else if ((first->op_flags & OPf_KIDS) && ckWARN(WARN_MISC)) { 3566 const OP * const k1 = ((UNOP*)first)->op_first; 3567 const OP * const k2 = k1->op_sibling; 3568 OPCODE warnop = 0; 3569 switch (first->op_type) 3570 { 3571 case OP_NULL: 3572 if (k2 && k2->op_type == OP_READLINE 3573 && (k2->op_flags & OPf_STACKED) 3574 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) 3575 { 3576 warnop = k2->op_type; 3577 } 3578 break; 3579 3580 case OP_SASSIGN: 3581 if (k1->op_type == OP_READDIR 3582 || k1->op_type == OP_GLOB 3583 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB) 3584 || k1->op_type == OP_EACH) 3585 { 3586 warnop = ((k1->op_type == OP_NULL) 3587 ? (OPCODE)k1->op_targ : k1->op_type); 3588 } 3589 break; 3590 } 3591 if (warnop) { 3592 const line_t oldline = CopLINE(PL_curcop); 3593 CopLINE_set(PL_curcop, PL_copline); 3594 Perl_warner(aTHX_ packWARN(WARN_MISC), 3595 "Value of %s%s can be \"0\"; test with defined()", 3596 PL_op_desc[warnop], 3597 ((warnop == OP_READLINE || warnop == OP_GLOB) 3598 ? " construct" : "() operator")); 3599 CopLINE_set(PL_curcop, oldline); 3600 } 3601 } 3602 3603 if (!other) 3604 return first; 3605 3606 if (type == OP_ANDASSIGN || type == OP_ORASSIGN) 3607 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */ 3608 3609 NewOp(1101, logop, 1, LOGOP); 3610 3611 logop->op_type = (OPCODE)type; 3612 logop->op_ppaddr = PL_ppaddr[type]; 3613 logop->op_first = first; 3614 logop->op_flags = (U8)(flags | OPf_KIDS); 3615 logop->op_other = LINKLIST(other); 3616 logop->op_private = (U8)(1 | (flags >> 8)); 3617 3618 /* establish postfix order */ 3619 logop->op_next = LINKLIST(first); 3620 first->op_next = (OP*)logop; 3621 first->op_sibling = other; 3622 3623 CHECKOP(type,logop); 3624 3625 o = newUNOP(OP_NULL, 0, (OP*)logop); 3626 other->op_next = o; 3627 3628 return o; 3629 } 3630 3631 OP * 3632 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) 3633 { 3634 LOGOP *logop; 3635 OP *start; 3636 OP *o; 3637 3638 if (!falseop) 3639 return newLOGOP(OP_AND, 0, first, trueop); 3640 if (!trueop) 3641 return newLOGOP(OP_OR, 0, first, falseop); 3642 3643 scalarboolean(first); 3644 if (first->op_type == OP_CONST) { 3645 if (first->op_private & OPpCONST_BARE && 3646 first->op_private & OPpCONST_STRICT) { 3647 no_bareword_allowed(first); 3648 } 3649 if (SvTRUE(((SVOP*)first)->op_sv)) { 3650 op_free(first); 3651 op_free(falseop); 3652 return trueop; 3653 } 3654 else { 3655 op_free(first); 3656 op_free(trueop); 3657 return falseop; 3658 } 3659 } 3660 NewOp(1101, logop, 1, LOGOP); 3661 logop->op_type = OP_COND_EXPR; 3662 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR]; 3663 logop->op_first = first; 3664 logop->op_flags = (U8)(flags | OPf_KIDS); 3665 logop->op_private = (U8)(1 | (flags >> 8)); 3666 logop->op_other = LINKLIST(trueop); 3667 logop->op_next = LINKLIST(falseop); 3668 3669 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */ 3670 logop); 3671 3672 /* establish postfix order */ 3673 start = LINKLIST(first); 3674 first->op_next = (OP*)logop; 3675 3676 first->op_sibling = trueop; 3677 trueop->op_sibling = falseop; 3678 o = newUNOP(OP_NULL, 0, (OP*)logop); 3679 3680 trueop->op_next = falseop->op_next = o; 3681 3682 o->op_next = start; 3683 return o; 3684 } 3685 3686 OP * 3687 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right) 3688 { 3689 LOGOP *range; 3690 OP *flip; 3691 OP *flop; 3692 OP *leftstart; 3693 OP *o; 3694 3695 NewOp(1101, range, 1, LOGOP); 3696 3697 range->op_type = OP_RANGE; 3698 range->op_ppaddr = PL_ppaddr[OP_RANGE]; 3699 range->op_first = left; 3700 range->op_flags = OPf_KIDS; 3701 leftstart = LINKLIST(left); 3702 range->op_other = LINKLIST(right); 3703 range->op_private = (U8)(1 | (flags >> 8)); 3704 3705 left->op_sibling = right; 3706 3707 range->op_next = (OP*)range; 3708 flip = newUNOP(OP_FLIP, flags, (OP*)range); 3709 flop = newUNOP(OP_FLOP, 0, flip); 3710 o = newUNOP(OP_NULL, 0, flop); 3711 linklist(flop); 3712 range->op_next = leftstart; 3713 3714 left->op_next = flip; 3715 right->op_next = flop; 3716 3717 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY); 3718 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV); 3719 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY); 3720 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV); 3721 3722 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0; 3723 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0; 3724 3725 flip->op_next = o; 3726 if (!flip->op_private || !flop->op_private) 3727 linklist(o); /* blow off optimizer unless constant */ 3728 3729 return o; 3730 } 3731 3732 OP * 3733 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) 3734 { 3735 OP* listop; 3736 OP* o; 3737 const bool once = block && block->op_flags & OPf_SPECIAL && 3738 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL); 3739 3740 PERL_UNUSED_ARG(debuggable); 3741 3742 if (expr) { 3743 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv)) 3744 return block; /* do {} while 0 does once */ 3745 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB 3746 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) { 3747 expr = newUNOP(OP_DEFINED, 0, 3748 newASSIGNOP(0, newDEFSVOP(), 0, expr) ); 3749 } else if (expr->op_flags & OPf_KIDS) { 3750 const OP * const k1 = ((UNOP*)expr)->op_first; 3751 const OP * const k2 = k1 ? k1->op_sibling : NULL; 3752 switch (expr->op_type) { 3753 case OP_NULL: 3754 if (k2 && k2->op_type == OP_READLINE 3755 && (k2->op_flags & OPf_STACKED) 3756 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) 3757 expr = newUNOP(OP_DEFINED, 0, expr); 3758 break; 3759 3760 case OP_SASSIGN: 3761 if (k1->op_type == OP_READDIR 3762 || k1->op_type == OP_GLOB 3763 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB) 3764 || k1->op_type == OP_EACH) 3765 expr = newUNOP(OP_DEFINED, 0, expr); 3766 break; 3767 } 3768 } 3769 } 3770 3771 /* if block is null, the next append_elem() would put UNSTACK, a scalar 3772 * op, in listop. This is wrong. [perl #27024] */ 3773 if (!block) 3774 block = newOP(OP_NULL, 0); 3775 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0)); 3776 o = new_logop(OP_AND, 0, &expr, &listop); 3777 3778 if (listop) 3779 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o); 3780 3781 if (once && o != listop) 3782 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other; 3783 3784 if (o == listop) 3785 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */ 3786 3787 o->op_flags |= flags; 3788 o = scope(o); 3789 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/ 3790 return o; 3791 } 3792 3793 OP * 3794 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont) 3795 { 3796 OP *redo; 3797 OP *next = 0; 3798 OP *listop; 3799 OP *o; 3800 U8 loopflags = 0; 3801 3802 PERL_UNUSED_ARG(debuggable); 3803 3804 if (expr) { 3805 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB 3806 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) { 3807 expr = newUNOP(OP_DEFINED, 0, 3808 newASSIGNOP(0, newDEFSVOP(), 0, expr) ); 3809 } else if (expr->op_flags & OPf_KIDS) { 3810 const OP * const k1 = ((UNOP*)expr)->op_first; 3811 const OP * const k2 = (k1) ? k1->op_sibling : NULL; 3812 switch (expr->op_type) { 3813 case OP_NULL: 3814 if (k2 && k2->op_type == OP_READLINE 3815 && (k2->op_flags & OPf_STACKED) 3816 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) 3817 expr = newUNOP(OP_DEFINED, 0, expr); 3818 break; 3819 3820 case OP_SASSIGN: 3821 if (k1->op_type == OP_READDIR 3822 || k1->op_type == OP_GLOB 3823 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB) 3824 || k1->op_type == OP_EACH) 3825 expr = newUNOP(OP_DEFINED, 0, expr); 3826 break; 3827 } 3828 } 3829 } 3830 3831 if (!block) 3832 block = newOP(OP_NULL, 0); 3833 else if (cont) { 3834 block = scope(block); 3835 } 3836 3837 if (cont) { 3838 next = LINKLIST(cont); 3839 } 3840 if (expr) { 3841 OP * const unstack = newOP(OP_UNSTACK, 0); 3842 if (!next) 3843 next = unstack; 3844 cont = append_elem(OP_LINESEQ, cont, unstack); 3845 } 3846 3847 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont); 3848 redo = LINKLIST(listop); 3849 3850 if (expr) { 3851 PL_copline = (line_t)whileline; 3852 scalar(listop); 3853 o = new_logop(OP_AND, 0, &expr, &listop); 3854 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) { 3855 op_free(expr); /* oops, it's a while (0) */ 3856 op_free((OP*)loop); 3857 return Nullop; /* listop already freed by new_logop */ 3858 } 3859 if (listop) 3860 ((LISTOP*)listop)->op_last->op_next = 3861 (o == listop ? redo : LINKLIST(o)); 3862 } 3863 else 3864 o = listop; 3865 3866 if (!loop) { 3867 NewOp(1101,loop,1,LOOP); 3868 loop->op_type = OP_ENTERLOOP; 3869 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP]; 3870 loop->op_private = 0; 3871 loop->op_next = (OP*)loop; 3872 } 3873 3874 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o); 3875 3876 loop->op_redoop = redo; 3877 loop->op_lastop = o; 3878 o->op_private |= loopflags; 3879 3880 if (next) 3881 loop->op_nextop = next; 3882 else 3883 loop->op_nextop = o; 3884 3885 o->op_flags |= flags; 3886 o->op_private |= (flags >> 8); 3887 return o; 3888 } 3889 3890 OP * 3891 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont) 3892 { 3893 LOOP *loop; 3894 OP *wop; 3895 PADOFFSET padoff = 0; 3896 I32 iterflags = 0; 3897 I32 iterpflags = 0; 3898 3899 if (sv) { 3900 if (sv->op_type == OP_RV2SV) { /* symbol table variable */ 3901 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */ 3902 sv->op_type = OP_RV2GV; 3903 sv->op_ppaddr = PL_ppaddr[OP_RV2GV]; 3904 } 3905 else if (sv->op_type == OP_PADSV) { /* private variable */ 3906 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */ 3907 padoff = sv->op_targ; 3908 sv->op_targ = 0; 3909 op_free(sv); 3910 sv = Nullop; 3911 } 3912 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */ 3913 padoff = sv->op_targ; 3914 sv->op_targ = 0; 3915 iterflags |= OPf_SPECIAL; 3916 op_free(sv); 3917 sv = Nullop; 3918 } 3919 else 3920 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]); 3921 } 3922 else { 3923 #ifdef USE_5005THREADS 3924 padoff = find_threadsv("_"); 3925 iterflags |= OPf_SPECIAL; 3926 #else 3927 sv = newGVOP(OP_GV, 0, PL_defgv); 3928 #endif 3929 } 3930 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) { 3931 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART); 3932 iterflags |= OPf_STACKED; 3933 } 3934 else if (expr->op_type == OP_NULL && 3935 (expr->op_flags & OPf_KIDS) && 3936 ((BINOP*)expr)->op_first->op_type == OP_FLOP) 3937 { 3938 /* Basically turn for($x..$y) into the same as for($x,$y), but we 3939 * set the STACKED flag to indicate that these values are to be 3940 * treated as min/max values by 'pp_iterinit'. 3941 */ 3942 UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first; 3943 LOGOP* const range = (LOGOP*) flip->op_first; 3944 OP* const left = range->op_first; 3945 OP* const right = left->op_sibling; 3946 LISTOP* listop; 3947 3948 range->op_flags &= ~OPf_KIDS; 3949 range->op_first = Nullop; 3950 3951 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right); 3952 listop->op_first->op_next = range->op_next; 3953 left->op_next = range->op_other; 3954 right->op_next = (OP*)listop; 3955 listop->op_next = listop->op_first; 3956 3957 op_free(expr); 3958 expr = (OP*)(listop); 3959 op_null(expr); 3960 iterflags |= OPf_STACKED; 3961 } 3962 else { 3963 expr = mod(force_list(expr), OP_GREPSTART); 3964 } 3965 3966 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags, 3967 append_elem(OP_LIST, expr, scalar(sv)))); 3968 assert(!loop->op_next); 3969 /* for my $x () sets OPpLVAL_INTRO; 3970 * for our $x () sets OPpOUR_INTRO; both only used by Deparse.pm */ 3971 loop->op_private = (U8)iterpflags; 3972 #ifdef PL_OP_SLAB_ALLOC 3973 { 3974 LOOP *tmp; 3975 NewOp(1234,tmp,1,LOOP); 3976 Copy(loop,tmp,1,LISTOP); 3977 FreeOp(loop); 3978 loop = tmp; 3979 } 3980 #else 3981 Renew(loop, 1, LOOP); 3982 #endif 3983 loop->op_targ = padoff; 3984 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont); 3985 PL_copline = forline; 3986 return newSTATEOP(0, label, wop); 3987 } 3988 3989 OP* 3990 Perl_newLOOPEX(pTHX_ I32 type, OP *label) 3991 { 3992 OP *o; 3993 3994 if (type != OP_GOTO || label->op_type == OP_CONST) { 3995 /* "last()" means "last" */ 3996 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) 3997 o = newOP(type, OPf_SPECIAL); 3998 else { 3999 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST 4000 ? SvPVx_nolen_const(((SVOP*)label)->op_sv) 4001 : "")); 4002 } 4003 op_free(label); 4004 } 4005 else { 4006 /* Check whether it's going to be a goto &function */ 4007 if (label->op_type == OP_ENTERSUB 4008 && !(label->op_flags & OPf_STACKED)) 4009 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN)); 4010 o = newUNOP(type, OPf_STACKED, label); 4011 } 4012 PL_hints |= HINT_BLOCK_SCOPE; 4013 return o; 4014 } 4015 4016 /* 4017 =for apidoc cv_undef 4018 4019 Clear out all the active components of a CV. This can happen either 4020 by an explicit C<undef &foo>, or by the reference count going to zero. 4021 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous 4022 children can still follow the full lexical scope chain. 4023 4024 =cut 4025 */ 4026 4027 void 4028 Perl_cv_undef(pTHX_ CV *cv) 4029 { 4030 #ifdef USE_5005THREADS 4031 if (CvMUTEXP(cv)) { 4032 MUTEX_DESTROY(CvMUTEXP(cv)); 4033 Safefree(CvMUTEXP(cv)); 4034 CvMUTEXP(cv) = 0; 4035 } 4036 #endif /* USE_5005THREADS */ 4037 4038 #ifdef USE_ITHREADS 4039 if (CvFILE(cv) && !CvXSUB(cv)) { 4040 /* for XSUBs CvFILE point directly to static memory; __FILE__ */ 4041 Safefree(CvFILE(cv)); 4042 } 4043 CvFILE(cv) = 0; 4044 #endif 4045 4046 if (!CvXSUB(cv) && CvROOT(cv)) { 4047 #ifdef USE_5005THREADS 4048 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr)) 4049 Perl_croak(aTHX_ "Can't undef active subroutine"); 4050 #else 4051 if (CvDEPTH(cv)) 4052 Perl_croak(aTHX_ "Can't undef active subroutine"); 4053 #endif /* USE_5005THREADS */ 4054 ENTER; 4055 4056 PAD_SAVE_SETNULLPAD(); 4057 4058 op_free(CvROOT(cv)); 4059 CvROOT(cv) = Nullop; 4060 CvSTART(cv) = Nullop; 4061 LEAVE; 4062 } 4063 SvPOK_off((SV*)cv); /* forget prototype */ 4064 CvGV(cv) = Nullgv; 4065 4066 pad_undef(cv); 4067 4068 /* remove CvOUTSIDE unless this is an undef rather than a free */ 4069 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) { 4070 if (!CvWEAKOUTSIDE(cv)) 4071 SvREFCNT_dec(CvOUTSIDE(cv)); 4072 CvOUTSIDE(cv) = Nullcv; 4073 } 4074 if (CvCONST(cv)) { 4075 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr); 4076 CvCONST_off(cv); 4077 } 4078 if (CvXSUB(cv)) { 4079 CvXSUB(cv) = 0; 4080 } 4081 /* delete all flags except WEAKOUTSIDE */ 4082 CvFLAGS(cv) &= CVf_WEAKOUTSIDE; 4083 } 4084 4085 void 4086 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p) 4087 { 4088 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) { 4089 SV* const msg = sv_newmortal(); 4090 SV* name = Nullsv; 4091 4092 if (gv) 4093 gv_efullname3(name = sv_newmortal(), gv, Nullch); 4094 sv_setpv(msg, "Prototype mismatch:"); 4095 if (name) 4096 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name); 4097 if (SvPOK(cv)) 4098 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv); 4099 else 4100 Perl_sv_catpv(aTHX_ msg, ": none"); 4101 sv_catpv(msg, " vs "); 4102 if (p) 4103 Perl_sv_catpvf(aTHX_ msg, "(%s)", p); 4104 else 4105 sv_catpv(msg, "none"); 4106 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg); 4107 } 4108 } 4109 4110 static void const_sv_xsub(pTHX_ CV* cv); 4111 4112 /* 4113 4114 =head1 Optree Manipulation Functions 4115 4116 =for apidoc cv_const_sv 4117 4118 If C<cv> is a constant sub eligible for inlining. returns the constant 4119 value returned by the sub. Otherwise, returns NULL. 4120 4121 Constant subs can be created with C<newCONSTSUB> or as described in 4122 L<perlsub/"Constant Functions">. 4123 4124 =cut 4125 */ 4126 SV * 4127 Perl_cv_const_sv(pTHX_ CV *cv) 4128 { 4129 if (!cv || !CvCONST(cv)) 4130 return Nullsv; 4131 return (SV*)CvXSUBANY(cv).any_ptr; 4132 } 4133 4134 SV * 4135 Perl_op_const_sv(pTHX_ OP *o, CV *cv) 4136 { 4137 SV *sv = Nullsv; 4138 4139 if (!o) 4140 return Nullsv; 4141 4142 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first) 4143 o = cLISTOPo->op_first->op_sibling; 4144 4145 for (; o; o = o->op_next) { 4146 const OPCODE type = o->op_type; 4147 4148 if (sv && o->op_next == o) 4149 return sv; 4150 if (o->op_next != o) { 4151 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK) 4152 continue; 4153 if (type == OP_DBSTATE) 4154 continue; 4155 } 4156 if (type == OP_LEAVESUB || type == OP_RETURN) 4157 break; 4158 if (sv) 4159 return Nullsv; 4160 if (type == OP_CONST && cSVOPo->op_sv) 4161 sv = cSVOPo->op_sv; 4162 else if ((type == OP_PADSV || type == OP_CONST) && cv) { 4163 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ); 4164 if (!sv) 4165 return Nullsv; 4166 if (CvCONST(cv)) { 4167 /* We get here only from cv_clone2() while creating a closure. 4168 Copy the const value here instead of in cv_clone2 so that 4169 SvREADONLY_on doesn't lead to problems when leaving 4170 scope. 4171 */ 4172 sv = newSVsv(sv); 4173 } 4174 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1) 4175 return Nullsv; 4176 } 4177 else 4178 return Nullsv; 4179 } 4180 if (sv) 4181 SvREADONLY_on(sv); 4182 return sv; 4183 } 4184 4185 void 4186 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) 4187 { 4188 PERL_UNUSED_ARG(floor); 4189 4190 if (o) 4191 SAVEFREEOP(o); 4192 if (proto) 4193 SAVEFREEOP(proto); 4194 if (attrs) 4195 SAVEFREEOP(attrs); 4196 if (block) 4197 SAVEFREEOP(block); 4198 Perl_croak(aTHX_ "\"my sub\" not yet implemented"); 4199 } 4200 4201 CV * 4202 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block) 4203 { 4204 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block); 4205 } 4206 4207 CV * 4208 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) 4209 { 4210 const char *aname; 4211 GV *gv; 4212 const char *ps; 4213 STRLEN ps_len; 4214 register CV *cv=0; 4215 SV *const_sv; 4216 I32 gv_fetch_flags; 4217 4218 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : Nullch; 4219 4220 if (proto) { 4221 assert(proto->op_type == OP_CONST); 4222 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len); 4223 } 4224 else 4225 ps = Nullch; 4226 4227 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) { 4228 SV * const sv = sv_newmortal(); 4229 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]", 4230 PL_curstash ? "__ANON__" : "__ANON__::__ANON__", 4231 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); 4232 aname = SvPVX_const(sv); 4233 } 4234 else 4235 aname = Nullch; 4236 4237 /* There may be future conflict here as change 23766 is not yet merged. */ 4238 gv_fetch_flags = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) 4239 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT; 4240 gv = gv_fetchpv(name ? name : (aname ? aname : 4241 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")), 4242 gv_fetch_flags, SVt_PVCV); 4243 4244 if (o) 4245 SAVEFREEOP(o); 4246 if (proto) 4247 SAVEFREEOP(proto); 4248 if (attrs) 4249 SAVEFREEOP(attrs); 4250 4251 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at 4252 maximum a prototype before. */ 4253 if (SvTYPE(gv) > SVt_NULL) { 4254 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1) 4255 && ckWARN_d(WARN_PROTOTYPE)) 4256 { 4257 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype"); 4258 } 4259 cv_ckproto((CV*)gv, NULL, (char *)ps); 4260 } 4261 if (ps) 4262 sv_setpvn((SV*)gv, ps, ps_len); 4263 else 4264 sv_setiv((SV*)gv, -1); 4265 SvREFCNT_dec(PL_compcv); 4266 cv = PL_compcv = NULL; 4267 PL_sub_generation++; 4268 goto done; 4269 } 4270 4271 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv); 4272 4273 #ifdef GV_UNIQUE_CHECK 4274 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) { 4275 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name); 4276 } 4277 #endif 4278 4279 if (!block || !ps || *ps || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) 4280 const_sv = Nullsv; 4281 else 4282 const_sv = op_const_sv(block, Nullcv); 4283 4284 if (cv) { 4285 const bool exists = CvROOT(cv) || CvXSUB(cv); 4286 4287 #ifdef GV_UNIQUE_CHECK 4288 if (exists && GvUNIQUE(gv)) { 4289 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name); 4290 } 4291 #endif 4292 4293 /* if the subroutine doesn't exist and wasn't pre-declared 4294 * with a prototype, assume it will be AUTOLOADed, 4295 * skipping the prototype check 4296 */ 4297 if (exists || SvPOK(cv)) 4298 cv_ckproto(cv, gv, (char *)ps); 4299 /* already defined (or promised)? */ 4300 if (exists || GvASSUMECV(gv)) { 4301 if (!block && !attrs) { 4302 if (CvFLAGS(PL_compcv)) { 4303 /* might have had built-in attrs applied */ 4304 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS); 4305 } 4306 /* just a "sub foo;" when &foo is already defined */ 4307 SAVEFREESV(PL_compcv); 4308 goto done; 4309 } 4310 /* ahem, death to those who redefine active sort subs */ 4311 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv)) 4312 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name); 4313 if (block) { 4314 if (ckWARN(WARN_REDEFINE) 4315 || (CvCONST(cv) 4316 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv)))) 4317 { 4318 const line_t oldline = CopLINE(PL_curcop); 4319 if (PL_copline != NOLINE) 4320 CopLINE_set(PL_curcop, PL_copline); 4321 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), 4322 CvCONST(cv) ? "Constant subroutine %s redefined" 4323 : "Subroutine %s redefined", name); 4324 CopLINE_set(PL_curcop, oldline); 4325 } 4326 SvREFCNT_dec(cv); 4327 cv = Nullcv; 4328 } 4329 } 4330 } 4331 if (const_sv) { 4332 (void)SvREFCNT_inc(const_sv); 4333 if (cv) { 4334 assert(!CvROOT(cv) && !CvCONST(cv)); 4335 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */ 4336 CvXSUBANY(cv).any_ptr = const_sv; 4337 CvXSUB(cv) = const_sv_xsub; 4338 CvCONST_on(cv); 4339 } 4340 else { 4341 GvCV(gv) = Nullcv; 4342 cv = newCONSTSUB(NULL, (char *)name, const_sv); 4343 } 4344 op_free(block); 4345 SvREFCNT_dec(PL_compcv); 4346 PL_compcv = NULL; 4347 PL_sub_generation++; 4348 goto done; 4349 } 4350 if (attrs) { 4351 HV *stash; 4352 SV *rcv; 4353 4354 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs> 4355 * before we clobber PL_compcv. 4356 */ 4357 if (cv && !block) { 4358 rcv = (SV*)cv; 4359 /* Might have had built-in attributes applied -- propagate them. */ 4360 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS); 4361 if (CvGV(cv) && GvSTASH(CvGV(cv))) 4362 stash = GvSTASH(CvGV(cv)); 4363 else if (CvSTASH(cv)) 4364 stash = CvSTASH(cv); 4365 else 4366 stash = PL_curstash; 4367 } 4368 else { 4369 /* possibly about to re-define existing subr -- ignore old cv */ 4370 rcv = (SV*)PL_compcv; 4371 if (name && GvSTASH(gv)) 4372 stash = GvSTASH(gv); 4373 else 4374 stash = PL_curstash; 4375 } 4376 apply_attrs(stash, rcv, attrs, FALSE); 4377 } 4378 if (cv) { /* must reuse cv if autoloaded */ 4379 if (!block) { 4380 /* got here with just attrs -- work done, so bug out */ 4381 SAVEFREESV(PL_compcv); 4382 goto done; 4383 } 4384 /* transfer PL_compcv to cv */ 4385 cv_undef(cv); 4386 CvFLAGS(cv) = CvFLAGS(PL_compcv); 4387 if (!CvWEAKOUTSIDE(cv)) 4388 SvREFCNT_dec(CvOUTSIDE(cv)); 4389 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv); 4390 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv); 4391 CvOUTSIDE(PL_compcv) = 0; 4392 CvPADLIST(cv) = CvPADLIST(PL_compcv); 4393 CvPADLIST(PL_compcv) = 0; 4394 /* inner references to PL_compcv must be fixed up ... */ 4395 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv); 4396 /* ... before we throw it away */ 4397 SvREFCNT_dec(PL_compcv); 4398 if (PERLDB_INTER)/* Advice debugger on the new sub. */ 4399 ++PL_sub_generation; 4400 } 4401 else { 4402 cv = PL_compcv; 4403 if (name) { 4404 GvCV(gv) = cv; 4405 GvCVGEN(gv) = 0; 4406 PL_sub_generation++; 4407 } 4408 } 4409 CvGV(cv) = gv; 4410 CvFILE_set_from_cop(cv, PL_curcop); 4411 CvSTASH(cv) = PL_curstash; 4412 #ifdef USE_5005THREADS 4413 CvOWNER(cv) = 0; 4414 if (!CvMUTEXP(cv)) { 4415 New(666, CvMUTEXP(cv), 1, perl_mutex); 4416 MUTEX_INIT(CvMUTEXP(cv)); 4417 } 4418 #endif /* USE_5005THREADS */ 4419 4420 if (ps) 4421 sv_setpvn((SV*)cv, ps, ps_len); 4422 4423 if (PL_error_count) { 4424 op_free(block); 4425 block = Nullop; 4426 if (name) { 4427 const char *s = strrchr(name, ':'); 4428 s = s ? s+1 : name; 4429 if (strEQ(s, "BEGIN")) { 4430 const char not_safe[] = 4431 "BEGIN not safe after errors--compilation aborted"; 4432 if (PL_in_eval & EVAL_KEEPERR) 4433 Perl_croak(aTHX_ not_safe); 4434 else { 4435 /* force display of errors found but not reported */ 4436 sv_catpv(ERRSV, not_safe); 4437 Perl_croak(aTHX_ "%"SVf, ERRSV); 4438 } 4439 } 4440 } 4441 } 4442 if (!block) 4443 goto done; 4444 4445 if (CvLVALUE(cv)) { 4446 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0, 4447 mod(scalarseq(block), OP_LEAVESUBLV)); 4448 } 4449 else { 4450 /* This makes sub {}; work as expected. */ 4451 if (block->op_type == OP_STUB) { 4452 op_free(block); 4453 block = newSTATEOP(0, Nullch, 0); 4454 } 4455 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block)); 4456 } 4457 CvROOT(cv)->op_private |= OPpREFCOUNTED; 4458 OpREFCNT_set(CvROOT(cv), 1); 4459 CvSTART(cv) = LINKLIST(CvROOT(cv)); 4460 CvROOT(cv)->op_next = 0; 4461 CALL_PEEP(CvSTART(cv)); 4462 4463 /* now that optimizer has done its work, adjust pad values */ 4464 4465 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB); 4466 4467 if (CvCLONE(cv)) { 4468 assert(!CvCONST(cv)); 4469 if (ps && !*ps && op_const_sv(block, cv)) 4470 CvCONST_on(cv); 4471 } 4472 4473 if (name || aname) { 4474 const char *s; 4475 const char *tname = (name ? name : aname); 4476 4477 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) { 4478 SV *sv = NEWSV(0,0); 4479 SV *tmpstr = sv_newmortal(); 4480 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV); 4481 HV *hv; 4482 4483 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld", 4484 CopFILE(PL_curcop), 4485 (long)PL_subline, (long)CopLINE(PL_curcop)); 4486 gv_efullname3(tmpstr, gv, Nullch); 4487 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0); 4488 hv = GvHVn(db_postponed); 4489 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) { 4490 CV * const pcv = GvCV(db_postponed); 4491 if (pcv) { 4492 dSP; 4493 PUSHMARK(SP); 4494 XPUSHs(tmpstr); 4495 PUTBACK; 4496 call_sv((SV*)pcv, G_DISCARD); 4497 } 4498 } 4499 } 4500 4501 if ((s = strrchr(tname,':'))) 4502 s++; 4503 else 4504 s = tname; 4505 4506 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I') 4507 goto done; 4508 4509 if (strEQ(s, "BEGIN")) { 4510 const I32 oldscope = PL_scopestack_ix; 4511 ENTER; 4512 SAVECOPFILE(&PL_compiling); 4513 SAVECOPLINE(&PL_compiling); 4514 4515 if (!PL_beginav) 4516 PL_beginav = newAV(); 4517 DEBUG_x( dump_sub(gv) ); 4518 av_push(PL_beginav, (SV*)cv); 4519 GvCV(gv) = 0; /* cv has been hijacked */ 4520 call_list(oldscope, PL_beginav); 4521 4522 PL_curcop = &PL_compiling; 4523 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); 4524 LEAVE; 4525 } 4526 else if (strEQ(s, "END") && !PL_error_count) { 4527 if (!PL_endav) 4528 PL_endav = newAV(); 4529 DEBUG_x( dump_sub(gv) ); 4530 av_unshift(PL_endav, 1); 4531 av_store(PL_endav, 0, (SV*)cv); 4532 GvCV(gv) = 0; /* cv has been hijacked */ 4533 } 4534 else if (strEQ(s, "CHECK") && !PL_error_count) { 4535 if (!PL_checkav) 4536 PL_checkav = newAV(); 4537 DEBUG_x( dump_sub(gv) ); 4538 if (PL_main_start && ckWARN(WARN_VOID)) 4539 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block"); 4540 av_unshift(PL_checkav, 1); 4541 av_store(PL_checkav, 0, (SV*)cv); 4542 GvCV(gv) = 0; /* cv has been hijacked */ 4543 } 4544 else if (strEQ(s, "INIT") && !PL_error_count) { 4545 if (!PL_initav) 4546 PL_initav = newAV(); 4547 DEBUG_x( dump_sub(gv) ); 4548 if (PL_main_start && ckWARN(WARN_VOID)) 4549 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block"); 4550 av_push(PL_initav, (SV*)cv); 4551 GvCV(gv) = 0; /* cv has been hijacked */ 4552 } 4553 } 4554 4555 done: 4556 PL_copline = NOLINE; 4557 LEAVE_SCOPE(floor); 4558 return cv; 4559 } 4560 4561 /* XXX unsafe for threads if eval_owner isn't held */ 4562 /* 4563 =for apidoc newCONSTSUB 4564 4565 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is 4566 eligible for inlining at compile-time. 4567 4568 =cut 4569 */ 4570 4571 CV * 4572 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv) 4573 { 4574 CV* cv; 4575 4576 ENTER; 4577 4578 SAVECOPLINE(PL_curcop); 4579 CopLINE_set(PL_curcop, PL_copline); 4580 4581 SAVEHINTS(); 4582 PL_hints &= ~HINT_BLOCK_SCOPE; 4583 4584 if (stash) { 4585 SAVESPTR(PL_curstash); 4586 SAVECOPSTASH(PL_curcop); 4587 PL_curstash = stash; 4588 CopSTASH_set(PL_curcop,stash); 4589 } 4590 4591 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop))); 4592 CvXSUBANY(cv).any_ptr = sv; 4593 CvCONST_on(cv); 4594 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */ 4595 4596 if (stash) 4597 CopSTASH_free(PL_curcop); 4598 4599 LEAVE; 4600 4601 return cv; 4602 } 4603 4604 /* 4605 =for apidoc U||newXS 4606 4607 Used by C<xsubpp> to hook up XSUBs as Perl subs. 4608 4609 =cut 4610 */ 4611 4612 CV * 4613 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename) 4614 { 4615 GV * const gv = gv_fetchpv(name ? name : 4616 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"), 4617 GV_ADDMULTI, SVt_PVCV); 4618 register CV *cv; 4619 4620 if ((cv = (name ? GvCV(gv) : Nullcv))) { 4621 if (GvCVGEN(gv)) { 4622 /* just a cached method */ 4623 SvREFCNT_dec(cv); 4624 cv = Nullcv; 4625 } 4626 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) { 4627 /* already defined (or promised) */ 4628 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */ 4629 if (ckWARN(WARN_REDEFINE)) { 4630 GV * const gvcv = CvGV(cv); 4631 if (gvcv) { 4632 HV * const stash = GvSTASH(gvcv); 4633 if (stash) { 4634 const char *name = HvNAME_get(stash); 4635 if ( strEQ(name,"autouse") ) { 4636 const line_t oldline = CopLINE(PL_curcop); 4637 if (PL_copline != NOLINE) 4638 CopLINE_set(PL_curcop, PL_copline); 4639 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), 4640 CvCONST(cv) ? "Constant subroutine %s redefined" 4641 : "Subroutine %s redefined" 4642 ,name); 4643 CopLINE_set(PL_curcop, oldline); 4644 } 4645 } 4646 } 4647 } 4648 SvREFCNT_dec(cv); 4649 cv = Nullcv; 4650 } 4651 } 4652 4653 if (cv) /* must reuse cv if autoloaded */ 4654 cv_undef(cv); 4655 else { 4656 cv = (CV*)NEWSV(1105,0); 4657 sv_upgrade((SV *)cv, SVt_PVCV); 4658 if (name) { 4659 GvCV(gv) = cv; 4660 GvCVGEN(gv) = 0; 4661 PL_sub_generation++; 4662 } 4663 } 4664 CvGV(cv) = gv; 4665 #ifdef USE_5005THREADS 4666 New(666, CvMUTEXP(cv), 1, perl_mutex); 4667 MUTEX_INIT(CvMUTEXP(cv)); 4668 CvOWNER(cv) = 0; 4669 #endif /* USE_5005THREADS */ 4670 (void)gv_fetchfile(filename); 4671 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be 4672 an external constant string */ 4673 CvXSUB(cv) = subaddr; 4674 4675 if (name) { 4676 const char *s = strrchr(name,':'); 4677 if (s) 4678 s++; 4679 else 4680 s = name; 4681 4682 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I') 4683 goto done; 4684 4685 if (strEQ(s, "BEGIN")) { 4686 if (!PL_beginav) 4687 PL_beginav = newAV(); 4688 av_push(PL_beginav, (SV*)cv); 4689 GvCV(gv) = 0; /* cv has been hijacked */ 4690 } 4691 else if (strEQ(s, "END")) { 4692 if (!PL_endav) 4693 PL_endav = newAV(); 4694 av_unshift(PL_endav, 1); 4695 av_store(PL_endav, 0, (SV*)cv); 4696 GvCV(gv) = 0; /* cv has been hijacked */ 4697 } 4698 else if (strEQ(s, "CHECK")) { 4699 if (!PL_checkav) 4700 PL_checkav = newAV(); 4701 if (PL_main_start && ckWARN(WARN_VOID)) 4702 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block"); 4703 av_unshift(PL_checkav, 1); 4704 av_store(PL_checkav, 0, (SV*)cv); 4705 GvCV(gv) = 0; /* cv has been hijacked */ 4706 } 4707 else if (strEQ(s, "INIT")) { 4708 if (!PL_initav) 4709 PL_initav = newAV(); 4710 if (PL_main_start && ckWARN(WARN_VOID)) 4711 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block"); 4712 av_push(PL_initav, (SV*)cv); 4713 GvCV(gv) = 0; /* cv has been hijacked */ 4714 } 4715 } 4716 else 4717 CvANON_on(cv); 4718 4719 done: 4720 return cv; 4721 } 4722 4723 void 4724 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) 4725 { 4726 register CV *cv; 4727 char *name; 4728 GV *gv; 4729 STRLEN n_a; 4730 4731 if (o) 4732 name = SvPVx(cSVOPo->op_sv, n_a); 4733 else 4734 name = "STDOUT"; 4735 gv = gv_fetchpv(name,TRUE, SVt_PVFM); 4736 #ifdef GV_UNIQUE_CHECK 4737 if (GvUNIQUE(gv)) { 4738 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)"); 4739 } 4740 #endif 4741 GvMULTI_on(gv); 4742 if ((cv = GvFORM(gv))) { 4743 if (ckWARN(WARN_REDEFINE)) { 4744 const line_t oldline = CopLINE(PL_curcop); 4745 if (PL_copline != NOLINE) 4746 CopLINE_set(PL_curcop, PL_copline); 4747 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name); 4748 CopLINE_set(PL_curcop, oldline); 4749 } 4750 SvREFCNT_dec(cv); 4751 } 4752 cv = PL_compcv; 4753 GvFORM(gv) = cv; 4754 CvGV(cv) = gv; 4755 CvFILE_set_from_cop(cv, PL_curcop); 4756 4757 4758 pad_tidy(padtidy_FORMAT); 4759 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block)); 4760 CvROOT(cv)->op_private |= OPpREFCOUNTED; 4761 OpREFCNT_set(CvROOT(cv), 1); 4762 CvSTART(cv) = LINKLIST(CvROOT(cv)); 4763 CvROOT(cv)->op_next = 0; 4764 CALL_PEEP(CvSTART(cv)); 4765 op_free(o); 4766 PL_copline = NOLINE; 4767 LEAVE_SCOPE(floor); 4768 } 4769 4770 OP * 4771 Perl_newANONLIST(pTHX_ OP *o) 4772 { 4773 return newUNOP(OP_REFGEN, 0, 4774 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN)); 4775 } 4776 4777 OP * 4778 Perl_newANONHASH(pTHX_ OP *o) 4779 { 4780 return newUNOP(OP_REFGEN, 0, 4781 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN)); 4782 } 4783 4784 OP * 4785 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block) 4786 { 4787 return newANONATTRSUB(floor, proto, Nullop, block); 4788 } 4789 4790 OP * 4791 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block) 4792 { 4793 return newUNOP(OP_REFGEN, 0, 4794 newSVOP(OP_ANONCODE, 0, 4795 (SV*)newATTRSUB(floor, 0, proto, attrs, block))); 4796 } 4797 4798 OP * 4799 Perl_oopsAV(pTHX_ OP *o) 4800 { 4801 switch (o->op_type) { 4802 case OP_PADSV: 4803 o->op_type = OP_PADAV; 4804 o->op_ppaddr = PL_ppaddr[OP_PADAV]; 4805 return ref(o, OP_RV2AV); 4806 4807 case OP_RV2SV: 4808 o->op_type = OP_RV2AV; 4809 o->op_ppaddr = PL_ppaddr[OP_RV2AV]; 4810 ref(o, OP_RV2AV); 4811 break; 4812 4813 default: 4814 if (ckWARN_d(WARN_INTERNAL)) 4815 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV"); 4816 break; 4817 } 4818 return o; 4819 } 4820 4821 OP * 4822 Perl_oopsHV(pTHX_ OP *o) 4823 { 4824 switch (o->op_type) { 4825 case OP_PADSV: 4826 case OP_PADAV: 4827 o->op_type = OP_PADHV; 4828 o->op_ppaddr = PL_ppaddr[OP_PADHV]; 4829 return ref(o, OP_RV2HV); 4830 4831 case OP_RV2SV: 4832 case OP_RV2AV: 4833 o->op_type = OP_RV2HV; 4834 o->op_ppaddr = PL_ppaddr[OP_RV2HV]; 4835 ref(o, OP_RV2HV); 4836 break; 4837 4838 default: 4839 if (ckWARN_d(WARN_INTERNAL)) 4840 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV"); 4841 break; 4842 } 4843 return o; 4844 } 4845 4846 OP * 4847 Perl_newAVREF(pTHX_ OP *o) 4848 { 4849 if (o->op_type == OP_PADANY) { 4850 o->op_type = OP_PADAV; 4851 o->op_ppaddr = PL_ppaddr[OP_PADAV]; 4852 return o; 4853 } 4854 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV) 4855 && ckWARN(WARN_DEPRECATED)) { 4856 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), 4857 "Using an array as a reference is deprecated"); 4858 } 4859 return newUNOP(OP_RV2AV, 0, scalar(o)); 4860 } 4861 4862 OP * 4863 Perl_newGVREF(pTHX_ I32 type, OP *o) 4864 { 4865 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT) 4866 return newUNOP(OP_NULL, 0, o); 4867 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type); 4868 } 4869 4870 OP * 4871 Perl_newHVREF(pTHX_ OP *o) 4872 { 4873 if (o->op_type == OP_PADANY) { 4874 o->op_type = OP_PADHV; 4875 o->op_ppaddr = PL_ppaddr[OP_PADHV]; 4876 return o; 4877 } 4878 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV) 4879 && ckWARN(WARN_DEPRECATED)) { 4880 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), 4881 "Using a hash as a reference is deprecated"); 4882 } 4883 return newUNOP(OP_RV2HV, 0, scalar(o)); 4884 } 4885 4886 OP * 4887 Perl_oopsCV(pTHX_ OP *o) 4888 { 4889 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__); 4890 /* STUB */ 4891 PERL_UNUSED_ARG(o); 4892 NORETURN_FUNCTION_END; 4893 } 4894 4895 OP * 4896 Perl_newCVREF(pTHX_ I32 flags, OP *o) 4897 { 4898 return newUNOP(OP_RV2CV, flags, scalar(o)); 4899 } 4900 4901 OP * 4902 Perl_newSVREF(pTHX_ OP *o) 4903 { 4904 if (o->op_type == OP_PADANY) { 4905 o->op_type = OP_PADSV; 4906 o->op_ppaddr = PL_ppaddr[OP_PADSV]; 4907 return o; 4908 } 4909 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) { 4910 o->op_flags |= OPpDONE_SVREF; 4911 return o; 4912 } 4913 return newUNOP(OP_RV2SV, 0, scalar(o)); 4914 } 4915 4916 /* Check routines. See the comments at the top of this file for details 4917 * on when these are called */ 4918 4919 OP * 4920 Perl_ck_anoncode(pTHX_ OP *o) 4921 { 4922 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type); 4923 cSVOPo->op_sv = Nullsv; 4924 return o; 4925 } 4926 4927 OP * 4928 Perl_ck_bitop(pTHX_ OP *o) 4929 { 4930 #define OP_IS_NUMCOMPARE(op) \ 4931 ((op) == OP_LT || (op) == OP_I_LT || \ 4932 (op) == OP_GT || (op) == OP_I_GT || \ 4933 (op) == OP_LE || (op) == OP_I_LE || \ 4934 (op) == OP_GE || (op) == OP_I_GE || \ 4935 (op) == OP_EQ || (op) == OP_I_EQ || \ 4936 (op) == OP_NE || (op) == OP_I_NE || \ 4937 (op) == OP_NCMP || (op) == OP_I_NCMP) 4938 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); 4939 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */ 4940 && (o->op_type == OP_BIT_OR 4941 || o->op_type == OP_BIT_AND 4942 || o->op_type == OP_BIT_XOR)) 4943 { 4944 const OP * const left = cBINOPo->op_first; 4945 const OP * const right = left->op_sibling; 4946 if ((OP_IS_NUMCOMPARE(left->op_type) && 4947 (left->op_flags & OPf_PARENS) == 0) || 4948 (OP_IS_NUMCOMPARE(right->op_type) && 4949 (right->op_flags & OPf_PARENS) == 0)) 4950 if (ckWARN(WARN_PRECEDENCE)) 4951 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE), 4952 "Possible precedence problem on bitwise %c operator", 4953 o->op_type == OP_BIT_OR ? '|' 4954 : o->op_type == OP_BIT_AND ? '&' : '^' 4955 ); 4956 } 4957 return o; 4958 } 4959 4960 OP * 4961 Perl_ck_concat(pTHX_ OP *o) 4962 { 4963 const OP *kid = cUNOPo->op_first; 4964 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) && 4965 !(kUNOP->op_first->op_flags & OPf_MOD)) 4966 o->op_flags |= OPf_STACKED; 4967 return o; 4968 } 4969 4970 OP * 4971 Perl_ck_spair(pTHX_ OP *o) 4972 { 4973 if (o->op_flags & OPf_KIDS) { 4974 OP* newop; 4975 OP* kid; 4976 const OPCODE type = o->op_type; 4977 o = modkids(ck_fun(o), type); 4978 kid = cUNOPo->op_first; 4979 newop = kUNOP->op_first->op_sibling; 4980 if (newop && 4981 (newop->op_sibling || 4982 !(PL_opargs[newop->op_type] & OA_RETSCALAR) || 4983 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV || 4984 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) { 4985 4986 return o; 4987 } 4988 op_free(kUNOP->op_first); 4989 kUNOP->op_first = newop; 4990 } 4991 o->op_ppaddr = PL_ppaddr[++o->op_type]; 4992 return ck_fun(o); 4993 } 4994 4995 OP * 4996 Perl_ck_delete(pTHX_ OP *o) 4997 { 4998 o = ck_fun(o); 4999 o->op_private = 0; 5000 if (o->op_flags & OPf_KIDS) { 5001 OP * const kid = cUNOPo->op_first; 5002 switch (kid->op_type) { 5003 case OP_ASLICE: 5004 o->op_flags |= OPf_SPECIAL; 5005 /* FALL THROUGH */ 5006 case OP_HSLICE: 5007 o->op_private |= OPpSLICE; 5008 break; 5009 case OP_AELEM: 5010 o->op_flags |= OPf_SPECIAL; 5011 /* FALL THROUGH */ 5012 case OP_HELEM: 5013 break; 5014 default: 5015 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice", 5016 OP_DESC(o)); 5017 } 5018 op_null(kid); 5019 } 5020 return o; 5021 } 5022 5023 OP * 5024 Perl_ck_die(pTHX_ OP *o) 5025 { 5026 #ifdef VMS 5027 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH; 5028 #endif 5029 return ck_fun(o); 5030 } 5031 5032 OP * 5033 Perl_ck_eof(pTHX_ OP *o) 5034 { 5035 const I32 type = o->op_type; 5036 5037 if (o->op_flags & OPf_KIDS) { 5038 if (cLISTOPo->op_first->op_type == OP_STUB) { 5039 op_free(o); 5040 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv)); 5041 } 5042 return ck_fun(o); 5043 } 5044 return o; 5045 } 5046 5047 OP * 5048 Perl_ck_eval(pTHX_ OP *o) 5049 { 5050 PL_hints |= HINT_BLOCK_SCOPE; 5051 if (o->op_flags & OPf_KIDS) { 5052 SVOP * const kid = (SVOP*)cUNOPo->op_first; 5053 5054 if (!kid) { 5055 o->op_flags &= ~OPf_KIDS; 5056 op_null(o); 5057 } 5058 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) { 5059 LOGOP *enter; 5060 5061 cUNOPo->op_first = 0; 5062 op_free(o); 5063 5064 NewOp(1101, enter, 1, LOGOP); 5065 enter->op_type = OP_ENTERTRY; 5066 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY]; 5067 enter->op_private = 0; 5068 5069 /* establish postfix order */ 5070 enter->op_next = (OP*)enter; 5071 5072 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid); 5073 o->op_type = OP_LEAVETRY; 5074 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY]; 5075 enter->op_other = o; 5076 return o; 5077 } 5078 else 5079 scalar((OP*)kid); 5080 } 5081 else { 5082 op_free(o); 5083 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP()); 5084 } 5085 o->op_targ = (PADOFFSET)PL_hints; 5086 return o; 5087 } 5088 5089 OP * 5090 Perl_ck_exit(pTHX_ OP *o) 5091 { 5092 #ifdef VMS 5093 HV * const table = GvHV(PL_hintgv); 5094 if (table) { 5095 SV * const * const svp = hv_fetch(table, "vmsish_exit", 11, FALSE); 5096 if (svp && *svp && SvTRUE(*svp)) 5097 o->op_private |= OPpEXIT_VMSISH; 5098 } 5099 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH; 5100 #endif 5101 return ck_fun(o); 5102 } 5103 5104 OP * 5105 Perl_ck_exec(pTHX_ OP *o) 5106 { 5107 if (o->op_flags & OPf_STACKED) { 5108 OP *kid; 5109 o = ck_fun(o); 5110 kid = cUNOPo->op_first->op_sibling; 5111 if (kid->op_type == OP_RV2GV) 5112 op_null(kid); 5113 } 5114 else 5115 o = listkids(o); 5116 return o; 5117 } 5118 5119 OP * 5120 Perl_ck_exists(pTHX_ OP *o) 5121 { 5122 o = ck_fun(o); 5123 if (o->op_flags & OPf_KIDS) { 5124 OP * const kid = cUNOPo->op_first; 5125 if (kid->op_type == OP_ENTERSUB) { 5126 (void) ref(kid, o->op_type); 5127 if (kid->op_type != OP_RV2CV && !PL_error_count) 5128 Perl_croak(aTHX_ "%s argument is not a subroutine name", 5129 OP_DESC(o)); 5130 o->op_private |= OPpEXISTS_SUB; 5131 } 5132 else if (kid->op_type == OP_AELEM) 5133 o->op_flags |= OPf_SPECIAL; 5134 else if (kid->op_type != OP_HELEM) 5135 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element", 5136 OP_DESC(o)); 5137 op_null(kid); 5138 } 5139 return o; 5140 } 5141 5142 OP * 5143 Perl_ck_rvconst(pTHX_ register OP *o) 5144 { 5145 SVOP *kid = (SVOP*)cUNOPo->op_first; 5146 5147 o->op_private |= (PL_hints & HINT_STRICT_REFS); 5148 if (kid->op_type == OP_CONST) { 5149 char *name; 5150 int iscv; 5151 GV *gv; 5152 SV * const kidsv = kid->op_sv; 5153 STRLEN n_a; 5154 5155 /* Is it a constant from cv_const_sv()? */ 5156 if (SvROK(kidsv) && SvREADONLY(kidsv)) { 5157 SV *rsv = SvRV(kidsv); 5158 const int svtype = SvTYPE(rsv); 5159 const char *badtype = Nullch; 5160 5161 switch (o->op_type) { 5162 case OP_RV2SV: 5163 if (svtype > SVt_PVMG) 5164 badtype = "a SCALAR"; 5165 break; 5166 case OP_RV2AV: 5167 if (svtype != SVt_PVAV) 5168 badtype = "an ARRAY"; 5169 break; 5170 case OP_RV2HV: 5171 if (svtype != SVt_PVHV) { 5172 if (svtype == SVt_PVAV) { /* pseudohash? */ 5173 SV **ksv = av_fetch((AV*)rsv, 0, FALSE); 5174 if (ksv && SvROK(*ksv) 5175 && SvTYPE(SvRV(*ksv)) == SVt_PVHV) 5176 { 5177 break; 5178 } 5179 } 5180 badtype = "a HASH"; 5181 } 5182 break; 5183 case OP_RV2CV: 5184 if (svtype != SVt_PVCV) 5185 badtype = "a CODE"; 5186 break; 5187 } 5188 if (badtype) 5189 Perl_croak(aTHX_ "Constant is not %s reference", badtype); 5190 return o; 5191 } 5192 name = SvPV(kidsv, n_a); 5193 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) { 5194 const char *badthing = Nullch; 5195 switch (o->op_type) { 5196 case OP_RV2SV: 5197 badthing = "a SCALAR"; 5198 break; 5199 case OP_RV2AV: 5200 badthing = "an ARRAY"; 5201 break; 5202 case OP_RV2HV: 5203 badthing = "a HASH"; 5204 break; 5205 } 5206 if (badthing) 5207 Perl_croak(aTHX_ 5208 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use", 5209 name, badthing); 5210 } 5211 /* 5212 * This is a little tricky. We only want to add the symbol if we 5213 * didn't add it in the lexer. Otherwise we get duplicate strict 5214 * warnings. But if we didn't add it in the lexer, we must at 5215 * least pretend like we wanted to add it even if it existed before, 5216 * or we get possible typo warnings. OPpCONST_ENTERED says 5217 * whether the lexer already added THIS instance of this symbol. 5218 */ 5219 iscv = (o->op_type == OP_RV2CV) * 2; 5220 do { 5221 gv = gv_fetchpv(name, 5222 iscv | !(kid->op_private & OPpCONST_ENTERED), 5223 iscv 5224 ? SVt_PVCV 5225 : o->op_type == OP_RV2SV 5226 ? SVt_PV 5227 : o->op_type == OP_RV2AV 5228 ? SVt_PVAV 5229 : o->op_type == OP_RV2HV 5230 ? SVt_PVHV 5231 : SVt_PVGV); 5232 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++); 5233 if (gv) { 5234 kid->op_type = OP_GV; 5235 SvREFCNT_dec(kid->op_sv); 5236 #ifdef USE_ITHREADS 5237 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */ 5238 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP); 5239 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix)); 5240 GvIN_PAD_on(gv); 5241 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv)); 5242 #else 5243 kid->op_sv = SvREFCNT_inc(gv); 5244 #endif 5245 kid->op_private = 0; 5246 kid->op_ppaddr = PL_ppaddr[OP_GV]; 5247 } 5248 } 5249 return o; 5250 } 5251 5252 OP * 5253 Perl_ck_ftst(pTHX_ OP *o) 5254 { 5255 const I32 type = o->op_type; 5256 5257 if (o->op_flags & OPf_REF) { 5258 /* nothing */ 5259 } 5260 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) { 5261 SVOP * const kid = (SVOP*)cUNOPo->op_first; 5262 5263 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { 5264 STRLEN n_a; 5265 OP * const newop = newGVOP(type, OPf_REF, 5266 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO)); 5267 op_free(o); 5268 o = newop; 5269 } 5270 else { 5271 if ((PL_hints & HINT_FILETEST_ACCESS) && 5272 OP_IS_FILETEST_ACCESS(o)) 5273 o->op_private |= OPpFT_ACCESS; 5274 } 5275 } 5276 else { 5277 op_free(o); 5278 if (type == OP_FTTTY) 5279 o = newGVOP(type, OPf_REF, PL_stdingv); 5280 else 5281 o = newUNOP(type, 0, newDEFSVOP()); 5282 } 5283 return o; 5284 } 5285 5286 OP * 5287 Perl_ck_fun(pTHX_ OP *o) 5288 { 5289 const int type = o->op_type; 5290 register I32 oa = PL_opargs[type] >> OASHIFT; 5291 5292 if (o->op_flags & OPf_STACKED) { 5293 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL)) 5294 oa &= ~OA_OPTIONAL; 5295 else 5296 return no_fh_allowed(o); 5297 } 5298 5299 if (o->op_flags & OPf_KIDS) { 5300 STRLEN n_a; 5301 OP **tokid = &cLISTOPo->op_first; 5302 register OP *kid = cLISTOPo->op_first; 5303 OP *sibl; 5304 I32 numargs = 0; 5305 5306 if (kid->op_type == OP_PUSHMARK || 5307 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK)) 5308 { 5309 tokid = &kid->op_sibling; 5310 kid = kid->op_sibling; 5311 } 5312 if (!kid && PL_opargs[type] & OA_DEFGV) 5313 *tokid = kid = newDEFSVOP(); 5314 5315 while (oa && kid) { 5316 numargs++; 5317 sibl = kid->op_sibling; 5318 switch (oa & 7) { 5319 case OA_SCALAR: 5320 /* list seen where single (scalar) arg expected? */ 5321 if (numargs == 1 && !(oa >> 4) 5322 && kid->op_type == OP_LIST && type != OP_SCALAR) 5323 { 5324 return too_many_arguments(o,PL_op_desc[type]); 5325 } 5326 scalar(kid); 5327 break; 5328 case OA_LIST: 5329 if (oa < 16) { 5330 kid = 0; 5331 continue; 5332 } 5333 else 5334 list(kid); 5335 break; 5336 case OA_AVREF: 5337 if ((type == OP_PUSH || type == OP_UNSHIFT) 5338 && !kid->op_sibling && ckWARN(WARN_SYNTAX)) 5339 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 5340 "Useless use of %s with no values", 5341 PL_op_desc[type]); 5342 5343 if (kid->op_type == OP_CONST && 5344 (kid->op_private & OPpCONST_BARE)) 5345 { 5346 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a); 5347 OP * const newop = newAVREF(newGVOP(OP_GV, 0, 5348 gv_fetchpv(name, TRUE, SVt_PVAV) )); 5349 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) 5350 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), 5351 "Array @%s missing the @ in argument %"IVdf" of %s()", 5352 name, (IV)numargs, PL_op_desc[type]); 5353 op_free(kid); 5354 kid = newop; 5355 kid->op_sibling = sibl; 5356 *tokid = kid; 5357 } 5358 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) 5359 bad_type(numargs, "array", PL_op_desc[type], kid); 5360 mod(kid, type); 5361 break; 5362 case OA_HVREF: 5363 if (kid->op_type == OP_CONST && 5364 (kid->op_private & OPpCONST_BARE)) 5365 { 5366 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a); 5367 OP * const newop = newHVREF(newGVOP(OP_GV, 0, 5368 gv_fetchpv(name, TRUE, SVt_PVHV) )); 5369 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) 5370 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), 5371 "Hash %%%s missing the %% in argument %"IVdf" of %s()", 5372 name, (IV)numargs, PL_op_desc[type]); 5373 op_free(kid); 5374 kid = newop; 5375 kid->op_sibling = sibl; 5376 *tokid = kid; 5377 } 5378 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV) 5379 bad_type(numargs, "hash", PL_op_desc[type], kid); 5380 mod(kid, type); 5381 break; 5382 case OA_CVREF: 5383 { 5384 OP * const newop = newUNOP(OP_NULL, 0, kid); 5385 kid->op_sibling = 0; 5386 linklist(kid); 5387 newop->op_next = newop; 5388 kid = newop; 5389 kid->op_sibling = sibl; 5390 *tokid = kid; 5391 } 5392 break; 5393 case OA_FILEREF: 5394 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) { 5395 if (kid->op_type == OP_CONST && 5396 (kid->op_private & OPpCONST_BARE)) 5397 { 5398 OP *newop = newGVOP(OP_GV, 0, 5399 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE, 5400 SVt_PVIO) ); 5401 if (!(o->op_private & 1) && /* if not unop */ 5402 kid == cLISTOPo->op_last) 5403 cLISTOPo->op_last = newop; 5404 op_free(kid); 5405 kid = newop; 5406 } 5407 else if (kid->op_type == OP_READLINE) { 5408 /* neophyte patrol: open(<FH>), close(<FH>) etc. */ 5409 bad_type(numargs, "HANDLE", OP_DESC(o), kid); 5410 } 5411 else { 5412 I32 flags = OPf_SPECIAL; 5413 I32 priv = 0; 5414 PADOFFSET targ = 0; 5415 5416 /* is this op a FH constructor? */ 5417 if (is_handle_constructor(o,numargs)) { 5418 const char *name = Nullch; 5419 STRLEN len = 0; 5420 5421 flags = 0; 5422 /* Set a flag to tell rv2gv to vivify 5423 * need to "prove" flag does not mean something 5424 * else already - NI-S 1999/05/07 5425 */ 5426 priv = OPpDEREF; 5427 if (kid->op_type == OP_PADSV) { 5428 /*XXX DAPM 2002.08.25 tmp assert test */ 5429 /*XXX*/ assert(av_fetch(PL_comppad_name, (kid->op_targ), FALSE)); 5430 /*XXX*/ assert(*av_fetch(PL_comppad_name, (kid->op_targ), FALSE)); 5431 5432 name = PAD_COMPNAME_PV(kid->op_targ); 5433 /* SvCUR of a pad namesv can't be trusted 5434 * (see PL_generation), so calc its length 5435 * manually */ 5436 if (name) 5437 len = strlen(name); 5438 5439 } 5440 else if (kid->op_type == OP_RV2SV 5441 && kUNOP->op_first->op_type == OP_GV) 5442 { 5443 GV *gv = cGVOPx_gv(kUNOP->op_first); 5444 name = GvNAME(gv); 5445 len = GvNAMELEN(gv); 5446 } 5447 else if (kid->op_type == OP_AELEM 5448 || kid->op_type == OP_HELEM) 5449 { 5450 OP *op = ((BINOP*)kid)->op_first; 5451 name = 0; 5452 if (op) { 5453 SV *tmpstr = Nullsv; 5454 const char * const a = 5455 kid->op_type == OP_AELEM ? 5456 "[]" : "{}"; 5457 if (((op->op_type == OP_RV2AV) || 5458 (op->op_type == OP_RV2HV)) && 5459 (op = ((UNOP*)op)->op_first) && 5460 (op->op_type == OP_GV)) { 5461 /* packagevar $a[] or $h{} */ 5462 GV * const gv = cGVOPx_gv(op); 5463 if (gv) 5464 tmpstr = 5465 Perl_newSVpvf(aTHX_ 5466 "%s%c...%c", 5467 GvNAME(gv), 5468 a[0], a[1]); 5469 } 5470 else if (op->op_type == OP_PADAV 5471 || op->op_type == OP_PADHV) { 5472 /* lexicalvar $a[] or $h{} */ 5473 const char * const padname = 5474 PAD_COMPNAME_PV(op->op_targ); 5475 if (padname) 5476 tmpstr = 5477 Perl_newSVpvf(aTHX_ 5478 "%s%c...%c", 5479 padname + 1, 5480 a[0], a[1]); 5481 } 5482 if (tmpstr) { 5483 name = SvPV_const(tmpstr, len); 5484 sv_2mortal(tmpstr); 5485 } 5486 } 5487 if (!name) { 5488 name = "__ANONIO__"; 5489 len = 10; 5490 } 5491 mod(kid, type); 5492 } 5493 if (name) { 5494 SV *namesv; 5495 targ = pad_alloc(OP_RV2GV, SVs_PADTMP); 5496 namesv = PAD_SVl(targ); 5497 (void)SvUPGRADE(namesv, SVt_PV); 5498 if (*name != '$') 5499 sv_setpvn(namesv, "$", 1); 5500 sv_catpvn(namesv, name, len); 5501 } 5502 } 5503 kid->op_sibling = 0; 5504 kid = newUNOP(OP_RV2GV, flags, scalar(kid)); 5505 kid->op_targ = targ; 5506 kid->op_private |= priv; 5507 } 5508 kid->op_sibling = sibl; 5509 *tokid = kid; 5510 } 5511 scalar(kid); 5512 break; 5513 case OA_SCALARREF: 5514 mod(scalar(kid), type); 5515 break; 5516 } 5517 oa >>= 4; 5518 tokid = &kid->op_sibling; 5519 kid = kid->op_sibling; 5520 } 5521 o->op_private |= numargs; 5522 if (kid) 5523 return too_many_arguments(o,OP_DESC(o)); 5524 listkids(o); 5525 } 5526 else if (PL_opargs[type] & OA_DEFGV) { 5527 op_free(o); 5528 return newUNOP(type, 0, newDEFSVOP()); 5529 } 5530 5531 if (oa) { 5532 while (oa & OA_OPTIONAL) 5533 oa >>= 4; 5534 if (oa && oa != OA_LIST) 5535 return too_few_arguments(o,OP_DESC(o)); 5536 } 5537 return o; 5538 } 5539 5540 OP * 5541 Perl_ck_glob(pTHX_ OP *o) 5542 { 5543 GV *gv; 5544 5545 o = ck_fun(o); 5546 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling) 5547 append_elem(OP_GLOB, o, newDEFSVOP()); 5548 5549 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) 5550 && GvCVu(gv) && GvIMPORTED_CV(gv))) 5551 { 5552 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV); 5553 } 5554 5555 #if !defined(PERL_EXTERNAL_GLOB) 5556 /* XXX this can be tightened up and made more failsafe. */ 5557 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) { 5558 GV *glob_gv; 5559 ENTER; 5560 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, 5561 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv); 5562 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV); 5563 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV); 5564 GvCV(gv) = GvCV(glob_gv); 5565 (void)SvREFCNT_inc((SV*)GvCV(gv)); 5566 GvIMPORTED_CV_on(gv); 5567 LEAVE; 5568 } 5569 #endif /* PERL_EXTERNAL_GLOB */ 5570 5571 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) { 5572 append_elem(OP_GLOB, o, 5573 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++))); 5574 o->op_type = OP_LIST; 5575 o->op_ppaddr = PL_ppaddr[OP_LIST]; 5576 cLISTOPo->op_first->op_type = OP_PUSHMARK; 5577 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK]; 5578 cLISTOPo->op_first->op_targ = 0; 5579 o = newUNOP(OP_ENTERSUB, OPf_STACKED, 5580 append_elem(OP_LIST, o, 5581 scalar(newUNOP(OP_RV2CV, 0, 5582 newGVOP(OP_GV, 0, gv))))); 5583 o = newUNOP(OP_NULL, 0, ck_subr(o)); 5584 o->op_targ = OP_GLOB; /* hint at what it used to be */ 5585 return o; 5586 } 5587 gv = newGVgen("main"); 5588 gv_IOadd(gv); 5589 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv)); 5590 scalarkids(o); 5591 return o; 5592 } 5593 5594 OP * 5595 Perl_ck_grep(pTHX_ OP *o) 5596 { 5597 LOGOP *gwop; 5598 OP *kid; 5599 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE; 5600 5601 o->op_ppaddr = PL_ppaddr[OP_GREPSTART]; 5602 NewOp(1101, gwop, 1, LOGOP); 5603 5604 if (o->op_flags & OPf_STACKED) { 5605 OP* k; 5606 o = ck_sort(o); 5607 kid = cLISTOPo->op_first->op_sibling; 5608 if (!cUNOPx(kid)->op_next) 5609 Perl_croak(aTHX_ "panic: ck_grep"); 5610 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) { 5611 kid = k; 5612 } 5613 kid->op_next = (OP*)gwop; 5614 o->op_flags &= ~OPf_STACKED; 5615 } 5616 kid = cLISTOPo->op_first->op_sibling; 5617 if (type == OP_MAPWHILE) 5618 list(kid); 5619 else 5620 scalar(kid); 5621 o = ck_fun(o); 5622 if (PL_error_count) 5623 return o; 5624 kid = cLISTOPo->op_first->op_sibling; 5625 if (kid->op_type != OP_NULL) 5626 Perl_croak(aTHX_ "panic: ck_grep"); 5627 kid = kUNOP->op_first; 5628 5629 gwop->op_type = type; 5630 gwop->op_ppaddr = PL_ppaddr[type]; 5631 gwop->op_first = listkids(o); 5632 gwop->op_flags |= OPf_KIDS; 5633 gwop->op_private = 1; 5634 gwop->op_other = LINKLIST(kid); 5635 gwop->op_targ = pad_alloc(type, SVs_PADTMP); 5636 kid->op_next = (OP*)gwop; 5637 5638 kid = cLISTOPo->op_first->op_sibling; 5639 if (!kid || !kid->op_sibling) 5640 return too_few_arguments(o,OP_DESC(o)); 5641 for (kid = kid->op_sibling; kid; kid = kid->op_sibling) 5642 mod(kid, OP_GREPSTART); 5643 5644 return (OP*)gwop; 5645 } 5646 5647 OP * 5648 Perl_ck_index(pTHX_ OP *o) 5649 { 5650 if (o->op_flags & OPf_KIDS) { 5651 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ 5652 if (kid) 5653 kid = kid->op_sibling; /* get past "big" */ 5654 if (kid && kid->op_type == OP_CONST) 5655 fbm_compile(((SVOP*)kid)->op_sv, 0); 5656 } 5657 return ck_fun(o); 5658 } 5659 5660 OP * 5661 Perl_ck_lengthconst(pTHX_ OP *o) 5662 { 5663 /* XXX length optimization goes here */ 5664 return ck_fun(o); 5665 } 5666 5667 OP * 5668 Perl_ck_lfun(pTHX_ OP *o) 5669 { 5670 const OPCODE type = o->op_type; 5671 return modkids(ck_fun(o), type); 5672 } 5673 5674 OP * 5675 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ 5676 { 5677 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) { 5678 switch (cUNOPo->op_first->op_type) { 5679 case OP_RV2AV: 5680 /* This is needed for 5681 if (defined %stash::) 5682 to work. Do not break Tk. 5683 */ 5684 break; /* Globals via GV can be undef */ 5685 case OP_PADAV: 5686 case OP_AASSIGN: /* Is this a good idea? */ 5687 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), 5688 "defined(@array) is deprecated"); 5689 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), 5690 "\t(Maybe you should just omit the defined()?)\n"); 5691 break; 5692 case OP_RV2HV: 5693 /* This is needed for 5694 if (defined %stash::) 5695 to work. Do not break Tk. 5696 */ 5697 break; /* Globals via GV can be undef */ 5698 case OP_PADHV: 5699 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), 5700 "defined(%%hash) is deprecated"); 5701 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), 5702 "\t(Maybe you should just omit the defined()?)\n"); 5703 break; 5704 default: 5705 /* no warning */ 5706 break; 5707 } 5708 } 5709 return ck_rfun(o); 5710 } 5711 5712 OP * 5713 Perl_ck_rfun(pTHX_ OP *o) 5714 { 5715 const OPCODE type = o->op_type; 5716 return refkids(ck_fun(o), type); 5717 } 5718 5719 OP * 5720 Perl_ck_listiob(pTHX_ OP *o) 5721 { 5722 register OP *kid; 5723 5724 kid = cLISTOPo->op_first; 5725 if (!kid) { 5726 o = force_list(o); 5727 kid = cLISTOPo->op_first; 5728 } 5729 if (kid->op_type == OP_PUSHMARK) 5730 kid = kid->op_sibling; 5731 if (kid && o->op_flags & OPf_STACKED) 5732 kid = kid->op_sibling; 5733 else if (kid && !kid->op_sibling) { /* print HANDLE; */ 5734 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) { 5735 o->op_flags |= OPf_STACKED; /* make it a filehandle */ 5736 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid)); 5737 cLISTOPo->op_first->op_sibling = kid; 5738 cLISTOPo->op_last = kid; 5739 kid = kid->op_sibling; 5740 } 5741 } 5742 5743 if (!kid) 5744 append_elem(o->op_type, o, newDEFSVOP()); 5745 5746 return listkids(o); 5747 } 5748 5749 OP * 5750 Perl_ck_sassign(pTHX_ OP *o) 5751 { 5752 OP *kid = cLISTOPo->op_first; 5753 /* has a disposable target? */ 5754 if ((PL_opargs[kid->op_type] & OA_TARGLEX) 5755 && !(kid->op_flags & OPf_STACKED) 5756 /* Cannot steal the second time! */ 5757 && !(kid->op_private & OPpTARGET_MY)) 5758 { 5759 OP * const kkid = kid->op_sibling; 5760 5761 /* Can just relocate the target. */ 5762 if (kkid && kkid->op_type == OP_PADSV 5763 && !(kkid->op_private & OPpLVAL_INTRO)) 5764 { 5765 kid->op_targ = kkid->op_targ; 5766 kkid->op_targ = 0; 5767 /* Now we do not need PADSV and SASSIGN. */ 5768 kid->op_sibling = o->op_sibling; /* NULL */ 5769 cLISTOPo->op_first = NULL; 5770 op_free(o); 5771 op_free(kkid); 5772 kid->op_private |= OPpTARGET_MY; /* Used for context settings */ 5773 return kid; 5774 } 5775 } 5776 return o; 5777 } 5778 5779 OP * 5780 Perl_ck_match(pTHX_ OP *o) 5781 { 5782 o->op_private |= OPpRUNTIME; 5783 return o; 5784 } 5785 5786 OP * 5787 Perl_ck_method(pTHX_ OP *o) 5788 { 5789 OP * const kid = cUNOPo->op_first; 5790 if (kid->op_type == OP_CONST) { 5791 SV* sv = kSVOP->op_sv; 5792 if (!(strchr(SvPVX_const(sv), ':') || strchr(SvPVX_const(sv), '\''))) { 5793 OP *cmop; 5794 if (!SvREADONLY(sv) || !SvFAKE(sv)) { 5795 sv = newSVpvn_share(SvPVX_const(sv), SvCUR(sv), 0); 5796 } 5797 else { 5798 kSVOP->op_sv = Nullsv; 5799 } 5800 cmop = newSVOP(OP_METHOD_NAMED, 0, sv); 5801 op_free(o); 5802 return cmop; 5803 } 5804 } 5805 return o; 5806 } 5807 5808 OP * 5809 Perl_ck_null(pTHX_ OP *o) 5810 { 5811 return o; 5812 } 5813 5814 OP * 5815 Perl_ck_open(pTHX_ OP *o) 5816 { 5817 HV * const table = GvHV(PL_hintgv); 5818 if (table) { 5819 SV **svp = hv_fetch(table, "open_IN", 7, FALSE); 5820 if (svp && *svp) { 5821 const I32 mode = mode_from_discipline(*svp); 5822 if (mode & O_BINARY) 5823 o->op_private |= OPpOPEN_IN_RAW; 5824 else if (mode & O_TEXT) 5825 o->op_private |= OPpOPEN_IN_CRLF; 5826 } 5827 5828 svp = hv_fetch(table, "open_OUT", 8, FALSE); 5829 if (svp && *svp) { 5830 const I32 mode = mode_from_discipline(*svp); 5831 if (mode & O_BINARY) 5832 o->op_private |= OPpOPEN_OUT_RAW; 5833 else if (mode & O_TEXT) 5834 o->op_private |= OPpOPEN_OUT_CRLF; 5835 } 5836 } 5837 if (o->op_type == OP_BACKTICK) 5838 return o; 5839 { 5840 /* In case of three-arg dup open remove strictness 5841 * from the last arg if it is a bareword. */ 5842 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */ 5843 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */ 5844 OP *oa; 5845 const char *mode; 5846 5847 if ((last->op_type == OP_CONST) && /* The bareword. */ 5848 (last->op_private & OPpCONST_BARE) && 5849 (last->op_private & OPpCONST_STRICT) && 5850 (oa = first->op_sibling) && /* The fh. */ 5851 (oa = oa->op_sibling) && /* The mode. */ 5852 (oa->op_type == OP_CONST) && 5853 SvPOK(((SVOP*)oa)->op_sv) && 5854 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) && 5855 mode[0] == '>' && mode[1] == '&' && /* A dup open. */ 5856 (last == oa->op_sibling)) /* The bareword. */ 5857 last->op_private &= ~OPpCONST_STRICT; 5858 } 5859 return ck_fun(o); 5860 } 5861 5862 OP * 5863 Perl_ck_repeat(pTHX_ OP *o) 5864 { 5865 if (cBINOPo->op_first->op_flags & OPf_PARENS) { 5866 o->op_private |= OPpREPEAT_DOLIST; 5867 cBINOPo->op_first = force_list(cBINOPo->op_first); 5868 } 5869 else 5870 scalar(o); 5871 return o; 5872 } 5873 5874 OP * 5875 Perl_ck_require(pTHX_ OP *o) 5876 { 5877 GV* gv; 5878 5879 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */ 5880 SVOP * const kid = (SVOP*)cUNOPo->op_first; 5881 5882 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { 5883 SV * const sv = kid->op_sv; 5884 U32 was_readonly = SvREADONLY(sv); 5885 char *s; 5886 5887 if (was_readonly) { 5888 if (SvFAKE(sv)) { 5889 sv_force_normal_flags(sv, 0); 5890 assert(!SvREADONLY(sv)); 5891 was_readonly = 0; 5892 } else { 5893 SvREADONLY_off(sv); 5894 } 5895 } 5896 5897 for (s = SvPVX(sv); *s; s++) { 5898 if (*s == ':' && s[1] == ':') { 5899 *s = '/'; 5900 Move(s+2, s+1, strlen(s+2)+1, char); 5901 SvCUR_set(sv, SvCUR(sv) - 1); 5902 } 5903 } 5904 sv_catpvn(sv, ".pm", 3); 5905 SvFLAGS(sv) |= was_readonly; 5906 } 5907 } 5908 5909 /* handle override, if any */ 5910 gv = gv_fetchpv("require", FALSE, SVt_PVCV); 5911 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) 5912 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV); 5913 5914 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) { 5915 OP * const kid = cUNOPo->op_first; 5916 cUNOPo->op_first = 0; 5917 op_free(o); 5918 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED, 5919 append_elem(OP_LIST, kid, 5920 scalar(newUNOP(OP_RV2CV, 0, 5921 newGVOP(OP_GV, 0, 5922 gv)))))); 5923 } 5924 5925 return ck_fun(o); 5926 } 5927 5928 OP * 5929 Perl_ck_return(pTHX_ OP *o) 5930 { 5931 if (CvLVALUE(PL_compcv)) { 5932 OP *kid; 5933 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling) 5934 mod(kid, OP_LEAVESUBLV); 5935 } 5936 return o; 5937 } 5938 5939 #if 0 5940 OP * 5941 Perl_ck_retarget(pTHX_ OP *o) 5942 { 5943 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__); 5944 /* STUB */ 5945 return o; 5946 } 5947 #endif 5948 5949 OP * 5950 Perl_ck_select(pTHX_ OP *o) 5951 { 5952 OP* kid; 5953 if (o->op_flags & OPf_KIDS) { 5954 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ 5955 if (kid && kid->op_sibling) { 5956 o->op_type = OP_SSELECT; 5957 o->op_ppaddr = PL_ppaddr[OP_SSELECT]; 5958 o = ck_fun(o); 5959 return fold_constants(o); 5960 } 5961 } 5962 o = ck_fun(o); 5963 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ 5964 if (kid && kid->op_type == OP_RV2GV) 5965 kid->op_private &= ~HINT_STRICT_REFS; 5966 return o; 5967 } 5968 5969 OP * 5970 Perl_ck_shift(pTHX_ OP *o) 5971 { 5972 const I32 type = o->op_type; 5973 5974 if (!(o->op_flags & OPf_KIDS)) { 5975 OP *argop; 5976 5977 op_free(o); 5978 #ifdef USE_5005THREADS 5979 if (!CvUNIQUE(PL_compcv)) { 5980 argop = newOP(OP_PADAV, OPf_REF); 5981 argop->op_targ = 0; /* PAD_SV(0) is @_ */ 5982 } 5983 else { 5984 argop = newUNOP(OP_RV2AV, 0, 5985 scalar(newGVOP(OP_GV, 0, 5986 gv_fetchpv("ARGV", TRUE, SVt_PVAV)))); 5987 } 5988 #else 5989 argop = newUNOP(OP_RV2AV, 0, 5990 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv))); 5991 #endif /* USE_5005THREADS */ 5992 return newUNOP(type, 0, scalar(argop)); 5993 } 5994 return scalar(modkids(ck_fun(o), type)); 5995 } 5996 5997 OP * 5998 Perl_ck_sort(pTHX_ OP *o) 5999 { 6000 OP *firstkid; 6001 6002 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED) 6003 simplify_sort(o); 6004 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ 6005 if (o->op_flags & OPf_STACKED) { /* may have been cleared */ 6006 OP *k = NULL; 6007 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */ 6008 6009 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) { 6010 linklist(kid); 6011 if (kid->op_type == OP_SCOPE) { 6012 k = kid->op_next; 6013 kid->op_next = 0; 6014 } 6015 else if (kid->op_type == OP_LEAVE) { 6016 if (o->op_type == OP_SORT) { 6017 op_null(kid); /* wipe out leave */ 6018 kid->op_next = kid; 6019 6020 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) { 6021 if (k->op_next == kid) 6022 k->op_next = 0; 6023 /* don't descend into loops */ 6024 else if (k->op_type == OP_ENTERLOOP 6025 || k->op_type == OP_ENTERITER) 6026 { 6027 k = cLOOPx(k)->op_lastop; 6028 } 6029 } 6030 } 6031 else 6032 kid->op_next = 0; /* just disconnect the leave */ 6033 k = kLISTOP->op_first; 6034 } 6035 CALL_PEEP(k); 6036 6037 kid = firstkid; 6038 if (o->op_type == OP_SORT) { 6039 /* provide scalar context for comparison function/block */ 6040 kid = scalar(kid); 6041 kid->op_next = kid; 6042 } 6043 else 6044 kid->op_next = k; 6045 o->op_flags |= OPf_SPECIAL; 6046 } 6047 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV) 6048 op_null(firstkid); 6049 6050 firstkid = firstkid->op_sibling; 6051 } 6052 6053 /* provide list context for arguments */ 6054 if (o->op_type == OP_SORT) 6055 list(firstkid); 6056 6057 return o; 6058 } 6059 6060 STATIC void 6061 S_simplify_sort(pTHX_ OP *o) 6062 { 6063 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ 6064 OP *k; 6065 int descending; 6066 GV *gv; 6067 const char *gvname; 6068 if (!(o->op_flags & OPf_STACKED)) 6069 return; 6070 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV)); 6071 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV)); 6072 kid = kUNOP->op_first; /* get past null */ 6073 if (kid->op_type != OP_SCOPE) 6074 return; 6075 kid = kLISTOP->op_last; /* get past scope */ 6076 switch(kid->op_type) { 6077 case OP_NCMP: 6078 case OP_I_NCMP: 6079 case OP_SCMP: 6080 break; 6081 default: 6082 return; 6083 } 6084 k = kid; /* remember this node*/ 6085 if (kBINOP->op_first->op_type != OP_RV2SV) 6086 return; 6087 kid = kBINOP->op_first; /* get past cmp */ 6088 if (kUNOP->op_first->op_type != OP_GV) 6089 return; 6090 kid = kUNOP->op_first; /* get past rv2sv */ 6091 gv = kGVOP_gv; 6092 if (GvSTASH(gv) != PL_curstash) 6093 return; 6094 gvname = GvNAME(gv); 6095 if (*gvname == 'a' && gvname[1] == '\0') 6096 descending = 0; 6097 else if (*gvname == 'b' && gvname[1] == '\0') 6098 descending = 1; 6099 else 6100 return; 6101 6102 kid = k; /* back to cmp */ 6103 if (kBINOP->op_last->op_type != OP_RV2SV) 6104 return; 6105 kid = kBINOP->op_last; /* down to 2nd arg */ 6106 if (kUNOP->op_first->op_type != OP_GV) 6107 return; 6108 kid = kUNOP->op_first; /* get past rv2sv */ 6109 gv = kGVOP_gv; 6110 if (GvSTASH(gv) != PL_curstash) 6111 return; 6112 gvname = GvNAME(gv); 6113 if ( descending 6114 ? !(*gvname == 'a' && gvname[1] == '\0') 6115 : !(*gvname == 'b' && gvname[1] == '\0')) 6116 return; 6117 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL); 6118 if (descending) 6119 o->op_private |= OPpSORT_DESCEND; 6120 if (k->op_type == OP_NCMP) 6121 o->op_private |= OPpSORT_NUMERIC; 6122 if (k->op_type == OP_I_NCMP) 6123 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER; 6124 kid = cLISTOPo->op_first->op_sibling; 6125 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */ 6126 op_free(kid); /* then delete it */ 6127 } 6128 6129 OP * 6130 Perl_ck_split(pTHX_ OP *o) 6131 { 6132 register OP *kid; 6133 6134 if (o->op_flags & OPf_STACKED) 6135 return no_fh_allowed(o); 6136 6137 kid = cLISTOPo->op_first; 6138 if (kid->op_type != OP_NULL) 6139 Perl_croak(aTHX_ "panic: ck_split"); 6140 kid = kid->op_sibling; 6141 op_free(cLISTOPo->op_first); 6142 cLISTOPo->op_first = kid; 6143 if (!kid) { 6144 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1)); 6145 cLISTOPo->op_last = kid; /* There was only one element previously */ 6146 } 6147 6148 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) { 6149 OP * const sibl = kid->op_sibling; 6150 kid->op_sibling = 0; 6151 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop); 6152 if (cLISTOPo->op_first == cLISTOPo->op_last) 6153 cLISTOPo->op_last = kid; 6154 cLISTOPo->op_first = kid; 6155 kid->op_sibling = sibl; 6156 } 6157 6158 kid->op_type = OP_PUSHRE; 6159 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE]; 6160 scalar(kid); 6161 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) { 6162 Perl_warner(aTHX_ packWARN(WARN_REGEXP), 6163 "Use of /g modifier is meaningless in split"); 6164 } 6165 6166 if (!kid->op_sibling) 6167 append_elem(OP_SPLIT, o, newDEFSVOP()); 6168 6169 kid = kid->op_sibling; 6170 scalar(kid); 6171 6172 if (!kid->op_sibling) 6173 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0))); 6174 6175 kid = kid->op_sibling; 6176 scalar(kid); 6177 6178 if (kid->op_sibling) 6179 return too_many_arguments(o,OP_DESC(o)); 6180 6181 return o; 6182 } 6183 6184 OP * 6185 Perl_ck_join(pTHX_ OP *o) 6186 { 6187 const OP * const kid = cLISTOPo->op_first->op_sibling; 6188 if (kid && kid->op_type == OP_MATCH) { 6189 if (ckWARN(WARN_SYNTAX)) { 6190 const REGEXP *re = PM_GETRE(kPMOP); 6191 const char *pmstr = re ? re->precomp : "STRING"; 6192 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 6193 "/%s/ should probably be written as \"%s\"", 6194 pmstr, pmstr); 6195 } 6196 } 6197 return ck_fun(o); 6198 } 6199 6200 OP * 6201 Perl_ck_subr(pTHX_ OP *o) 6202 { 6203 OP *prev = ((cUNOPo->op_first->op_sibling) 6204 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first; 6205 OP *o2 = prev->op_sibling; 6206 OP *cvop; 6207 char *proto = 0; 6208 CV *cv = 0; 6209 GV *namegv = 0; 6210 int optional = 0; 6211 I32 arg = 0; 6212 I32 contextclass = 0; 6213 char *e = 0; 6214 6215 o->op_private |= OPpENTERSUB_HASTARG; 6216 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ; 6217 if (cvop->op_type == OP_RV2CV) { 6218 SVOP* tmpop; 6219 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER); 6220 op_null(cvop); /* disable rv2cv */ 6221 tmpop = (SVOP*)((UNOP*)cvop)->op_first; 6222 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) { 6223 GV *gv = cGVOPx_gv(tmpop); 6224 cv = GvCVu(gv); 6225 if (!cv) 6226 tmpop->op_private |= OPpEARLY_CV; 6227 else if (SvPOK(cv)) { 6228 namegv = CvANON(cv) ? gv : CvGV(cv); 6229 proto = SvPV_nolen((SV*)cv); 6230 } 6231 } 6232 } 6233 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) { 6234 if (o2->op_type == OP_CONST) 6235 o2->op_private &= ~OPpCONST_STRICT; 6236 else if (o2->op_type == OP_LIST) { 6237 OP * const o = ((UNOP*)o2)->op_first->op_sibling; 6238 if (o && o->op_type == OP_CONST) 6239 o->op_private &= ~OPpCONST_STRICT; 6240 } 6241 } 6242 o->op_private |= (PL_hints & HINT_STRICT_REFS); 6243 if (PERLDB_SUB && PL_curstash != PL_debstash) 6244 o->op_private |= OPpENTERSUB_DB; 6245 while (o2 != cvop) { 6246 if (proto) { 6247 switch (*proto) { 6248 case '\0': 6249 return too_many_arguments(o, gv_ename(namegv)); 6250 case ';': 6251 optional = 1; 6252 proto++; 6253 continue; 6254 case '$': 6255 proto++; 6256 arg++; 6257 scalar(o2); 6258 break; 6259 case '%': 6260 case '@': 6261 list(o2); 6262 arg++; 6263 break; 6264 case '&': 6265 proto++; 6266 arg++; 6267 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF) 6268 bad_type(arg, 6269 arg == 1 ? "block or sub {}" : "sub {}", 6270 gv_ename(namegv), o2); 6271 break; 6272 case '*': 6273 /* '*' allows any scalar type, including bareword */ 6274 proto++; 6275 arg++; 6276 if (o2->op_type == OP_RV2GV) 6277 goto wrapref; /* autoconvert GLOB -> GLOBref */ 6278 else if (o2->op_type == OP_CONST) 6279 o2->op_private &= ~OPpCONST_STRICT; 6280 else if (o2->op_type == OP_ENTERSUB) { 6281 /* accidental subroutine, revert to bareword */ 6282 OP *gvop = ((UNOP*)o2)->op_first; 6283 if (gvop && gvop->op_type == OP_NULL) { 6284 gvop = ((UNOP*)gvop)->op_first; 6285 if (gvop) { 6286 for (; gvop->op_sibling; gvop = gvop->op_sibling) 6287 ; 6288 if (gvop && 6289 (gvop->op_private & OPpENTERSUB_NOPAREN) && 6290 (gvop = ((UNOP*)gvop)->op_first) && 6291 gvop->op_type == OP_GV) 6292 { 6293 GV * const gv = cGVOPx_gv(gvop); 6294 OP * const sibling = o2->op_sibling; 6295 SV * const n = newSVpvn("",0); 6296 op_free(o2); 6297 gv_fullname4(n, gv, "", FALSE); 6298 o2 = newSVOP(OP_CONST, 0, n); 6299 prev->op_sibling = o2; 6300 o2->op_sibling = sibling; 6301 } 6302 } 6303 } 6304 } 6305 scalar(o2); 6306 break; 6307 case '[': case ']': 6308 goto oops; 6309 break; 6310 case '\\': 6311 proto++; 6312 arg++; 6313 again: 6314 switch (*proto++) { 6315 case '[': 6316 if (contextclass++ == 0) { 6317 e = strchr(proto, ']'); 6318 if (!e || e == proto) 6319 goto oops; 6320 } 6321 else 6322 goto oops; 6323 goto again; 6324 break; 6325 case ']': 6326 if (contextclass) { 6327 char *p = proto; 6328 const char s = *p; 6329 contextclass = 0; 6330 *p = '\0'; 6331 while (*--p != '['); 6332 bad_type(arg, Perl_form(aTHX_ "one of %s", p), 6333 gv_ename(namegv), o2); 6334 *proto = s; 6335 } else 6336 goto oops; 6337 break; 6338 case '*': 6339 if (o2->op_type == OP_RV2GV) 6340 goto wrapref; 6341 if (!contextclass) 6342 bad_type(arg, "symbol", gv_ename(namegv), o2); 6343 break; 6344 case '&': 6345 if (o2->op_type == OP_ENTERSUB) 6346 goto wrapref; 6347 if (!contextclass) 6348 bad_type(arg, "subroutine entry", gv_ename(namegv), o2); 6349 break; 6350 case '$': 6351 if (o2->op_type == OP_RV2SV || 6352 o2->op_type == OP_PADSV || 6353 o2->op_type == OP_HELEM || 6354 o2->op_type == OP_AELEM || 6355 o2->op_type == OP_THREADSV) 6356 goto wrapref; 6357 if (!contextclass) 6358 bad_type(arg, "scalar", gv_ename(namegv), o2); 6359 break; 6360 case '@': 6361 if (o2->op_type == OP_RV2AV || 6362 o2->op_type == OP_PADAV) 6363 goto wrapref; 6364 if (!contextclass) 6365 bad_type(arg, "array", gv_ename(namegv), o2); 6366 break; 6367 case '%': 6368 if (o2->op_type == OP_RV2HV || 6369 o2->op_type == OP_PADHV) 6370 goto wrapref; 6371 if (!contextclass) 6372 bad_type(arg, "hash", gv_ename(namegv), o2); 6373 break; 6374 wrapref: 6375 { 6376 OP* const kid = o2; 6377 OP* const sib = kid->op_sibling; 6378 kid->op_sibling = 0; 6379 o2 = newUNOP(OP_REFGEN, 0, kid); 6380 o2->op_sibling = sib; 6381 prev->op_sibling = o2; 6382 } 6383 if (contextclass && e) { 6384 proto = e + 1; 6385 contextclass = 0; 6386 } 6387 break; 6388 default: goto oops; 6389 } 6390 if (contextclass) 6391 goto again; 6392 break; 6393 case ' ': 6394 proto++; 6395 continue; 6396 default: 6397 oops: 6398 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf, 6399 gv_ename(namegv), cv); 6400 } 6401 } 6402 else 6403 list(o2); 6404 mod(o2, OP_ENTERSUB); 6405 prev = o2; 6406 o2 = o2->op_sibling; 6407 } /* while */ 6408 if (proto && !optional && 6409 (*proto && *proto != '@' && *proto != '%' && *proto != ';')) 6410 return too_few_arguments(o, gv_ename(namegv)); 6411 return o; 6412 } 6413 6414 OP * 6415 Perl_ck_svconst(pTHX_ OP *o) 6416 { 6417 SvREADONLY_on(cSVOPo->op_sv); 6418 return o; 6419 } 6420 6421 OP * 6422 Perl_ck_trunc(pTHX_ OP *o) 6423 { 6424 if (o->op_flags & OPf_KIDS) { 6425 SVOP *kid = (SVOP*)cUNOPo->op_first; 6426 6427 if (kid->op_type == OP_NULL) 6428 kid = (SVOP*)kid->op_sibling; 6429 if (kid && kid->op_type == OP_CONST && 6430 (kid->op_private & OPpCONST_BARE)) 6431 { 6432 o->op_flags |= OPf_SPECIAL; 6433 kid->op_private &= ~OPpCONST_STRICT; 6434 } 6435 } 6436 return ck_fun(o); 6437 } 6438 6439 OP * 6440 Perl_ck_substr(pTHX_ OP *o) 6441 { 6442 o = ck_fun(o); 6443 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) { 6444 OP *kid = cLISTOPo->op_first; 6445 6446 if (kid->op_type == OP_NULL) 6447 kid = kid->op_sibling; 6448 if (kid) 6449 kid->op_flags |= OPf_MOD; 6450 6451 } 6452 return o; 6453 } 6454 6455 /* A peephole optimizer. We visit the ops in the order they're to execute. 6456 * See the comments at the top of this file for more details about when 6457 * peep() is called */ 6458 6459 void 6460 Perl_peep(pTHX_ register OP *o) 6461 { 6462 register OP* oldop = 0; 6463 STRLEN n_a; 6464 6465 if (!o || o->op_seq) 6466 return; 6467 ENTER; 6468 SAVEOP(); 6469 SAVEVPTR(PL_curcop); 6470 for (; o; o = o->op_next) { 6471 if (o->op_seq) 6472 break; 6473 /* The special value -1 is used by the B::C compiler backend to indicate 6474 * that an op is statically defined and should not be freed */ 6475 if (!PL_op_seqmax || PL_op_seqmax == (U16)-1) 6476 PL_op_seqmax = 1; 6477 PL_op = o; 6478 switch (o->op_type) { 6479 case OP_SETSTATE: 6480 case OP_NEXTSTATE: 6481 case OP_DBSTATE: 6482 PL_curcop = ((COP*)o); /* for warnings */ 6483 o->op_seq = PL_op_seqmax++; 6484 break; 6485 6486 case OP_CONST: 6487 if (cSVOPo->op_private & OPpCONST_STRICT) 6488 no_bareword_allowed(o); 6489 #ifdef USE_ITHREADS 6490 case OP_METHOD_NAMED: 6491 /* Relocate sv to the pad for thread safety. 6492 * Despite being a "constant", the SV is written to, 6493 * for reference counts, sv_upgrade() etc. */ 6494 if (cSVOP->op_sv) { 6495 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP); 6496 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) { 6497 /* If op_sv is already a PADTMP then it is being used by 6498 * some pad, so make a copy. */ 6499 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv); 6500 SvREADONLY_on(PAD_SVl(ix)); 6501 SvREFCNT_dec(cSVOPo->op_sv); 6502 } 6503 else { 6504 SvREFCNT_dec(PAD_SVl(ix)); 6505 SvPADTMP_on(cSVOPo->op_sv); 6506 PAD_SETSV(ix, cSVOPo->op_sv); 6507 /* XXX I don't know how this isn't readonly already. */ 6508 SvREADONLY_on(PAD_SVl(ix)); 6509 } 6510 cSVOPo->op_sv = Nullsv; 6511 o->op_targ = ix; 6512 } 6513 #endif 6514 o->op_seq = PL_op_seqmax++; 6515 break; 6516 6517 case OP_CONCAT: 6518 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) { 6519 if (o->op_next->op_private & OPpTARGET_MY) { 6520 if (o->op_flags & OPf_STACKED) /* chained concats */ 6521 goto ignore_optimization; 6522 else { 6523 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */ 6524 o->op_targ = o->op_next->op_targ; 6525 o->op_next->op_targ = 0; 6526 o->op_private |= OPpTARGET_MY; 6527 } 6528 } 6529 op_null(o->op_next); 6530 } 6531 ignore_optimization: 6532 o->op_seq = PL_op_seqmax++; 6533 break; 6534 case OP_STUB: 6535 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) { 6536 o->op_seq = PL_op_seqmax++; 6537 break; /* Scalar stub must produce undef. List stub is noop */ 6538 } 6539 goto nothin; 6540 case OP_NULL: 6541 if (o->op_targ == OP_NEXTSTATE 6542 || o->op_targ == OP_DBSTATE 6543 || o->op_targ == OP_SETSTATE) 6544 { 6545 PL_curcop = ((COP*)o); 6546 } 6547 /* XXX: We avoid setting op_seq here to prevent later calls 6548 to peep() from mistakenly concluding that optimisation 6549 has already occurred. This doesn't fix the real problem, 6550 though (See 20010220.007). AMS 20010719 */ 6551 if (oldop && o->op_next) { 6552 oldop->op_next = o->op_next; 6553 continue; 6554 } 6555 break; 6556 case OP_SCALAR: 6557 case OP_LINESEQ: 6558 case OP_SCOPE: 6559 nothin: 6560 if (oldop && o->op_next) { 6561 oldop->op_next = o->op_next; 6562 continue; 6563 } 6564 o->op_seq = PL_op_seqmax++; 6565 break; 6566 6567 case OP_PADAV: 6568 case OP_GV: 6569 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) { 6570 OP* pop = (o->op_type == OP_PADAV) ? 6571 o->op_next : o->op_next->op_next; 6572 IV i; 6573 if (pop && pop->op_type == OP_CONST && 6574 ((PL_op = pop->op_next)) && 6575 pop->op_next->op_type == OP_AELEM && 6576 !(pop->op_next->op_private & 6577 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) && 6578 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase) 6579 <= 255 && 6580 i >= 0) 6581 { 6582 GV *gv; 6583 if (cSVOPx(pop)->op_private & OPpCONST_STRICT) 6584 no_bareword_allowed(pop); 6585 if (o->op_type == OP_GV) 6586 op_null(o->op_next); 6587 op_null(pop->op_next); 6588 op_null(pop); 6589 o->op_flags |= pop->op_next->op_flags & OPf_MOD; 6590 o->op_next = pop->op_next->op_next; 6591 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST]; 6592 o->op_private = (U8)i; 6593 if (o->op_type == OP_GV) { 6594 gv = cGVOPo_gv; 6595 GvAVn(gv); 6596 } 6597 else 6598 o->op_flags |= OPf_SPECIAL; 6599 o->op_type = OP_AELEMFAST; 6600 } 6601 o->op_seq = PL_op_seqmax++; 6602 break; 6603 } 6604 6605 if (o->op_next->op_type == OP_RV2SV) { 6606 if (!(o->op_next->op_private & OPpDEREF)) { 6607 op_null(o->op_next); 6608 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO 6609 | OPpOUR_INTRO); 6610 o->op_next = o->op_next->op_next; 6611 o->op_type = OP_GVSV; 6612 o->op_ppaddr = PL_ppaddr[OP_GVSV]; 6613 } 6614 } 6615 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) { 6616 GV * const gv = cGVOPo_gv; 6617 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) { 6618 /* XXX could check prototype here instead of just carping */ 6619 SV * const sv = sv_newmortal(); 6620 gv_efullname3(sv, gv, Nullch); 6621 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), 6622 "%"SVf"() called too early to check prototype", 6623 sv); 6624 } 6625 } 6626 else if (o->op_next->op_type == OP_READLINE 6627 && o->op_next->op_next->op_type == OP_CONCAT 6628 && (o->op_next->op_next->op_flags & OPf_STACKED)) 6629 { 6630 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */ 6631 o->op_type = OP_RCATLINE; 6632 o->op_flags |= OPf_STACKED; 6633 o->op_ppaddr = PL_ppaddr[OP_RCATLINE]; 6634 op_null(o->op_next->op_next); 6635 op_null(o->op_next); 6636 } 6637 6638 o->op_seq = PL_op_seqmax++; 6639 break; 6640 6641 case OP_MAPWHILE: 6642 case OP_GREPWHILE: 6643 case OP_AND: 6644 case OP_OR: 6645 case OP_ANDASSIGN: 6646 case OP_ORASSIGN: 6647 case OP_COND_EXPR: 6648 case OP_RANGE: 6649 o->op_seq = PL_op_seqmax++; 6650 while (cLOGOP->op_other->op_type == OP_NULL) 6651 cLOGOP->op_other = cLOGOP->op_other->op_next; 6652 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */ 6653 break; 6654 6655 case OP_ENTERLOOP: 6656 case OP_ENTERITER: 6657 o->op_seq = PL_op_seqmax++; 6658 while (cLOOP->op_redoop->op_type == OP_NULL) 6659 cLOOP->op_redoop = cLOOP->op_redoop->op_next; 6660 peep(cLOOP->op_redoop); 6661 while (cLOOP->op_nextop->op_type == OP_NULL) 6662 cLOOP->op_nextop = cLOOP->op_nextop->op_next; 6663 peep(cLOOP->op_nextop); 6664 while (cLOOP->op_lastop->op_type == OP_NULL) 6665 cLOOP->op_lastop = cLOOP->op_lastop->op_next; 6666 peep(cLOOP->op_lastop); 6667 break; 6668 6669 case OP_QR: 6670 case OP_MATCH: 6671 case OP_SUBST: 6672 o->op_seq = PL_op_seqmax++; 6673 while (cPMOP->op_pmreplstart && 6674 cPMOP->op_pmreplstart->op_type == OP_NULL) 6675 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next; 6676 peep(cPMOP->op_pmreplstart); 6677 break; 6678 6679 case OP_EXEC: 6680 o->op_seq = PL_op_seqmax++; 6681 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE 6682 && ckWARN(WARN_SYNTAX)) 6683 { 6684 if (o->op_next->op_sibling && 6685 o->op_next->op_sibling->op_type != OP_EXIT && 6686 o->op_next->op_sibling->op_type != OP_WARN && 6687 o->op_next->op_sibling->op_type != OP_DIE) { 6688 const line_t oldline = CopLINE(PL_curcop); 6689 6690 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next)); 6691 Perl_warner(aTHX_ packWARN(WARN_EXEC), 6692 "Statement unlikely to be reached"); 6693 Perl_warner(aTHX_ packWARN(WARN_EXEC), 6694 "\t(Maybe you meant system() when you said exec()?)\n"); 6695 CopLINE_set(PL_curcop, oldline); 6696 } 6697 } 6698 break; 6699 6700 case OP_HELEM: { 6701 UNOP *rop; 6702 SV *lexname; 6703 GV **fields; 6704 SV **svp, **indsvp, *sv; 6705 I32 ind; 6706 const char *key = NULL; 6707 STRLEN keylen; 6708 6709 o->op_seq = PL_op_seqmax++; 6710 6711 if (((BINOP*)o)->op_last->op_type != OP_CONST) 6712 break; 6713 6714 /* Make the CONST have a shared SV */ 6715 svp = cSVOPx_svp(((BINOP*)o)->op_last); 6716 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) { 6717 key = SvPV_const(sv, keylen); 6718 lexname = newSVpvn_share(key, 6719 SvUTF8(sv) ? -(I32)keylen : keylen, 6720 0); 6721 SvREFCNT_dec(sv); 6722 *svp = lexname; 6723 } 6724 6725 if ((o->op_private & (OPpLVAL_INTRO))) 6726 break; 6727 6728 rop = (UNOP*)((BINOP*)o)->op_first; 6729 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV) 6730 break; 6731 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE); 6732 if (!(SvFLAGS(lexname) & SVpad_TYPED)) 6733 break; 6734 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE); 6735 if (!fields || !GvHV(*fields)) 6736 break; 6737 key = SvPV_const(*svp, keylen); 6738 indsvp = hv_fetch(GvHV(*fields), key, 6739 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE); 6740 if (!indsvp) { 6741 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" " 6742 "in variable %s of type %s", 6743 key, SvPV_nolen_const(lexname), 6744 HvNAME_get(SvSTASH(lexname))); 6745 } 6746 ind = SvIV(*indsvp); 6747 if (ind < 1) 6748 Perl_croak(aTHX_ "Bad index while coercing array into hash"); 6749 rop->op_type = OP_RV2AV; 6750 rop->op_ppaddr = PL_ppaddr[OP_RV2AV]; 6751 o->op_type = OP_AELEM; 6752 o->op_ppaddr = PL_ppaddr[OP_AELEM]; 6753 sv = newSViv(ind); 6754 if (SvREADONLY(*svp)) 6755 SvREADONLY_on(sv); 6756 SvFLAGS(sv) |= (SvFLAGS(*svp) 6757 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY)); 6758 SvREFCNT_dec(*svp); 6759 *svp = sv; 6760 break; 6761 } 6762 6763 case OP_HSLICE: { 6764 UNOP *rop; 6765 SV *lexname; 6766 GV **fields; 6767 SV **svp, **indsvp, *sv; 6768 I32 ind; 6769 const char *key; 6770 STRLEN keylen; 6771 SVOP *first_key_op, *key_op; 6772 6773 o->op_seq = PL_op_seqmax++; 6774 if ((o->op_private & (OPpLVAL_INTRO)) 6775 /* I bet there's always a pushmark... */ 6776 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST) 6777 /* hmmm, no optimization if list contains only one key. */ 6778 break; 6779 rop = (UNOP*)((LISTOP*)o)->op_last; 6780 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV) 6781 break; 6782 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE); 6783 if (!(SvFLAGS(lexname) & SVpad_TYPED)) 6784 break; 6785 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE); 6786 if (!fields || !GvHV(*fields)) 6787 break; 6788 /* Again guessing that the pushmark can be jumped over.... */ 6789 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling) 6790 ->op_first->op_sibling; 6791 /* Check that the key list contains only constants. */ 6792 for (key_op = first_key_op; key_op; 6793 key_op = (SVOP*)key_op->op_sibling) 6794 if (key_op->op_type != OP_CONST) 6795 break; 6796 if (key_op) 6797 break; 6798 rop->op_type = OP_RV2AV; 6799 rop->op_ppaddr = PL_ppaddr[OP_RV2AV]; 6800 o->op_type = OP_ASLICE; 6801 o->op_ppaddr = PL_ppaddr[OP_ASLICE]; 6802 for (key_op = first_key_op; key_op; 6803 key_op = (SVOP*)key_op->op_sibling) { 6804 svp = cSVOPx_svp(key_op); 6805 key = SvPV_const(*svp, keylen); 6806 indsvp = hv_fetch(GvHV(*fields), key, 6807 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE); 6808 if (!indsvp) { 6809 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" " 6810 "in variable %s of type %s", 6811 key, SvPV(lexname, n_a), HvNAME_get(SvSTASH(lexname))); 6812 } 6813 ind = SvIV(*indsvp); 6814 if (ind < 1) 6815 Perl_croak(aTHX_ "Bad index while coercing array into hash"); 6816 sv = newSViv(ind); 6817 if (SvREADONLY(*svp)) 6818 SvREADONLY_on(sv); 6819 SvFLAGS(sv) |= (SvFLAGS(*svp) 6820 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY)); 6821 SvREFCNT_dec(*svp); 6822 *svp = sv; 6823 } 6824 break; 6825 } 6826 6827 case OP_SORT: { 6828 /* will point to RV2AV or PADAV op on LHS/RHS of assign */ 6829 OP *oleft; 6830 OP *o2; 6831 6832 /* check that RHS of sort is a single plain array */ 6833 OP *oright = cUNOPo->op_first; 6834 if (!oright || oright->op_type != OP_PUSHMARK) 6835 break; 6836 6837 /* reverse sort ... can be optimised. */ 6838 if (!cUNOPo->op_sibling) { 6839 /* Nothing follows us on the list. */ 6840 OP * const reverse = o->op_next; 6841 6842 if (reverse->op_type == OP_REVERSE && 6843 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) { 6844 OP * const pushmark = cUNOPx(reverse)->op_first; 6845 if (pushmark && (pushmark->op_type == OP_PUSHMARK) 6846 && (cUNOPx(pushmark)->op_sibling == o)) { 6847 /* reverse -> pushmark -> sort */ 6848 o->op_private |= OPpSORT_REVERSE; 6849 op_null(reverse); 6850 pushmark->op_next = oright->op_next; 6851 op_null(oright); 6852 } 6853 } 6854 } 6855 6856 /* make @a = sort @a act in-place */ 6857 6858 o->op_seq = PL_op_seqmax++; 6859 6860 oright = cUNOPx(oright)->op_sibling; 6861 if (!oright) 6862 break; 6863 if (oright->op_type == OP_NULL) { /* skip sort block/sub */ 6864 oright = cUNOPx(oright)->op_sibling; 6865 } 6866 6867 if (!oright || 6868 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV) 6869 || oright->op_next != o 6870 || (oright->op_private & OPpLVAL_INTRO) 6871 ) 6872 break; 6873 6874 /* o2 follows the chain of op_nexts through the LHS of the 6875 * assign (if any) to the aassign op itself */ 6876 o2 = o->op_next; 6877 if (!o2 || o2->op_type != OP_NULL) 6878 break; 6879 o2 = o2->op_next; 6880 if (!o2 || o2->op_type != OP_PUSHMARK) 6881 break; 6882 o2 = o2->op_next; 6883 if (o2 && o2->op_type == OP_GV) 6884 o2 = o2->op_next; 6885 if (!o2 6886 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV) 6887 || (o2->op_private & OPpLVAL_INTRO) 6888 ) 6889 break; 6890 oleft = o2; 6891 o2 = o2->op_next; 6892 if (!o2 || o2->op_type != OP_NULL) 6893 break; 6894 o2 = o2->op_next; 6895 if (!o2 || o2->op_type != OP_AASSIGN 6896 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID) 6897 break; 6898 6899 /* check that the sort is the first arg on RHS of assign */ 6900 6901 o2 = cUNOPx(o2)->op_first; 6902 if (!o2 || o2->op_type != OP_NULL) 6903 break; 6904 o2 = cUNOPx(o2)->op_first; 6905 if (!o2 || o2->op_type != OP_PUSHMARK) 6906 break; 6907 if (o2->op_sibling != o) 6908 break; 6909 6910 /* check the array is the same on both sides */ 6911 if (oleft->op_type == OP_RV2AV) { 6912 if (oright->op_type != OP_RV2AV 6913 || !cUNOPx(oright)->op_first 6914 || cUNOPx(oright)->op_first->op_type != OP_GV 6915 || cGVOPx_gv(cUNOPx(oleft)->op_first) != 6916 cGVOPx_gv(cUNOPx(oright)->op_first) 6917 ) 6918 break; 6919 } 6920 else if (oright->op_type != OP_PADAV 6921 || oright->op_targ != oleft->op_targ 6922 ) 6923 break; 6924 6925 /* transfer MODishness etc from LHS arg to RHS arg */ 6926 oright->op_flags = oleft->op_flags; 6927 o->op_private |= OPpSORT_INPLACE; 6928 6929 /* excise push->gv->rv2av->null->aassign */ 6930 o2 = o->op_next->op_next; 6931 op_null(o2); /* PUSHMARK */ 6932 o2 = o2->op_next; 6933 if (o2->op_type == OP_GV) { 6934 op_null(o2); /* GV */ 6935 o2 = o2->op_next; 6936 } 6937 op_null(o2); /* RV2AV or PADAV */ 6938 o2 = o2->op_next->op_next; 6939 op_null(o2); /* AASSIGN */ 6940 6941 o->op_next = o2->op_next; 6942 6943 break; 6944 } 6945 6946 case OP_REVERSE: { 6947 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av; 6948 OP *gvop = NULL; 6949 LISTOP *enter, *exlist; 6950 o->op_seq = PL_op_seqmax++; 6951 6952 enter = (LISTOP *) o->op_next; 6953 if (!enter) 6954 break; 6955 if (enter->op_type == OP_NULL) { 6956 enter = (LISTOP *) enter->op_next; 6957 if (!enter) 6958 break; 6959 } 6960 /* for $a (...) will have OP_GV then OP_RV2GV here. 6961 for (...) just has an OP_GV. */ 6962 if (enter->op_type == OP_GV) { 6963 gvop = (OP *) enter; 6964 enter = (LISTOP *) enter->op_next; 6965 if (!enter) 6966 break; 6967 if (enter->op_type == OP_RV2GV) { 6968 enter = (LISTOP *) enter->op_next; 6969 if (!enter) 6970 break; 6971 } 6972 } 6973 6974 if (enter->op_type != OP_ENTERITER) 6975 break; 6976 6977 iter = enter->op_next; 6978 if (!iter || iter->op_type != OP_ITER) 6979 break; 6980 6981 expushmark = enter->op_first; 6982 if (!expushmark || expushmark->op_type != OP_NULL 6983 || expushmark->op_targ != OP_PUSHMARK) 6984 break; 6985 6986 exlist = (LISTOP *) expushmark->op_sibling; 6987 if (!exlist || exlist->op_type != OP_NULL 6988 || exlist->op_targ != OP_LIST) 6989 break; 6990 6991 if (exlist->op_last != o) { 6992 /* Mmm. Was expecting to point back to this op. */ 6993 break; 6994 } 6995 theirmark = exlist->op_first; 6996 if (!theirmark || theirmark->op_type != OP_PUSHMARK) 6997 break; 6998 6999 if (theirmark->op_sibling != o) { 7000 /* There's something between the mark and the reverse, eg 7001 for (1, reverse (...)) 7002 so no go. */ 7003 break; 7004 } 7005 7006 ourmark = ((LISTOP *)o)->op_first; 7007 if (!ourmark || ourmark->op_type != OP_PUSHMARK) 7008 break; 7009 7010 ourlast = ((LISTOP *)o)->op_last; 7011 if (!ourlast || ourlast->op_next != o) 7012 break; 7013 7014 rv2av = ourmark->op_sibling; 7015 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0 7016 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS) 7017 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) { 7018 /* We're just reversing a single array. */ 7019 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF; 7020 enter->op_flags |= OPf_STACKED; 7021 } 7022 7023 /* We don't have control over who points to theirmark, so sacrifice 7024 ours. */ 7025 theirmark->op_next = ourmark->op_next; 7026 theirmark->op_flags = ourmark->op_flags; 7027 ourlast->op_next = gvop ? gvop : (OP *) enter; 7028 op_null(ourmark); 7029 op_null(o); 7030 enter->op_private |= OPpITER_REVERSED; 7031 iter->op_private |= OPpITER_REVERSED; 7032 7033 break; 7034 } 7035 7036 default: 7037 o->op_seq = PL_op_seqmax++; 7038 break; 7039 } 7040 oldop = o; 7041 } 7042 LEAVE; 7043 } 7044 7045 char* 7046 Perl_custom_op_name(pTHX_ OP* o) 7047 { 7048 const IV index = PTR2IV(o->op_ppaddr); 7049 SV* keysv; 7050 HE* he; 7051 7052 if (!PL_custom_op_names) /* This probably shouldn't happen */ 7053 return (char *)PL_op_name[OP_CUSTOM]; 7054 7055 keysv = sv_2mortal(newSViv(index)); 7056 7057 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0); 7058 if (!he) 7059 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */ 7060 7061 return SvPV_nolen(HeVAL(he)); 7062 } 7063 7064 char* 7065 Perl_custom_op_desc(pTHX_ OP* o) 7066 { 7067 const IV index = PTR2IV(o->op_ppaddr); 7068 SV* keysv; 7069 HE* he; 7070 7071 if (!PL_custom_op_descs) 7072 return (char *)PL_op_desc[OP_CUSTOM]; 7073 7074 keysv = sv_2mortal(newSViv(index)); 7075 7076 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0); 7077 if (!he) 7078 return (char *)PL_op_desc[OP_CUSTOM]; 7079 7080 return SvPV_nolen(HeVAL(he)); 7081 } 7082 7083 #include "XSUB.h" 7084 7085 /* Efficient sub that returns a constant scalar value. */ 7086 static void 7087 const_sv_xsub(pTHX_ CV* cv) 7088 { 7089 dXSARGS; 7090 if (items != 0) { 7091 #if 0 7092 Perl_croak(aTHX_ "usage: %s::%s()", 7093 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv))); 7094 #endif 7095 } 7096 EXTEND(sp, 1); 7097 ST(0) = (SV*)XSANY.any_ptr; 7098 XSRETURN(1); 7099 } 7100 7101 /* 7102 * Local variables: 7103 * c-indentation-style: bsd 7104 * c-basic-offset: 4 7105 * indent-tabs-mode: t 7106 * End: 7107 * 7108 * ex: set ts=8 sts=4 sw=4 noet: 7109 */ 7110