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