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 ###### { 164 ###### SV* tmpsv = sv_newmortal(); 165 ###### gv_efullname3(tmpsv, gv, Nullch); 166 ###### return SvPV_nolen_const(tmpsv); 167 } 168 169 STATIC OP * 170 S_no_fh_allowed(pTHX_ OP *o) 171 ###### { 172 ###### yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function", 173 OP_DESC(o))); 174 ###### return o; 175 } 176 177 STATIC OP * 178 S_too_few_arguments(pTHX_ OP *o, const char *name) 179 ###### { 180 ###### yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name)); 181 ###### return o; 182 } 183 184 STATIC OP * 185 S_too_many_arguments(pTHX_ OP *o, const char *name) 186 ###### { 187 ###### yyerror(Perl_form(aTHX_ "Too many arguments for %s", name)); 188 ###### return o; 189 } 190 191 STATIC void 192 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid) 193 ###### { 194 ###### yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)", 195 (int)n, name, t, OP_DESC(kid))); 196 } 197 198 STATIC void 199 S_no_bareword_allowed(pTHX_ const OP *o) 200 ###### { 201 ###### qerror(Perl_mess(aTHX_ 202 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use", 203 cSVOPo_sv)); 204 } 205 206 /* "register" allocation */ 207 208 PADOFFSET 209 Perl_allocmy(pTHX_ char *name) 210 214565 { 211 214565 PADOFFSET off; 212 213 /* complain about "my $" etc etc */ 214 214565 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 ###### if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) { 220 /* 1999-02-27 mjd@plover.com */ 221 ###### char *p; 222 ###### p = strchr(name, '\0'); 223 /* The next block assumes the buffer is at least 205 chars 224 long. At present, it's always at least 256 chars. */ 225 ###### if (p-name > 200) { 226 ###### strcpy(name+200, "..."); 227 ###### p = name+199; 228 } 229 else { 230 ###### p[1] = '\0'; 231 } 232 /* Move everything else down one character */ 233 ###### for (; p-name > 2; p--) 234 ###### *p = *(p-1); 235 ###### name[2] = toCTRL(name[1]); 236 ###### name[1] = '^'; 237 } 238 ###### yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name)); 239 } 240 241 /* check for duplicate declaration */ 242 214565 pad_check_dup(name, 243 (bool)(PL_in_my == KEY_our), 244 (PL_curstash ? PL_curstash : PL_defstash) 245 ); 246 247 214565 if (PL_in_my_stash && *name != '$') { 248 ###### 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 214565 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 214565 return off; 265 } 266 267 /* Destructor */ 268 269 void 270 Perl_op_free(pTHX_ OP *o) 271 8496069 { 272 dVAR; 273 8496069 OPCODE type; 274 8496069 PADOFFSET refcnt; 275 276 8496069 if (!o || o->op_static) 277 8477959 return; 278 279 8477959 if (o->op_private & OPpREFCOUNTED) { 280 508618 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 102500 OP_REFCNT_LOCK; 288 102500 refcnt = OpREFCNT_dec(o); 289 102500 OP_REFCNT_UNLOCK; 290 102500 if (refcnt) 291 2948 return; 292 8475011 break; 293 default: 294 8475011 break; 295 } 296 } 297 298 8475011 if (o->op_flags & OPf_KIDS) { 299 3855089 register OP *kid, *nextkid; 300 11800215 for (kid = cUNOPo->op_first; kid; kid = nextkid) { 301 7945126 nextkid = kid->op_sibling; /* Get before next freeing kid */ 302 7945126 op_free(kid); 303 } 304 } 305 8475011 type = o->op_type; 306 8475011 if (type == OP_NULL) 307 1439759 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 8475011 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE) 312 830221 cop_free((COP*)o); 313 314 8475011 op_clear(o); 315 8475011 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 9545920 { 325 326 dVAR; 327 9545920 switch (o->op_type) { 328 case OP_NULL: /* Was holding old type, if any. */ 329 case OP_ENTEREVAL: /* Was holding hints. */ 330 1445689 o->op_targ = 0; 331 1445689 break; 332 default: 333 6185245 if (!(o->op_flags & OPf_REF) 334 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst))) 335 539497 break; 336 /* FALL THROUGH */ 337 case OP_GVSV: 338 case OP_GV: 339 case OP_AELEMFAST: 340 539497 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 533191 SvREFCNT_dec(cSVOPo->op_sv); 351 533191 cSVOPo->op_sv = Nullsv; 352 #endif 353 } 354 533191 break; 355 case OP_METHOD_NAMED: 356 case OP_CONST: 357 1273570 SvREFCNT_dec(cSVOPo->op_sv); 358 1273570 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 1273570 break; 372 case OP_GOTO: 373 case OP_NEXT: 374 case OP_LAST: 375 case OP_REDO: 376 34124 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS)) 377 26735 break; 378 /* FALL THROUGH */ 379 case OP_TRANS: 380 8706 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) { 381 ###### SvREFCNT_dec(cSVOPo->op_sv); 382 ###### cSVOPo->op_sv = Nullsv; 383 } 384 else { 385 8706 Safefree(cPVOPo->op_pv); 386 8706 cPVOPo->op_pv = Nullch; 387 } 388 8706 break; 389 case OP_SUBST: 390 24068 op_free(cPMOPo->op_pmreplroot); 391 24068 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 4498 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot); 401 #endif 402 /* FALL THROUGH */ 403 case OP_MATCH: 404 case OP_QR: 405 clear_pmop: 406 { 407 70148 HV *pmstash = PmopSTASH(cPMOPo); 408 70148 if (pmstash && SvREFCNT(pmstash)) { 409 61277 MAGIC *mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab); 410 61277 if (mg) { 411 61277 PMOP *pmop = (PMOP*) mg->mg_obj; 412 61277 PMOP *lastpmop = NULL; 413 533326 while (pmop) { 414 533326 if (cPMOPo == pmop) { 415 61277 if (lastpmop) 416 51093 lastpmop->op_pmnext = pmop->op_pmnext; 417 else 418 10184 mg->mg_obj = (SV*) pmop->op_pmnext; 419 10184 break; 420 } 421 472049 lastpmop = pmop; 422 472049 pmop = pmop->op_pmnext; 423 } 424 } 425 } 426 PmopSTASH_free(cPMOPo); 427 } 428 70148 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 70148 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo)); 436 70148 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 9545920 break; 446 } 447 448 9545920 if (o->op_targ > 0) { 449 1897618 pad_free(o->op_targ); 450 1897618 o->op_targ = 0; 451 } 452 } 453 454 STATIC void 455 S_cop_free(pTHX_ COP* cop) 456 830221 { 457 830221 Safefree(cop->cop_label); /* FIXME: treaddead ??? */ 458 830221 CopFILE_free(cop); 459 CopSTASH_free(cop); 460 830221 if (! specialWARN(cop->cop_warnings)) 461 182 SvREFCNT_dec(cop->cop_warnings); 462 830221 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 ###### SvREFCNT_dec(cop->cop_io); 471 #endif 472 } 473 } 474 475 void 476 Perl_op_null(pTHX_ OP *o) 477 1070909 { 478 dVAR; 479 1070909 if (o->op_type == OP_NULL) 480 ###### return; 481 1070909 op_clear(o); 482 1070909 o->op_targ = o->op_type; 483 1070909 o->op_type = OP_NULL; 484 1070909 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 3362819 { 508 509 3362819 if (o->op_next) 510 8668 return o->op_next; 511 512 /* establish postfix order */ 513 3354151 if (cUNOPo->op_first) { 514 3341852 register OP *kid; 515 3341852 o->op_next = LINKLIST(cUNOPo->op_first); 516 10381749 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { 517 7039897 if (kid->op_sibling) 518 3698045 kid->op_next = LINKLIST(kid->op_sibling); 519 else 520 3341852 kid->op_next = o; 521 } 522 } 523 else 524 12299 o->op_next = o; 525 526 3354151 return o->op_next; 527 } 528 529 OP * 530 Perl_scalarkids(pTHX_ OP *o) 531 1655 { 532 1655 if (o && o->op_flags & OPf_KIDS) { 533 1655 OP *kid; 534 3868 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 535 2213 scalar(kid); 536 } 537 1655 return o; 538 } 539 540 STATIC OP * 541 S_scalarboolean(pTHX_ OP *o) 542 343036 { 543 343036 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) { 544 ###### if (ckWARN(WARN_SYNTAX)) { 545 ###### const line_t oldline = CopLINE(PL_curcop); 546 547 ###### if (PL_copline != NOLINE) 548 ###### CopLINE_set(PL_curcop, PL_copline); 549 ###### Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be =="); 550 ###### CopLINE_set(PL_curcop, oldline); 551 } 552 } 553 343036 return scalar(o); 554 } 555 556 OP * 557 Perl_scalar(pTHX_ OP *o) 558 11559336 { 559 dVAR; 560 11559336 OP *kid; 561 562 /* assumes no premature commitment */ 563 11559336 if (!o || (o->op_flags & OPf_WANT) || PL_error_count 564 || o->op_type == OP_RETURN) 565 { 566 6093061 return o; 567 } 568 569 5466275 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR; 570 571 5466275 switch (o->op_type) { 572 case OP_REPEAT: 573 286 scalar(cBINOPo->op_first); 574 286 break; 575 case OP_OR: 576 case OP_AND: 577 case OP_COND_EXPR: 578 187706 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) 579 101502 scalar(kid); 580 ###### break; 581 case OP_SPLIT: 582 ###### if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) { 583 ###### if (!kPMOP->op_pmreplroot) 584 ###### 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 5314387 if (o->op_flags & OPf_KIDS) { 593 5164742 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) 594 3182697 scalar(kid); 595 } 596 3174 break; 597 case OP_LEAVE: 598 case OP_LEAVETRY: 599 3174 kid = cLISTOPo->op_first; 600 3174 scalar(kid); 601 12376 while ((kid = kid->op_sibling)) { 602 9202 if (kid->op_sibling) 603 6028 scalarvoid(kid); 604 else 605 3174 scalar(kid); 606 } 607 3174 WITH_THR(PL_curcop = &PL_compiling); 608 3174 break; 609 case OP_SCOPE: 610 case OP_LINESEQ: 611 case OP_LIST: 612 419064 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { 613 356840 if (kid->op_sibling) 614 294616 scalarvoid(kid); 615 else 616 62224 scalar(kid); 617 } 618 62224 WITH_THR(PL_curcop = &PL_compiling); 619 62224 break; 620 case OP_SORT: 621 ###### if (ckWARN(WARN_VOID)) 622 ###### Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context"); 623 } 624 5466275 return o; 625 } 626 627 OP * 628 Perl_scalarvoid(pTHX_ OP *o) 629 3595521 { 630 dVAR; 631 3595521 OP *kid; 632 3595521 const char* useless = 0; 633 3595521 SV* sv; 634 3595521 U8 want; 635 636 3595521 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 1632354 PL_curcop = (COP*)o; /* for warning below */ 643 644 /* assumes no premature commitment */ 645 3595521 want = o->op_flags & OPf_WANT; 646 3595521 if ((want && want != OPf_WANT_SCALAR) || PL_error_count 647 || o->op_type == OP_RETURN) 648 { 649 1387323 return o; 650 } 651 652 2208198 if ((o->op_private & OPpTARGET_MY) 653 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */ 654 { 655 9982 return scalar(o); /* As if inside SASSIGN */ 656 } 657 658 2198216 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID; 659 660 2198216 switch (o->op_type) { 661 default: 662 493868 if (!(PL_opargs[o->op_type] & OA_FOLDCONST)) 663 475021 break; 664 /* FALL THROUGH */ 665 case OP_REPEAT: 666 18847 if (o->op_flags & OPf_STACKED) 667 18847 break; 668 ###### goto func_ops; 669 case OP_SUBSTR: 670 ###### if (o->op_private == 4) 671 ###### 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 40460 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO))) 743 ###### useless = OP_DESC(o); 744 ###### break; 745 746 case OP_NOT: 747 ###### kid = cUNOPo->op_first; 748 ###### if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST && 749 kid->op_type != OP_TRANS) { 750 ###### 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 17489 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) && 760 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE)) 761 ###### useless = "a variable"; 762 ###### break; 763 764 case OP_CONST: 765 143 sv = cSVOPo_sv; 766 143 if (cSVOPo->op_private & OPpCONST_STRICT) 767 ###### no_bareword_allowed(o); 768 else { 769 143 if (ckWARN(WARN_VOID)) { 770 59 useless = "a constant"; 771 /* don't warn on optimised away booleans, eg 772 * use constant Foo, 5; Foo || print; */ 773 59 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT) 774 1 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 58 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0)) 779 58 useless = 0; 780 ###### 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 ###### 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 143 op_null(o); /* don't execute or even remember it */ 795 143 break; 796 797 case OP_POSTINC: 798 3860 o->op_type = OP_PREINC; /* pre-increment is faster */ 799 3860 o->op_ppaddr = PL_ppaddr[OP_PREINC]; 800 3860 break; 801 802 case OP_POSTDEC: 803 57 o->op_type = OP_PREDEC; /* pre-decrement is faster */ 804 57 o->op_ppaddr = PL_ppaddr[OP_PREDEC]; 805 57 break; 806 807 case OP_OR: 808 case OP_AND: 809 case OP_DOR: 810 case OP_COND_EXPR: 811 500899 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) 812 272583 scalarvoid(kid); 813 239033 break; 814 815 case OP_NULL: 816 239033 if (o->op_flags & OPf_STACKED) 817 1144 break; 818 /* FALL THROUGH */ 819 case OP_NEXTSTATE: 820 case OP_DBSTATE: 821 case OP_ENTERTRY: 822 case OP_ENTER: 823 1146787 if (!(o->op_flags & OPf_KIDS)) 824 908898 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 1557553 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 833 1122992 scalarvoid(kid); 834 1376 break; 835 case OP_ENTEREVAL: 836 1376 scalarkids(o); 837 1376 break; 838 case OP_REQUIRE: 839 /* all requires must return a boolean value */ 840 68040 o->op_flags &= ~OPf_WANT; 841 /* FALL THROUGH */ 842 case OP_SCALAR: 843 68040 return scalar(o); 844 case OP_SPLIT: 845 4 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) { 846 4 if (!kPMOP->op_pmreplroot) 847 1 deprecate_old("implicit split to @_"); 848 } 849 2130176 break; 850 } 851 2130176 if (useless && ckWARN(WARN_VOID)) 852 ###### Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless); 853 2130176 return o; 854 } 855 856 OP * 857 Perl_listkids(pTHX_ OP *o) 858 1000802 { 859 1000802 if (o && o->op_flags & OPf_KIDS) { 860 1000802 OP *kid; 861 3095875 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 862 2095073 list(kid); 863 } 864 1000802 return o; 865 } 866 867 OP * 868 Perl_list(pTHX_ OP *o) 869 2558464 { 870 dVAR; 871 2558464 OP *kid; 872 873 /* assumes no premature commitment */ 874 2558464 if (!o || (o->op_flags & OPf_WANT) || PL_error_count 875 || o->op_type == OP_RETURN) 876 { 877 1820523 return o; 878 } 879 880 737941 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 737941 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST; 887 888 737941 switch (o->op_type) { 889 case OP_FLOP: 890 case OP_REPEAT: 891 1796 list(cBINOPo->op_first); 892 1796 break; 893 case OP_OR: 894 case OP_AND: 895 case OP_COND_EXPR: 896 15451 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) 897 10081 list(kid); 898 719009 break; 899 default: 900 case OP_MATCH: 901 case OP_QR: 902 case OP_SUBST: 903 case OP_NULL: 904 719009 if (!(o->op_flags & OPf_KIDS)) 905 236331 break; 906 482678 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) { 907 178 list(cBINOPo->op_first); 908 178 return gen_constant_list(o); 909 } 910 case OP_LIST: 911 489519 listkids(o); 912 489519 break; 913 case OP_LEAVE: 914 case OP_LEAVETRY: 915 2291 kid = cLISTOPo->op_first; 916 2291 list(kid); 917 8151 while ((kid = kid->op_sibling)) { 918 5860 if (kid->op_sibling) 919 3569 scalarvoid(kid); 920 else 921 2291 list(kid); 922 } 923 2291 WITH_THR(PL_curcop = &PL_compiling); 924 2291 break; 925 case OP_SCOPE: 926 case OP_LINESEQ: 927 7368 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { 928 4912 if (kid->op_sibling) 929 2456 scalarvoid(kid); 930 else 931 2456 list(kid); 932 } 933 2456 WITH_THR(PL_curcop = &PL_compiling); 934 2456 break; 935 case OP_REQUIRE: 936 /* all requires must return a boolean value */ 937 ###### o->op_flags &= ~OPf_WANT; 938 ###### return scalar(o); 939 } 940 737763 return o; 941 } 942 943 OP * 944 Perl_scalarseq(pTHX_ OP *o) 945 463400 { 946 463400 if (o) { 947 461737 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 379131 OP *kid; 953 2649869 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { 954 2270738 if (kid->op_sibling) { 955 1891607 scalarvoid(kid); 956 } 957 } 958 379131 PL_curcop = &PL_compiling; 959 } 960 461737 o->op_flags &= ~OPf_PARENS; 961 461737 if (PL_hints & HINT_BLOCK_SCOPE) 962 364000 o->op_flags |= OPf_PARENS; 963 } 964 else 965 1663 o = newOP(OP_STUB, 0); 966 463400 return o; 967 } 968 969 STATIC OP * 970 S_modkids(pTHX_ OP *o, I32 type) 971 86753 { 972 86753 if (o && o->op_flags & OPf_KIDS) { 973 80499 OP *kid; 974 160998 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 975 80499 mod(kid, type); 976 } 977 86753 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 1049380 { 994 dVAR; 995 1049380 OP *kid; 996 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */ 997 1049380 int localize = -1; 998 999 1049380 if (!o || PL_error_count) 1000 34 return o; 1001 1002 1049346 if ((o->op_private & OPpTARGET_MY) 1003 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */ 1004 { 1005 42 return o; 1006 } 1007 1008 1049304 switch (o->op_type) { 1009 case OP_UNDEF: 1010 978 localize = 0; 1011 978 PL_modcount++; 1012 978 return o; 1013 case OP_CONST: 1014 88811 if (!(o->op_private & (OPpCONST_ARYBASE))) 1015 88811 goto nomod; 1016 ###### if (PL_eval_start && PL_eval_start->op_type == OP_CONST) { 1017 ###### PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv); 1018 ###### PL_eval_start = 0; 1019 } 1020 ###### else if (!type) { 1021 ###### SAVEI32(PL_compiling.cop_arybase); 1022 ###### PL_compiling.cop_arybase = 0; 1023 } 1024 ###### else if (type == OP_REFGEN) 1025 ###### goto nomod; 1026 else 1027 ###### Perl_croak(aTHX_ "That use of $[ is unsupported"); 1028 622 break; 1029 case OP_STUB: 1030 622 if (o->op_flags & OPf_PARENS) 1031 622 break; 1032 20076 goto nomod; 1033 case OP_ENTERSUB: 1034 20076 if ((type == OP_UNDEF || type == OP_REFGEN) && 1035 !(o->op_flags & OPf_STACKED)) { 1036 17027 o->op_type = OP_RV2CV; /* entersub => rv2cv */ 1037 17027 o->op_ppaddr = PL_ppaddr[OP_RV2CV]; 1038 17027 assert(cUNOPo->op_first->op_type == OP_NULL); 1039 17027 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */ 1040 17027 break; 1041 } 1042 3049 else if (o->op_private & OPpENTERSUB_NOMOD) 1043 ###### return o; 1044 else { /* lvalue subroutine call */ 1045 3049 o->op_private |= OPpLVAL_INTRO; 1046 3049 PL_modcount = RETURN_UNLIMITED_NUMBER; 1047 3049 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) { 1048 /* Backward compatibility mode: */ 1049 3049 o->op_private |= OPpENTERSUB_INARGS; 1050 3049 break; 1051 } 1052 else { /* Compile-time error message: */ 1053 ###### OP *kid = cUNOPo->op_first; 1054 ###### CV *cv; 1055 ###### OP *okid; 1056 1057 ###### if (kid->op_type == OP_PUSHMARK) 1058 ###### goto skip_kids; 1059 ###### 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 ###### kid = kLISTOP->op_first; 1065 skip_kids: 1066 ###### while (kid->op_sibling) 1067 ###### kid = kid->op_sibling; 1068 ###### if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) { 1069 /* Indirect call */ 1070 ###### if (kid->op_type == OP_METHOD_NAMED 1071 || kid->op_type == OP_METHOD) 1072 { 1073 ###### UNOP *newop; 1074 1075 ###### NewOp(1101, newop, 1, UNOP); 1076 ###### newop->op_type = OP_RV2CV; 1077 ###### newop->op_ppaddr = PL_ppaddr[OP_RV2CV]; 1078 ###### newop->op_first = Nullop; 1079 ###### newop->op_next = (OP*)newop; 1080 ###### kid->op_sibling = (OP*)newop; 1081 ###### newop->op_private |= OPpLVAL_INTRO; 1082 ###### 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 ###### okid = kid; 1095 ###### kid = kUNOP->op_first; 1096 ###### if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV) 1097 ###### kid = kUNOP->op_first; 1098 ###### 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 ###### if (kid->op_type != OP_GV) { 1104 /* Restore RV2CV to check lvalueness */ 1105 restore_2cv: 1106 ###### 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 ###### okid->op_next = Nullop; 1112 ###### okid->op_type = OP_RV2CV; 1113 ###### okid->op_targ = 0; 1114 ###### okid->op_ppaddr = PL_ppaddr[OP_RV2CV]; 1115 ###### okid->op_private |= OPpLVAL_INTRO; 1116 ###### break; 1117 } 1118 1119 ###### cv = GvCV(kGVOP_gv); 1120 ###### if (!cv) 1121 ###### goto restore_2cv; 1122 ###### if (CvLVALUE(cv)) 1123 ###### break; 1124 } 1125 } 1126 /* FALL THROUGH */ 1127 default: 1128 nomod: 1129 /* grep, foreach, subcalls, refgen */ 1130 166892 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) 1131 ###### break; 1132 ###### 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 ###### 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 2599 if (!(o->op_flags & OPf_STACKED)) 1162 1491 goto nomod; 1163 1108 PL_modcount++; 1164 1108 break; 1165 1166 case OP_COND_EXPR: 1167 1395 localize = 1; 1168 4185 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) 1169 2790 mod(kid, type); 1170 110130 break; 1171 1172 case OP_RV2AV: 1173 case OP_RV2HV: 1174 110130 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) { 1175 50 PL_modcount = RETURN_UNLIMITED_NUMBER; 1176 50 return o; /* Treat \(@foo) like ordinary list. */ 1177 } 1178 /* FALL THROUGH */ 1179 case OP_RV2GV: 1180 128856 if (scalar_mod_type(o, type)) 1181 ###### goto nomod; 1182 128856 ref(cUNOPo->op_first, o->op_type); 1183 /* FALL THROUGH */ 1184 case OP_ASLICE: 1185 case OP_HSLICE: 1186 131366 if (type == OP_LEAVESUBLV) 1187 ###### o->op_private |= OPpMAYBE_LVSUB; 1188 131366 localize = 1; 1189 /* FALL THROUGH */ 1190 case OP_AASSIGN: 1191 case OP_NEXTSTATE: 1192 case OP_DBSTATE: 1193 131392 PL_modcount = RETURN_UNLIMITED_NUMBER; 1194 131392 break; 1195 case OP_RV2SV: 1196 76120 ref(cUNOPo->op_first, o->op_type); 1197 76120 localize = 1; 1198 /* FALL THROUGH */ 1199 case OP_GV: 1200 case OP_AV2ARYLEN: 1201 76282 PL_hints |= HINT_BLOCK_SCOPE; 1202 case OP_SASSIGN: 1203 case OP_ANDASSIGN: 1204 case OP_ORASSIGN: 1205 case OP_DORASSIGN: 1206 78282 PL_modcount++; 1207 78282 break; 1208 1209 case OP_AELEMFAST: 1210 ###### localize = -1; 1211 ###### PL_modcount++; 1212 ###### break; 1213 1214 case OP_PADAV: 1215 case OP_PADHV: 1216 57896 PL_modcount = RETURN_UNLIMITED_NUMBER; 1217 57896 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) 1218 ###### return o; /* Treat \(@foo) like ordinary list. */ 1219 57896 if (scalar_mod_type(o, type)) 1220 ###### goto nomod; 1221 57896 if (type == OP_LEAVESUBLV) 1222 ###### o->op_private |= OPpMAYBE_LVSUB; 1223 /* FALL THROUGH */ 1224 case OP_PADSV: 1225 408712 PL_modcount++; 1226 408712 if (!type) /* local() */ 1227 ###### Perl_croak(aTHX_ "Can't localize lexical variable %s", 1228 PAD_COMPNAME_PV(o->op_targ)); 1229 97343 break; 1230 1231 case OP_PUSHMARK: 1232 97343 localize = 0; 1233 97343 break; 1234 1235 case OP_KEYS: 1236 1867 if (type != OP_SASSIGN) 1237 1867 goto nomod; 1238 482 goto lvalue_func; 1239 case OP_SUBSTR: 1240 482 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */ 1241 ###### goto nomod; 1242 /* FALL THROUGH */ 1243 case OP_POS: 1244 case OP_VEC: 1245 2886 if (type == OP_LEAVESUBLV) 1246 ###### o->op_private |= OPpMAYBE_LVSUB; 1247 lvalue_func: 1248 2886 pad_free(o->op_targ); 1249 2886 o->op_targ = pad_alloc(o->op_type, SVs_PADMY); 1250 2886 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL); 1251 2886 if (o->op_flags & OPf_KIDS) 1252 2886 mod(cBINOPo->op_first->op_sibling, type); 1253 2886 break; 1254 1255 case OP_AELEM: 1256 case OP_HELEM: 1257 40722 ref(cBINOPo->op_first, o->op_type); 1258 40722 if (type == OP_ENTERSUB && 1259 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF))) 1260 4894 o->op_private |= OPpLVAL_DEFER; 1261 40722 if (type == OP_LEAVESUBLV) 1262 ###### o->op_private |= OPpMAYBE_LVSUB; 1263 40722 localize = 1; 1264 40722 PL_modcount++; 1265 40722 break; 1266 1267 case OP_SCOPE: 1268 case OP_LEAVE: 1269 case OP_ENTER: 1270 case OP_LINESEQ: 1271 ###### localize = 0; 1272 ###### if (o->op_flags & OPf_KIDS) 1273 ###### mod(cLISTOPo->op_last, type); 1274 ###### break; 1275 1276 case OP_NULL: 1277 66620 localize = 0; 1278 66620 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */ 1279 1320 goto nomod; 1280 65300 else if (!(o->op_flags & OPf_KIDS)) 1281 ###### break; 1282 65300 if (o->op_targ != OP_LIST) { 1283 1503 mod(cBINOPo->op_first, type); 1284 1503 break; 1285 } 1286 /* FALL THROUGH */ 1287 case OP_LIST: 1288 97343 localize = 0; 1289 351236 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 1290 253893 mod(kid, type); 1291 ###### break; 1292 1293 case OP_RETURN: 1294 ###### if (type != OP_LEAVESUBLV) 1295 ###### goto nomod; 1296 1048276 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 1048276 if (type == OP_REFGEN && 1303 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)) 1304 ###### return o; 1305 1306 1048276 if (type != OP_LEAVESUBLV) 1307 1048276 o->op_flags |= OPf_MOD; 1308 1309 1048276 if (type == OP_AASSIGN || type == OP_SASSIGN) 1310 400656 o->op_flags |= OPf_SPECIAL|OPf_REF; 1311 647620 else if (!type) { /* local() */ 1312 21888 switch (localize) { 1313 case 1: 1314 17736 o->op_private |= OPpLVAL_INTRO; 1315 17736 o->op_flags &= ~OPf_SPECIAL; 1316 17736 PL_hints |= HINT_BLOCK_SCOPE; 1317 17736 break; 1318 case 0: 1319 ###### break; 1320 case -1: 1321 ###### if (ckWARN(WARN_SYNTAX)) { 1322 ###### Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 1323 "Useless localization of %s", OP_DESC(o)); 1324 } 1325 } 1326 } 1327 625732 else if (type != OP_GREPSTART && type != OP_ENTERSUB 1328 && type != OP_LEAVESUBLV) 1329 329440 o->op_flags |= OPf_REF; 1330 1048276 return o; 1331 } 1332 1333 STATIC bool 1334 S_scalar_mod_type(pTHX_ const OP *o, I32 type) 1335 186752 { 1336 186752 switch (type) { 1337 case OP_SASSIGN: 1338 12780 if (o->op_type == OP_RV2GV) 1339 12780 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 ###### return TRUE; 1375 default: 1376 173972 return FALSE; 1377 } 1378 } 1379 1380 STATIC bool 1381 S_is_handle_constructor(pTHX_ const OP *o, I32 numargs) 1382 6242 { 1383 6242 switch (o->op_type) { 1384 case OP_PIPE_OP: 1385 case OP_SOCKPAIR: 1386 ###### if (numargs == 2) 1387 ###### 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 1856 if (numargs == 1) 1396 1856 return TRUE; 1397 /* FALL THROUGH */ 1398 default: 1399 4386 return FALSE; 1400 } 1401 } 1402 1403 OP * 1404 Perl_refkids(pTHX_ OP *o, I32 type) 1405 35094 { 1406 35094 if (o && o->op_flags & OPf_KIDS) { 1407 35094 OP *kid; 1408 70188 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 1409 35094 ref(kid, type); 1410 } 1411 35094 return o; 1412 } 1413 1414 OP * 1415 Perl_ref(pTHX_ OP *o, I32 type) 1416 699988 { 1417 dVAR; 1418 699988 OP *kid; 1419 1420 699988 if (!o || PL_error_count) 1421 ###### return o; 1422 1423 699988 switch (o->op_type) { 1424 case OP_ENTERSUB: 1425 4634 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) && 1426 !(o->op_flags & OPf_STACKED)) { 1427 4466 o->op_type = OP_RV2CV; /* entersub => rv2cv */ 1428 4466 o->op_ppaddr = PL_ppaddr[OP_RV2CV]; 1429 4466 assert(cUNOPo->op_first->op_type == OP_NULL); 1430 4466 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */ 1431 4466 o->op_flags |= OPf_SPECIAL; 1432 } 1433 4466 break; 1434 1435 case OP_COND_EXPR: 1436 ###### for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) 1437 ###### ref(kid, type); 1438 4650 break; 1439 case OP_RV2SV: 1440 4650 if (type == OP_DEFINED) 1441 4217 o->op_flags |= OPf_SPECIAL; /* don't create GV */ 1442 4650 ref(cUNOPo->op_first, o->op_type); 1443 /* FALL THROUGH */ 1444 case OP_PADSV: 1445 107892 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) { 1446 76385 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV 1447 : type == OP_RV2HV ? OPpDEREF_HV 1448 : OPpDEREF_SV); 1449 76385 o->op_flags |= OPf_MOD; 1450 } 1451 76385 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 165181 o->op_flags |= OPf_REF; 1460 /* FALL THROUGH */ 1461 case OP_RV2GV: 1462 192014 if (type == OP_DEFINED) 1463 ###### o->op_flags |= OPf_SPECIAL; /* don't create GV */ 1464 192014 ref(cUNOPo->op_first, o->op_type); 1465 192014 break; 1466 1467 case OP_PADAV: 1468 case OP_PADHV: 1469 46766 o->op_flags |= OPf_REF; 1470 46766 break; 1471 1472 case OP_SCALAR: 1473 case OP_NULL: 1474 2675 if (!(o->op_flags & OPf_KIDS)) 1475 ###### break; 1476 2675 ref(cBINOPo->op_first, type); 1477 2675 break; 1478 case OP_AELEM: 1479 case OP_HELEM: 1480 15843 ref(cBINOPo->op_first, o->op_type); 1481 15843 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) { 1482 11097 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV 1483 : type == OP_RV2HV ? OPpDEREF_HV 1484 : OPpDEREF_SV); 1485 11097 o->op_flags |= OPf_MOD; 1486 } 1487 11097 break; 1488 1489 case OP_SCOPE: 1490 case OP_LEAVE: 1491 case OP_ENTER: 1492 case OP_LIST: 1493 21800 if (!(o->op_flags & OPf_KIDS)) 1494 ###### break; 1495 21800 ref(cLISTOPo->op_last, type); 1496 break; 1497 default: 1498 699988 break; 1499 } 1500 699988 return scalar(o); 1501 1502 } 1503 1504 STATIC OP * 1505 S_dup_attrlist(pTHX_ OP *o) 1506 ###### { 1507 ###### 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 ###### if (o->op_type == OP_CONST) 1514 ###### rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv)); 1515 else { 1516 ###### assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS)); 1517 ###### for (o = cLISTOPo->op_first; o; o=o->op_sibling) { 1518 ###### if (o->op_type == OP_CONST) 1519 ###### rop = append_elem(OP_LIST, rop, 1520 newSVOP(OP_CONST, o->op_flags, 1521 ###### SvREFCNT_inc(cSVOPo->op_sv))); 1522 } 1523 } 1524 ###### return rop; 1525 } 1526 1527 STATIC void 1528 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my) 1529 ###### { 1530 dVAR; 1531 ###### SV *stashsv; 1532 1533 /* fake up C */ 1534 ###### ENTER; /* need to protect against side-effects of 'use' */ 1535 ###### SAVEINT(PL_expect); 1536 ###### stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no; 1537 1538 #define ATTRSMODULE "attributes" 1539 #define ATTRSMODULE_PM "attributes.pm" 1540 1541 ###### if (for_my) { 1542 /* Don't force the C if we don't need it. */ 1543 ###### SV **svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM, 1544 ###### sizeof(ATTRSMODULE_PM)-1, 0); 1545 ###### 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 ###### 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 ###### LEAVE; 1564 } 1565 1566 STATIC void 1567 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) 1568 ###### { 1569 ###### OP *pack, *imop, *arg; 1570 ###### SV *meth, *stashsv; 1571 1572 ###### if (!attrs) 1573 ###### return; 1574 1575 assert(target->op_type == OP_PADSV || 1576 target->op_type == OP_PADHV || 1577 ###### target->op_type == OP_PADAV); 1578 1579 /* Ensure that attributes.pm is loaded. */ 1580 ###### apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE); 1581 1582 /* Need package name for method call. */ 1583 ###### pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1)); 1584 1585 /* Build up the real arg-list. */ 1586 ###### stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no; 1587 1588 ###### arg = newOP(OP_PADSV, 0); 1589 ###### arg->op_targ = target->op_targ; 1590 ###### 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 ###### meth = newSVpvn_share("import", 6, 0); 1599 ###### 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 ###### imop->op_private |= OPpENTERSUB_NOMOD; 1604 1605 /* Combine the ops. */ 1606 ###### *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 270223 { 1660 270223 I32 type; 1661 1662 270223 if (!o || PL_error_count) 1663 ###### return o; 1664 1665 270223 type = o->op_type; 1666 270223 if (type == OP_LIST) { 1667 27829 OP *kid; 1668 136613 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 1669 108784 my_kid(kid, attrs, imopsp); 1670 242394 } else if (type == OP_UNDEF) { 1671 ###### return o; 1672 242394 } else if (type == OP_RV2SV || /* "our" declaration */ 1673 type == OP_RV2AV || 1674 type == OP_RV2HV) { /* XXX does this let anything illegal in? */ 1675 22158 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */ 1676 ###### yyerror(Perl_form(aTHX_ "Can't declare %s in %s", 1677 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my")); 1678 22158 } else if (attrs) { 1679 ###### GV *gv = cGVOPx_gv(cUNOPo->op_first); 1680 ###### PL_in_my = FALSE; 1681 ###### PL_in_my_stash = Nullhv; 1682 ###### 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 22158 o->op_private |= OPpOUR_INTRO; 1689 22158 return o; 1690 } 1691 220236 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 220236 else if (attrs && type != OP_PUSHMARK) { 1702 ###### HV *stash; 1703 1704 ###### PL_in_my = FALSE; 1705 ###### PL_in_my_stash = Nullhv; 1706 1707 /* check for C when deciding package */ 1708 ###### stash = PAD_COMPNAME_TYPE(o->op_targ); 1709 ###### if (!stash) 1710 ###### stash = PL_curstash; 1711 ###### apply_attrs_my(stash, o, attrs, imopsp); 1712 } 1713 248065 o->op_flags |= OPf_MOD; 1714 248065 o->op_private |= OPpLVAL_INTRO; 1715 248065 return o; 1716 } 1717 1718 OP * 1719 Perl_my_attrs(pTHX_ OP *o, OP *attrs) 1720 161439 { 1721 161439 OP *rops = Nullop; 1722 161439 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 161439 maybe_scalar = 1; 1733 #endif 1734 161439 if (attrs) 1735 ###### SAVEFREEOP(attrs); 1736 161439 o = my_kid(o, attrs, &rops); 1737 161439 if (rops) { 1738 ###### if (maybe_scalar && o->op_type == OP_PADSV) { 1739 ###### o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o)); 1740 ###### o->op_private |= OPpLVAL_INTRO; 1741 } 1742 else 1743 ###### o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops); 1744 } 1745 161439 PL_in_my = FALSE; 1746 161439 PL_in_my_stash = Nullhv; 1747 161439 return o; 1748 } 1749 1750 OP * 1751 Perl_my(pTHX_ OP *o) 1752 161195 { 1753 161195 return my_attrs(o, Nullop); 1754 } 1755 1756 OP * 1757 Perl_sawparens(pTHX_ OP *o) 1758 144576 { 1759 144576 if (o) 1760 144576 o->op_flags |= OPf_PARENS; 1761 144576 return o; 1762 } 1763 1764 OP * 1765 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) 1766 54734 { 1767 54734 OP *o; 1768 54734 bool ismatchop = 0; 1769 1770 54734 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 ###### const char *desc = PL_op_desc[(right->op_type == OP_SUBST || 1776 right->op_type == OP_TRANS) 1777 ###### ? right->op_type : OP_MATCH]; 1778 ###### const char *sample = ((left->op_type == OP_RV2AV || 1779 left->op_type == OP_PADAV) 1780 ###### ? "@array" : "%hash"); 1781 ###### Perl_warner(aTHX_ packWARN(WARN_MISC), 1782 "Applying %s to %s will act on scalar(%s)", 1783 desc, sample, sample); 1784 } 1785 1786 54734 if (right->op_type == OP_CONST && 1787 cSVOPx(right)->op_private & OPpCONST_BARE && 1788 cSVOPx(right)->op_private & OPpCONST_STRICT) 1789 { 1790 ###### no_bareword_allowed(right); 1791 } 1792 1793 54734 ismatchop = right->op_type == OP_MATCH || 1794 right->op_type == OP_SUBST || 1795 right->op_type == OP_TRANS; 1796 54734 if (ismatchop && right->op_private & OPpTARGET_MY) { 1797 ###### right->op_targ = 0; 1798 ###### right->op_private &= ~OPpTARGET_MY; 1799 } 1800 54734 if (!(right->op_flags & OPf_STACKED) && ismatchop) { 1801 54521 right->op_flags |= OPf_STACKED; 1802 54521 if (right->op_type != OP_MATCH && 1803 ! (right->op_type == OP_TRANS && 1804 right->op_private & OPpTRANS_IDENTICAL)) 1805 21947 left = mod(left, right->op_type); 1806 54521 if (right->op_type == OP_TRANS) 1807 1294 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right); 1808 else 1809 53227 o = prepend_elem(right->op_type, scalar(left), right); 1810 54521 if (type == OP_NOT) 1811 3580 return newUNOP(OP_NOT, 0, scalar(o)); 1812 50941 return o; 1813 } 1814 else 1815 213 return bind_match(type, left, 1816 pmruntime(newPMOP(OP_MATCH, 0), right, 0)); 1817 } 1818 1819 OP * 1820 Perl_invert(pTHX_ OP *o) 1821 11678 { 1822 11678 if (!o) 1823 ###### return o; 1824 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */ 1825 11678 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o)); 1826 } 1827 1828 OP * 1829 Perl_scope(pTHX_ OP *o) 1830 163890 { 1831 dVAR; 1832 163890 if (o) { 1833 163890 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) { 1834 110017 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o); 1835 110017 o->op_type = OP_LEAVE; 1836 110017 o->op_ppaddr = PL_ppaddr[OP_LEAVE]; 1837 } 1838 53873 else if (o->op_type == OP_LINESEQ) { 1839 53355 OP *kid; 1840 53355 o->op_type = OP_SCOPE; 1841 53355 o->op_ppaddr = PL_ppaddr[OP_SCOPE]; 1842 53355 kid = ((LISTOP*)o)->op_first; 1843 53355 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) 1844 53355 op_null(kid); 1845 } 1846 else 1847 518 o = newLISTOP(OP_SCOPE, 0, o, Nullop); 1848 } 1849 163890 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 375974 { 1862 375974 const int retval = PL_savestack_ix; 1863 375974 pad_block_start(full); 1864 375974 SAVEHINTS(); 1865 375974 PL_hints &= ~HINT_BLOCK_SCOPE; 1866 375974 SAVESPTR(PL_compiling.cop_warnings); 1867 375974 if (! specialWARN(PL_compiling.cop_warnings)) { 1868 ###### PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ; 1869 ###### SAVEFREESV(PL_compiling.cop_warnings) ; 1870 } 1871 375974 SAVESPTR(PL_compiling.cop_io); 1872 375974 if (! specialCopIO(PL_compiling.cop_io)) { 1873 ###### PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ; 1874 ###### SAVEFREESV(PL_compiling.cop_io) ; 1875 } 1876 375974 return retval; 1877 } 1878 1879 OP* 1880 Perl_block_end(pTHX_ I32 floor, OP *seq) 1881 375974 { 1882 375974 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE; 1883 375974 OP* retval = scalarseq(seq); 1884 375974 LEAVE_SCOPE(floor); 1885 375974 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); 1886 375974 if (needblockscope) 1887 280509 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */ 1888 375974 pad_leavemy(); 1889 375974 return retval; 1890 } 1891 1892 STATIC OP * 1893 S_newDEFSVOP(pTHX) 1894 3170 { 1895 3170 const I32 offset = pad_findmy("$_"); 1896 3170 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) { 1897 3170 return newSVREF(newGVOP(OP_GV, 0, PL_defgv)); 1898 } 1899 else { 1900 ###### OP *o = newOP(OP_PADSV, 0); 1901 ###### o->op_targ = offset; 1902 ###### return o; 1903 } 1904 } 1905 1906 void 1907 Perl_newPROG(pTHX_ OP *o) 1908 12652 { 1909 12652 if (PL_in_eval) { 1910 12087 if (PL_eval_root) 1911 ###### return; 1912 12087 PL_eval_root = newUNOP(OP_LEAVEEVAL, 1913 ((PL_in_eval & EVAL_KEEPERR) 1914 ? OPf_SPECIAL : 0), o); 1915 12087 PL_eval_start = linklist(PL_eval_root); 1916 12087 PL_eval_root->op_private |= OPpREFCOUNTED; 1917 12087 OpREFCNT_set(PL_eval_root, 1); 1918 12087 PL_eval_root->op_next = 0; 1919 12087 CALL_PEEP(PL_eval_start); 1920 } 1921 else { 1922 565 if (o->op_type == OP_STUB) { 1923 ###### PL_comppad_name = 0; 1924 ###### PL_compcv = 0; 1925 ###### FreeOp(o); 1926 ###### return; 1927 } 1928 565 PL_main_root = scope(sawparens(scalarvoid(o))); 1929 565 PL_curcop = &PL_compiling; 1930 565 PL_main_start = LINKLIST(PL_main_root); 1931 565 PL_main_root->op_private |= OPpREFCOUNTED; 1932 565 OpREFCNT_set(PL_main_root, 1); 1933 565 PL_main_root->op_next = 0; 1934 565 CALL_PEEP(PL_main_start); 1935 565 PL_compcv = 0; 1936 1937 /* Register with debugger */ 1938 565 if (PERLDB_INTER) { 1939 ###### CV *cv = get_cv("DB::postponed", FALSE); 1940 ###### 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 165209 { 1954 165209 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 119493 if (ckWARN(WARN_PARENTHESIS) 1964 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') 1965 { 1966 447 char *s = PL_bufptr; 1967 447 bool sigil = FALSE; 1968 1969 /* some heuristics to detect a potential error */ 1970 894 while (*s && (strchr(", \t\n", *s))) 1971 447 s++; 1972 1973 864 while (1) { 1974 864 if (*s && strchr("@$%*", *s) && *++s 1975 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) { 1976 417 s++; 1977 417 sigil = TRUE; 1978 1616 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) 1979 1199 s++; 1980 469 while (*s && (strchr(", \t\n", *s))) 1981 52 s++; 1982 } 1983 else 1984 447 break; 1985 } 1986 447 if (sigil && (*s == ';' || *s == '=')) { 1987 ###### 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 165209 if (lex) 1995 151133 o = my(o); 1996 else 1997 14076 o = mod(o, OP_NULL); /* a bit kludgey */ 1998 165209 PL_in_my = FALSE; 1999 165209 PL_in_my_stash = Nullhv; 2000 165209 return o; 2001 } 2002 2003 OP * 2004 Perl_jmaybe(pTHX_ OP *o) 2005 108383 { 2006 108383 if (o->op_type == OP_LIST) { 2007 110 OP *o2; 2008 110 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 108383 return o; 2012 } 2013 2014 OP * 2015 Perl_fold_constants(pTHX_ register OP *o) 2016 2655019 { 2017 dVAR; 2018 2655019 register OP *curop; 2019 2655019 I32 type = o->op_type; 2020 2655019 SV *sv; 2021 2022 2655019 if (PL_opargs[type] & OA_RETSCALAR) 2023 1426746 scalar(o); 2024 2655019 if (PL_opargs[type] & OA_TARGET && !o->op_targ) 2025 945173 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 2655019 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 ###### o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)]; 2034 } 2035 2036 2655019 if (!(PL_opargs[type] & OA_FOLDCONST)) 2037 2126556 goto nope; 2038 2039 528463 switch (type) { 2040 case OP_NEGATE: 2041 /* XXX might want a ck_negate() for this */ 2042 5975 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT; 2043 5975 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 6328 if (PL_hints & HINT_LOCALE) 2056 ###### goto nope; 2057 } 2058 2059 528463 if (PL_error_count) 2060 ###### goto nope; /* Don't try to run w/ errors */ 2061 2062 1009098 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) { 2063 940266 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 459631 goto nope; 2071 } 2072 } 2073 2074 68832 curop = LINKLIST(o); 2075 68832 o->op_next = 0; 2076 68832 PL_op = curop; 2077 68832 CALLRUNOPS(aTHX); 2078 68832 sv = *(PL_stack_sp--); 2079 68832 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */ 2080 68827 pad_swipe(o->op_targ, FALSE); 2081 5 else if (SvTEMP(sv)) { /* grab mortal temp? */ 2082 3 (void)SvREFCNT_inc(sv); 2083 3 SvTEMP_off(sv); 2084 } 2085 68832 op_free(o); 2086 68832 if (type == OP_RV2GV) 2087 ###### return newGVOP(OP_GV, 0, (GV*)sv); 2088 68832 return newSVOP(OP_CONST, 0, sv); 2089 2090 nope: 2091 2586187 return o; 2092 } 2093 2094 OP * 2095 Perl_gen_constant_list(pTHX_ register OP *o) 2096 178 { 2097 dVAR; 2098 178 register OP *curop; 2099 178 const I32 oldtmps_floor = PL_tmps_floor; 2100 2101 178 list(o); 2102 178 if (PL_error_count) 2103 ###### return o; /* Don't attempt to run with errors */ 2104 2105 178 PL_op = curop = LINKLIST(o); 2106 178 o->op_next = 0; 2107 178 CALL_PEEP(curop); 2108 178 pp_pushmark(); 2109 178 CALLRUNOPS(aTHX); 2110 178 PL_op = curop; 2111 178 pp_anonlist(); 2112 178 PL_tmps_floor = oldtmps_floor; 2113 2114 178 o->op_type = OP_RV2AV; 2115 178 o->op_ppaddr = PL_ppaddr[OP_RV2AV]; 2116 178 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */ 2117 178 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */ 2118 178 o->op_opt = 0; /* needs to be revisited in peep() */ 2119 178 curop = ((UNOP*)o)->op_first; 2120 178 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--)); 2121 178 op_free(curop); 2122 178 linklist(o); 2123 178 return list(o); 2124 } 2125 2126 OP * 2127 Perl_convert(pTHX_ I32 type, I32 flags, OP *o) 2128 385869 { 2129 dVAR; 2130 385869 if (!o || o->op_type != OP_LIST) 2131 236677 o = newLISTOP(OP_LIST, 0, o, Nullop); 2132 else 2133 149192 o->op_flags &= ~OPf_WANT; 2134 2135 385869 if (!(PL_opargs[type] & OA_MARK)) 2136 186095 op_null(cLISTOPo->op_first); 2137 2138 385869 o->op_type = (OPCODE)type; 2139 385869 o->op_ppaddr = PL_ppaddr[type]; 2140 385869 o->op_flags |= flags; 2141 2142 385869 o = CHECKOP(type, o); 2143 385869 if (o->op_type != (unsigned)type) 2144 10850 return o; 2145 2146 375019 return fold_constants(o); 2147 } 2148 2149 /* List constructors */ 2150 2151 OP * 2152 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last) 2153 788964 { 2154 788964 if (!first) 2155 42964 return last; 2156 2157 746000 if (!last) 2158 14368 return first; 2159 2160 731632 if (first->op_type != (unsigned)type 2161 || (type == OP_LIST && (first->op_flags & OPf_PARENS))) 2162 { 2163 290619 return newLISTOP(type, 0, first, last); 2164 } 2165 2166 441013 if (first->op_flags & OPf_KIDS) 2167 441013 ((LISTOP*)first)->op_last->op_sibling = last; 2168 else { 2169 ###### first->op_flags |= OPf_KIDS; 2170 ###### ((LISTOP*)first)->op_first = last; 2171 } 2172 441013 ((LISTOP*)first)->op_last = last; 2173 441013 return first; 2174 } 2175 2176 OP * 2177 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last) 2178 1008265 { 2179 1008265 if (!first) 2180 270409 return (OP*)last; 2181 2182 737856 if (!last) 2183 221656 return (OP*)first; 2184 2185 516200 if (first->op_type != (unsigned)type) 2186 4442 return prepend_elem(type, (OP*)first, (OP*)last); 2187 2188 511758 if (last->op_type != (unsigned)type) 2189 22236 return append_elem(type, (OP*)first, (OP*)last); 2190 2191 489522 first->op_last->op_sibling = last->op_first; 2192 489522 first->op_last = last->op_last; 2193 489522 first->op_flags |= (last->op_flags & OPf_KIDS); 2194 2195 489522 FreeOp(last); 2196 2197 489522 return (OP*)first; 2198 } 2199 2200 OP * 2201 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last) 2202 1088130 { 2203 1088130 if (!first) 2204 ###### return last; 2205 2206 1088130 if (!last) 2207 39382 return first; 2208 2209 1048748 if (last->op_type == (unsigned)type) { 2210 211052 if (type == OP_LIST) { /* already a PUSHMARK there */ 2211 15104 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling; 2212 15104 ((LISTOP*)last)->op_first->op_sibling = first; 2213 15104 if (!(first->op_flags & OPf_PARENS)) 2214 15103 last->op_flags &= ~OPf_PARENS; 2215 } 2216 else { 2217 195948 if (!(last->op_flags & OPf_KIDS)) { 2218 57849 ((LISTOP*)last)->op_last = first; 2219 57849 last->op_flags |= OPf_KIDS; 2220 } 2221 195948 first->op_sibling = ((LISTOP*)last)->op_first; 2222 195948 ((LISTOP*)last)->op_first = first; 2223 } 2224 211052 last->op_flags |= OPf_KIDS; 2225 211052 return last; 2226 } 2227 2228 837696 return newLISTOP(type, 0, first, last); 2229 } 2230 2231 /* Constructors */ 2232 2233 OP * 2234 Perl_newNULLLIST(pTHX) 2235 6635 { 2236 6635 return newOP(OP_STUB, 0); 2237 } 2238 2239 OP * 2240 Perl_force_list(pTHX_ OP *o) 2241 353996 { 2242 353996 if (!o || o->op_type != OP_LIST) 2243 229142 o = newLISTOP(OP_LIST, 0, o, Nullop); 2244 353996 op_null(o); 2245 353996 return o; 2246 } 2247 2248 OP * 2249 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) 2250 1598775 { 2251 dVAR; 2252 1598775 LISTOP *listop; 2253 2254 1598775 NewOp(1101, listop, 1, LISTOP); 2255 2256 1598775 listop->op_type = (OPCODE)type; 2257 1598775 listop->op_ppaddr = PL_ppaddr[type]; 2258 1598775 if (first || last) 2259 1590537 flags |= OPf_KIDS; 2260 1598775 listop->op_flags = (U8)flags; 2261 2262 1598775 if (!last && first) 2263 458099 last = first; 2264 1140676 else if (!first && last) 2265 ###### first = last; 2266 1140676 else if (first) 2267 1132438 first->op_sibling = last; 2268 1598775 listop->op_first = first; 2269 1598775 listop->op_last = last; 2270 1598775 if (type == OP_LIST) { 2271 786571 OP* pushop; 2272 786571 pushop = newOP(OP_PUSHMARK, 0); 2273 786571 pushop->op_sibling = first; 2274 786571 listop->op_first = pushop; 2275 786571 listop->op_flags |= OPf_KIDS; 2276 786571 if (!last) 2277 8238 listop->op_last = pushop; 2278 } 2279 2280 1598775 return CHECKOP(type, listop); 2281 } 2282 2283 OP * 2284 Perl_newOP(pTHX_ I32 type, I32 flags) 2285 1943232 { 2286 dVAR; 2287 1943232 OP *o; 2288 1943232 NewOp(1101, o, 1, OP); 2289 1943232 o->op_type = (OPCODE)type; 2290 1943232 o->op_ppaddr = PL_ppaddr[type]; 2291 1943232 o->op_flags = (U8)flags; 2292 2293 1943232 o->op_next = o; 2294 1943232 o->op_private = (U8)(0 | (flags >> 8)); 2295 1943232 if (PL_opargs[type] & OA_RETSCALAR) 2296 866736 scalar(o); 2297 1943232 if (PL_opargs[type] & OA_TARGET) 2298 3237 o->op_targ = pad_alloc(type, SVs_PADTMP); 2299 1943232 return CHECKOP(type, o); 2300 } 2301 2302 OP * 2303 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) 2304 1535278 { 2305 dVAR; 2306 1535278 UNOP *unop; 2307 2308 1535278 if (!first) 2309 ###### first = newOP(OP_STUB, 0); 2310 1535278 if (PL_opargs[type] & OA_MARK) 2311 158462 first = force_list(first); 2312 2313 1535278 NewOp(1101, unop, 1, UNOP); 2314 1535278 unop->op_type = (OPCODE)type; 2315 1535278 unop->op_ppaddr = PL_ppaddr[type]; 2316 1535278 unop->op_first = first; 2317 1535278 unop->op_flags = flags | OPf_KIDS; 2318 1535278 unop->op_private = (U8)(1 | (flags >> 8)); 2319 1535278 unop = (UNOP*) CHECKOP(type, unop); 2320 1535278 if (unop->op_next) 2321 34237 return (OP*)unop; 2322 2323 1501041 return fold_constants((OP *) unop); 2324 } 2325 2326 OP * 2327 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) 2328 787574 { 2329 dVAR; 2330 787574 BINOP *binop; 2331 787574 NewOp(1101, binop, 1, BINOP); 2332 2333 787574 if (!first) 2334 ###### first = newOP(OP_NULL, 0); 2335 2336 787574 binop->op_type = (OPCODE)type; 2337 787574 binop->op_ppaddr = PL_ppaddr[type]; 2338 787574 binop->op_first = first; 2339 787574 binop->op_flags = flags | OPf_KIDS; 2340 787574 if (!last) { 2341 ###### last = first; 2342 ###### binop->op_private = (U8)(1 | (flags >> 8)); 2343 } 2344 else { 2345 787574 binop->op_private = (U8)(2 | (flags >> 8)); 2346 787574 first->op_sibling = last; 2347 } 2348 2349 787574 binop = (BINOP*)CHECKOP(type, binop); 2350 787574 if (binop->op_next || binop->op_type != (OPCODE)type) 2351 8615 return (OP*)binop; 2352 2353 778959 binop->op_last = binop->op_first->op_sibling; 2354 2355 778959 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 ###### { 2361 ###### if (*((const UV *)a) < (*(const UV *)b)) 2362 ###### 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 1317 { 2375 1317 SV *tstr = ((SVOP*)expr)->op_sv; 2376 1317 SV *rstr = ((SVOP*)repl)->op_sv; 2377 1317 STRLEN tlen; 2378 1317 STRLEN rlen; 2379 1317 const U8 *t = (U8*)SvPV_const(tstr, tlen); 2380 1317 const U8 *r = (U8*)SvPV_const(rstr, rlen); 2381 1317 register I32 i; 2382 1317 register I32 j; 2383 1317 I32 del; 2384 1317 I32 complement; 2385 1317 I32 squash; 2386 1317 I32 grows = 0; 2387 1317 register short *tbl; 2388 2389 1317 PL_hints |= HINT_BLOCK_SCOPE; 2390 1317 complement = o->op_private & OPpTRANS_COMPLEMENT; 2391 1317 del = o->op_private & OPpTRANS_DELETE; 2392 1317 squash = o->op_private & OPpTRANS_SQUASH; 2393 2394 1317 if (SvUTF8(tstr)) 2395 ###### o->op_private |= OPpTRANS_FROM_UTF; 2396 2397 1317 if (SvUTF8(rstr)) 2398 ###### o->op_private |= OPpTRANS_TO_UTF; 2399 2400 1317 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) { 2401 ###### SV* listsv = newSVpvn("# comment\n",10); 2402 ###### SV* transv = 0; 2403 ###### const U8* tend = t + tlen; 2404 ###### const U8* rend = r + rlen; 2405 ###### STRLEN ulen; 2406 ###### UV tfirst = 1; 2407 ###### UV tlast = 0; 2408 ###### IV tdiff; 2409 ###### UV rfirst = 1; 2410 ###### UV rlast = 0; 2411 ###### IV rdiff; 2412 ###### IV diff; 2413 ###### I32 none = 0; 2414 ###### U32 max = 0; 2415 ###### I32 bits; 2416 ###### I32 havefinal = 0; 2417 ###### U32 final = 0; 2418 ###### I32 from_utf = o->op_private & OPpTRANS_FROM_UTF; 2419 ###### I32 to_utf = o->op_private & OPpTRANS_TO_UTF; 2420 ###### U8* tsave = NULL; 2421 ###### U8* rsave = NULL; 2422 2423 ###### if (!from_utf) { 2424 ###### STRLEN len = tlen; 2425 ###### t = tsave = bytes_to_utf8(t, &len); 2426 ###### tend = t + len; 2427 } 2428 ###### 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 ###### if (complement) { 2441 ###### U8 tmpbuf[UTF8_MAXBYTES+1]; 2442 ###### UV *cp; 2443 ###### UV nextmin = 0; 2444 ###### New(1109, cp, 2*tlen, UV); 2445 ###### i = 0; 2446 ###### transv = newSVpvn("",0); 2447 ###### while (t < tend) { 2448 ###### cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0); 2449 ###### t += ulen; 2450 ###### if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { 2451 ###### t++; 2452 ###### cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0); 2453 ###### t += ulen; 2454 } 2455 else { 2456 ###### cp[2*i+1] = cp[2*i]; 2457 } 2458 ###### i++; 2459 } 2460 ###### qsort(cp, i, 2*sizeof(UV), uvcompare); 2461 ###### for (j = 0; j < i; j++) { 2462 ###### UV val = cp[2*j]; 2463 ###### diff = val - nextmin; 2464 ###### if (diff > 0) { 2465 ###### t = uvuni_to_utf8(tmpbuf,nextmin); 2466 ###### sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); 2467 ###### if (diff > 1) { 2468 ###### U8 range_mark = UTF_TO_NATIVE(0xff); 2469 ###### t = uvuni_to_utf8(tmpbuf, val - 1); 2470 ###### sv_catpvn(transv, (char *)&range_mark, 1); 2471 ###### sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); 2472 } 2473 } 2474 ###### val = cp[2*j+1]; 2475 ###### if (val >= nextmin) 2476 ###### nextmin = val + 1; 2477 } 2478 ###### t = uvuni_to_utf8(tmpbuf,nextmin); 2479 ###### sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); 2480 { 2481 ###### U8 range_mark = UTF_TO_NATIVE(0xff); 2482 ###### sv_catpvn(transv, (char *)&range_mark, 1); 2483 } 2484 ###### t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff, 2485 UNICODE_ALLOW_SUPER); 2486 ###### sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); 2487 ###### t = (const U8*)SvPVX_const(transv); 2488 ###### tlen = SvCUR(transv); 2489 ###### tend = t + tlen; 2490 ###### Safefree(cp); 2491 } 2492 ###### else if (!rlen && !del) { 2493 ###### r = t; rlen = tlen; rend = tend; 2494 } 2495 ###### if (!squash) { 2496 ###### if ((!rlen && !del) || t == r || 2497 (tlen == rlen && memEQ((char *)t, (char *)r, tlen))) 2498 { 2499 ###### o->op_private |= OPpTRANS_IDENTICAL; 2500 } 2501 } 2502 2503 ###### while (t < tend || tfirst <= tlast) { 2504 /* see if we need more "t" chars */ 2505 ###### if (tfirst > tlast) { 2506 ###### tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0); 2507 ###### t += ulen; 2508 ###### if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */ 2509 ###### t++; 2510 ###### tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0); 2511 ###### t += ulen; 2512 } 2513 else 2514 ###### tlast = tfirst; 2515 } 2516 2517 /* now see if we need more "r" chars */ 2518 ###### if (rfirst > rlast) { 2519 ###### if (r < rend) { 2520 ###### rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0); 2521 ###### r += ulen; 2522 ###### if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */ 2523 ###### r++; 2524 ###### rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0); 2525 ###### r += ulen; 2526 } 2527 else 2528 ###### rlast = rfirst; 2529 } 2530 else { 2531 ###### if (!havefinal++) 2532 ###### final = rlast; 2533 ###### rfirst = rlast = 0xffffffff; 2534 } 2535 } 2536 2537 /* now see which range will peter our first, if either. */ 2538 ###### tdiff = tlast - tfirst; 2539 ###### rdiff = rlast - rfirst; 2540 2541 ###### if (tdiff <= rdiff) 2542 ###### diff = tdiff; 2543 else 2544 ###### diff = rdiff; 2545 2546 ###### if (rfirst == 0xffffffff) { 2547 ###### diff = tdiff; /* oops, pretend rdiff is infinite */ 2548 ###### if (diff > 0) 2549 ###### Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n", 2550 (long)tfirst, (long)tlast); 2551 else 2552 ###### Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst); 2553 } 2554 else { 2555 ###### if (diff > 0) 2556 ###### Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n", 2557 (long)tfirst, (long)(tfirst + diff), 2558 (long)rfirst); 2559 else 2560 ###### Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n", 2561 (long)tfirst, (long)rfirst); 2562 2563 ###### if (rfirst + diff > max) 2564 ###### max = rfirst + diff; 2565 ###### if (!grows) 2566 ###### grows = (tfirst < rfirst && 2567 UNISKIP(tfirst) < UNISKIP(rfirst + diff)); 2568 ###### rfirst += diff + 1; 2569 } 2570 ###### tfirst += diff + 1; 2571 } 2572 2573 ###### none = ++max; 2574 ###### if (del) 2575 ###### del = ++max; 2576 2577 ###### if (max > 0xffff) 2578 ###### bits = 32; 2579 ###### else if (max > 0xff) 2580 ###### bits = 16; 2581 else 2582 ###### bits = 8; 2583 2584 ###### Safefree(cPVOPo->op_pv); 2585 ###### cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none); 2586 ###### SvREFCNT_dec(listsv); 2587 ###### if (transv) 2588 ###### SvREFCNT_dec(transv); 2589 2590 ###### if (!del && havefinal && rlen) 2591 ###### (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5, 2592 newSVuv((UV)final), 0); 2593 2594 ###### if (grows) 2595 ###### o->op_private |= OPpTRANS_GROWS; 2596 2597 ###### if (tsave) 2598 ###### Safefree(tsave); 2599 ###### if (rsave) 2600 ###### Safefree(rsave); 2601 2602 ###### op_free(expr); 2603 ###### op_free(repl); 2604 ###### return o; 2605 } 2606 2607 1317 tbl = (short*)cPVOPo->op_pv; 2608 1317 if (complement) { 2609 1 Zero(tbl, 256, short); 2610 64 for (i = 0; i < (I32)tlen; i++) 2611 63 tbl[t[i]] = -1; 2612 257 for (i = 0, j = 0; i < 256; i++) { 2613 256 if (!tbl[i]) { 2614 193 if (j >= (I32)rlen) { 2615 193 if (del) 2616 193 tbl[i] = -2; 2617 ###### else if (rlen) 2618 ###### tbl[i] = r[j-1]; 2619 else 2620 ###### 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 1 if (!del) { 2630 ###### if (!rlen) { 2631 ###### j = rlen; 2632 ###### if (!squash) 2633 ###### o->op_private |= OPpTRANS_IDENTICAL; 2634 } 2635 ###### else if (j >= (I32)rlen) 2636 ###### j = rlen - 1; 2637 else 2638 ###### cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short); 2639 ###### tbl[0x100] = rlen - j; 2640 ###### for (i=0; i < (I32)rlen - j; i++) 2641 ###### tbl[0x101+i] = r[j+i]; 2642 } 2643 } 2644 else { 2645 1316 if (!rlen && !del) { 2646 519 r = t; rlen = tlen; 2647 519 if (!squash) 2648 519 o->op_private |= OPpTRANS_IDENTICAL; 2649 } 2650 797 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) { 2651 3 o->op_private |= OPpTRANS_IDENTICAL; 2652 } 2653 338212 for (i = 0; i < 256; i++) 2654 336896 tbl[i] = -1; 2655 37215 for (i = 0, j = 0; i < (I32)tlen; i++,j++) { 2656 35899 if (j >= (I32)rlen) { 2657 4295 if (del) { 2658 11 if (tbl[t[i]] == -1) 2659 9 tbl[t[i]] = -2; 2660 9 continue; 2661 } 2662 4284 --j; 2663 } 2664 35888 if (tbl[t[i]] == -1) { 2665 35888 if (t[i] < 128 && r[j] >= 128) 2666 ###### grows = 1; 2667 35888 tbl[t[i]] = r[j]; 2668 } 2669 } 2670 } 2671 1317 if (grows) 2672 ###### o->op_private |= OPpTRANS_GROWS; 2673 1317 op_free(expr); 2674 1317 op_free(repl); 2675 2676 1317 return o; 2677 } 2678 2679 OP * 2680 Perl_newPMOP(pTHX_ I32 type, I32 flags) 2681 70148 { 2682 dVAR; 2683 70148 PMOP *pmop; 2684 2685 70148 NewOp(1101, pmop, 1, PMOP); 2686 70148 pmop->op_type = (OPCODE)type; 2687 70148 pmop->op_ppaddr = PL_ppaddr[type]; 2688 70148 pmop->op_flags = (U8)flags; 2689 70148 pmop->op_private = (U8)(0 | (flags >> 8)); 2690 2691 70148 if (PL_hints & HINT_RE_TAINT) 2692 14618 pmop->op_pmpermflags |= PMf_RETAINT; 2693 70148 if (PL_hints & HINT_LOCALE) 2694 ###### pmop->op_pmpermflags |= PMf_LOCALE; 2695 70148 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 70148 if (type != OP_TRANS && PL_curstash) { 2716 70148 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab); 2717 2718 70148 if (!mg) { 2719 6167 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0); 2720 } 2721 70148 pmop->op_pmnext = (PMOP*)mg->mg_obj; 2722 70148 mg->mg_obj = (SV*)pmop; 2723 70148 PmopSTASH_set(pmop,PL_curstash); 2724 } 2725 2726 70148 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 71465 { 2744 dVAR; 2745 71465 PMOP *pm; 2746 71465 LOGOP *rcop; 2747 71465 I32 repl_has_vars = 0; 2748 71465 OP* repl = Nullop; 2749 71465 bool reglist; 2750 2751 71465 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) { 2752 /* last element in list is the replacement; pop it */ 2753 25385 OP* kid; 2754 25385 repl = cLISTOPx(expr)->op_last; 2755 25385 kid = cLISTOPx(expr)->op_first; 2756 53096 while (kid->op_sibling != repl) 2757 27711 kid = kid->op_sibling; 2758 25385 kid->op_sibling = Nullop; 2759 25385 cLISTOPx(expr)->op_last = kid; 2760 } 2761 2762 71465 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 24125 OP* oe = expr; 2767 24125 expr = cLISTOPx(oe)->op_first->op_sibling; 2768 24125 cLISTOPx(oe)->op_first->op_sibling = Nullop; 2769 24125 cLISTOPx(oe)->op_last = Nullop; 2770 24125 op_free(oe); 2771 } 2772 2773 71465 if (o->op_type == OP_TRANS) { 2774 1317 return pmtrans(o, expr, repl); 2775 } 2776 2777 70148 reglist = isreg && expr->op_type == OP_LIST; 2778 70148 if (reglist) 2779 4184 op_null(expr); 2780 2781 70148 PL_hints |= HINT_BLOCK_SCOPE; 2782 70148 pm = (PMOP*)o; 2783 2784 70148 if (expr->op_type == OP_CONST) { 2785 63931 STRLEN plen; 2786 63931 SV *pat = ((SVOP*)expr)->op_sv; 2787 63931 const char *p = SvPV_const(pat, plen); 2788 63931 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) { 2789 562 U32 was_readonly = SvREADONLY(pat); 2790 2791 562 if (was_readonly) { 2792 562 if (SvFAKE(pat)) { 2793 ###### sv_force_normal_flags(pat, 0); 2794 ###### assert(!SvREADONLY(pat)); 2795 ###### was_readonly = 0; 2796 } else { 2797 562 SvREADONLY_off(pat); 2798 } 2799 } 2800 2801 562 sv_setpvn(pat, "\\s+", 3); 2802 2803 562 SvFLAGS(pat) |= was_readonly; 2804 2805 562 p = SvPV_const(pat, plen); 2806 562 pm->op_pmflags |= PMf_SKIPWHITE; 2807 } 2808 63931 if (DO_UTF8(pat)) 2809 ###### pm->op_pmdynflags |= PMdf_UTF8; 2810 /* FIXME - can we make this function take const char * args? */ 2811 63931 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm)); 2812 63931 if (strEQ("\\s+", PM_GETRE(pm)->precomp)) 2813 1127 pm->op_pmflags |= PMf_WHITE; 2814 63931 op_free(expr); 2815 } 2816 else { 2817 6217 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) 2818 6170 expr = newUNOP((!(PL_hints & HINT_RE_EVAL) 2819 ? OP_REGCRESET 2820 : OP_REGCMAYBE),0,expr); 2821 2822 6217 NewOp(1101, rcop, 1, LOGOP); 2823 6217 rcop->op_type = OP_REGCOMP; 2824 6217 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP]; 2825 6217 rcop->op_first = scalar(expr); 2826 6217 rcop->op_flags |= OPf_KIDS 2827 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0) 2828 | (reglist ? OPf_STACKED : 0); 2829 6217 rcop->op_private = 1; 2830 6217 rcop->op_other = o; 2831 6217 if (reglist) 2832 4184 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP); 2833 2834 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */ 2835 6217 PL_cv_has_eval = 1; 2836 2837 /* establish postfix order */ 2838 6217 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) { 2839 6170 LINKLIST(expr); 2840 6170 rcop->op_next = expr; 2841 6170 ((UNOP*)expr)->op_first->op_next = (OP*)rcop; 2842 } 2843 else { 2844 47 rcop->op_next = LINKLIST(expr); 2845 47 expr->op_next = (OP*)rcop; 2846 } 2847 2848 6217 prepend_elem(o->op_type, scalar((OP*)rcop), o); 2849 } 2850 2851 70148 if (repl) { 2852 24068 OP *curop; 2853 24068 if (pm->op_pmflags & PMf_EVAL) { 2854 785 curop = 0; 2855 785 if (CopLINE(PL_curcop) < (line_t)PL_multi_end) 2856 ###### CopLINE_set(PL_curcop, (line_t)PL_multi_end); 2857 } 2858 23283 else if (repl->op_type == OP_CONST) 2859 17601 curop = repl; 2860 else { 2861 5682 OP *lastop = 0; 2862 8357 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) { 2863 7801 if (PL_opargs[curop->op_type] & OA_DANGEROUS) { 2864 6159 if (curop->op_type == OP_GV) { 2865 5368 GV *gv = cGVOPx_gv(curop); 2866 5368 repl_has_vars = 1; 2867 5368 if (strchr("&`'123456789+-\016\022", *GvENAME(gv))) 2868 4896 break; 2869 } 2870 791 else if (curop->op_type == OP_RV2CV) 2871 ###### break; 2872 791 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 559 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/ 2877 230 break; 2878 } 2879 232 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 232 repl_has_vars = 1; 2884 } 2885 ###### else if (curop->op_type == OP_PUSHRE) 2886 ; /* Okay here, dangerous in newASSIGNOP */ 2887 else 2888 2675 break; 2889 } 2890 2675 lastop = curop; 2891 } 2892 } 2893 24068 if (curop == repl 2894 && !(repl_has_vars 2895 && (!PM_GETRE(pm) 2896 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) { 2897 18110 pm->op_pmflags |= PMf_CONST; /* const for long enough */ 2898 18110 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */ 2899 18110 prepend_elem(o->op_type, scalar(repl), o); 2900 } 2901 else { 2902 5958 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */ 2903 47 pm->op_pmflags |= PMf_MAYBE_CONST; 2904 47 pm->op_pmpermflags |= PMf_MAYBE_CONST; 2905 } 2906 5958 NewOp(1101, rcop, 1, LOGOP); 2907 5958 rcop->op_type = OP_SUBSTCONT; 2908 5958 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT]; 2909 5958 rcop->op_first = scalar(repl); 2910 5958 rcop->op_flags |= OPf_KIDS; 2911 5958 rcop->op_private = 1; 2912 5958 rcop->op_other = o; 2913 2914 /* establish postfix order */ 2915 5958 rcop->op_next = LINKLIST(repl); 2916 5958 repl->op_next = (OP*)rcop; 2917 2918 5958 pm->op_pmreplroot = scalar((OP*)rcop); 2919 5958 pm->op_pmreplstart = LINKLIST(rcop); 2920 5958 rcop->op_next = 0; 2921 } 2922 } 2923 2924 70148 return (OP*)pm; 2925 } 2926 2927 OP * 2928 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv) 2929 1810678 { 2930 dVAR; 2931 1810678 SVOP *svop; 2932 1810678 NewOp(1101, svop, 1, SVOP); 2933 1810678 svop->op_type = (OPCODE)type; 2934 1810678 svop->op_ppaddr = PL_ppaddr[type]; 2935 1810678 svop->op_sv = sv; 2936 1810678 svop->op_next = (OP*)svop; 2937 1810678 svop->op_flags = (U8)flags; 2938 1810678 if (PL_opargs[type] & OA_RETSCALAR) 2939 1757492 scalar((OP*)svop); 2940 1810678 if (PL_opargs[type] & OA_TARGET) 2941 1055 svop->op_targ = pad_alloc(type, SVs_PADTMP); 2942 1810678 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 52035 { 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 52035 return newSVOP(type, flags, SvREFCNT_inc(gv)); 2977 #endif 2978 } 2979 2980 OP * 2981 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv) 2982 8706 { 2983 dVAR; 2984 8706 PVOP *pvop; 2985 8706 NewOp(1101, pvop, 1, PVOP); 2986 8706 pvop->op_type = (OPCODE)type; 2987 8706 pvop->op_ppaddr = PL_ppaddr[type]; 2988 8706 pvop->op_pv = pv; 2989 8706 pvop->op_next = (OP*)pvop; 2990 8706 pvop->op_flags = (U8)flags; 2991 8706 if (PL_opargs[type] & OA_RETSCALAR) 2992 8706 scalar((OP*)pvop); 2993 8706 if (PL_opargs[type] & OA_TARGET) 2994 ###### pvop->op_targ = pad_alloc(type, SVs_PADTMP); 2995 8706 return CHECKOP(type, pvop); 2996 } 2997 2998 void 2999 Perl_package(pTHX_ OP *o) 3000 10455 { 3001 10455 const char *name; 3002 10455 STRLEN len; 3003 3004 10455 save_hptr(&PL_curstash); 3005 10455 save_item(PL_curstname); 3006 3007 10455 name = SvPV_const(cSVOPo->op_sv, len); 3008 10455 PL_curstash = gv_stashpvn(name, len, TRUE); 3009 10455 sv_setpvn(PL_curstname, name, len); 3010 10455 op_free(o); 3011 3012 10455 PL_hints |= HINT_BLOCK_SCOPE; 3013 10455 PL_copline = NOLINE; 3014 10455 PL_expect = XSTATE; 3015 } 3016 3017 void 3018 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) 3019 22597 { 3020 22597 OP *pack; 3021 22597 OP *imop; 3022 22597 OP *veop; 3023 3024 22597 if (idop->op_type != OP_CONST) 3025 ###### Perl_croak(aTHX_ "Module name must be constant"); 3026 3027 22597 veop = Nullop; 3028 3029 22597 if (version != Nullop) { 3030 6 SV *vesv = ((SVOP*)version)->op_sv; 3031 3032 6 if (arg == Nullop && !SvNIOKp(vesv)) { 3033 ###### arg = version; 3034 } 3035 else { 3036 6 OP *pack; 3037 6 SV *meth; 3038 3039 6 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 6 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv)); 3044 3045 /* Fake up a method call to VERSION */ 3046 6 meth = newSVpvn_share("VERSION", 7, 0); 3047 6 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 22597 if (arg && arg->op_type == OP_STUB) 3056 1065 imop = arg; /* no import on explicit () */ 3057 21532 else if (SvNIOKp(((SVOP*)idop)->op_sv)) { 3058 2837 imop = Nullop; /* use 5.0; */ 3059 } 3060 else { 3061 18695 SV *meth; 3062 3063 /* Make copy of idop so we don't free it twice */ 3064 18695 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv)); 3065 3066 /* Fake up a method call to import/unimport */ 3067 18695 meth = aver 3068 ? newSVpvn_share("import",6, 0) : newSVpvn_share("unimport", 8, 0); 3069 18695 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 22597 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 22597 PL_hints |= HINT_BLOCK_SCOPE; 3104 22597 PL_copline = NOLINE; 3105 22597 PL_expect = XSTATE; 3106 22597 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 ###### { 3128 ###### va_list args; 3129 ###### va_start(args, ver); 3130 ###### 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 ###### { 3149 ###### OP *modname, *veop, *imop; 3150 3151 ###### modname = newSVOP(OP_CONST, 0, name); 3152 ###### modname->op_private |= OPpCONST_BARE; 3153 ###### if (ver) { 3154 ###### veop = newSVOP(OP_CONST, 0, ver); 3155 } 3156 else 3157 ###### veop = Nullop; 3158 ###### if (flags & PERL_LOADMOD_NOIMPORT) { 3159 ###### imop = sawparens(newNULLLIST()); 3160 } 3161 ###### else if (flags & PERL_LOADMOD_IMPORT_OPS) { 3162 ###### imop = va_arg(*args, OP*); 3163 } 3164 else { 3165 ###### SV *sv; 3166 ###### imop = Nullop; 3167 ###### sv = va_arg(*args, SV*); 3168 ###### while (sv) { 3169 ###### imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv)); 3170 ###### sv = va_arg(*args, SV*); 3171 } 3172 } 3173 { 3174 ###### const line_t ocopline = PL_copline; 3175 ###### COP * const ocurcop = PL_curcop; 3176 ###### const int oexpect = PL_expect; 3177 3178 ###### utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), 3179 veop, modname, imop); 3180 ###### PL_expect = oexpect; 3181 ###### PL_copline = ocopline; 3182 ###### PL_curcop = ocurcop; 3183 } 3184 } 3185 3186 OP * 3187 Perl_dofile(pTHX_ OP *term) 3188 326 { 3189 326 OP *doop; 3190 326 GV *gv; 3191 3192 326 gv = gv_fetchpv("do", FALSE, SVt_PVCV); 3193 326 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) 3194 326 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV); 3195 3196 326 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 326 doop = newUNOP(OP_DOFILE, 0, scalar(term)); 3205 } 3206 326 return doop; 3207 } 3208 3209 OP * 3210 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval) 3211 6379 { 3212 6379 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 293742 { 3220 293742 if (!o) 3221 ###### return TRUE; 3222 3223 293742 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS) 3224 86 o = cUNOPo->op_first; 3225 3226 293742 if (o->op_type == OP_COND_EXPR) { 3227 86 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling); 3228 86 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling); 3229 3230 86 if (t && f) 3231 ###### return TRUE; 3232 86 if (t || f) 3233 ###### yyerror("Assignment to both a list and a scalar"); 3234 86 return FALSE; 3235 } 3236 3237 293656 if (o->op_type == OP_LIST && 3238 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR && 3239 o->op_private & OPpLVAL_INTRO) 3240 ###### return FALSE; 3241 3242 293656 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 61961 return TRUE; 3246 3247 231695 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) 3248 20360 return TRUE; 3249 3250 211335 if (o->op_type == OP_RV2SV) 3251 39998 return FALSE; 3252 3253 171337 return FALSE; 3254 } 3255 3256 OP * 3257 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) 3258 325519 { 3259 325519 OP *o; 3260 3261 325519 if (optype) { 3262 31949 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) { 3263 9327 return newLOGOP(optype, 0, 3264 mod(scalar(left), optype), 3265 newUNOP(OP_SASSIGN, 0, scalar(right))); 3266 } 3267 else { 3268 22622 return newBINOP(optype, OPf_STACKED, 3269 mod(scalar(left), optype), scalar(right)); 3270 } 3271 } 3272 3273 293570 if (is_list_assignment(left)) { 3274 82321 OP *curop; 3275 3276 82321 PL_modcount = 0; 3277 /* Grandfathering $[ assignment here. Bletch.*/ 3278 /* Only simple assignments like C<< ($[) = 1 >> are allowed */ 3279 82321 PL_eval_start = (left->op_type == OP_CONST) ? right : 0; 3280 82321 left = mod(left, OP_AASSIGN); 3281 82321 if (PL_eval_start) 3282 ###### PL_eval_start = 0; 3283 82321 else if (left->op_type == OP_CONST) { 3284 /* Result of assignment is always 1 (or we'd be dead already) */ 3285 ###### return newSVOP(OP_CONST, 0, newSViv(1)); 3286 } 3287 /* optimise C to C, and likewise for hashes */ 3288 82321 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 1088 op_free(right); 3293 1088 left->op_flags &= ~(OPf_REF|OPf_SPECIAL); 3294 1088 return left; 3295 } 3296 81233 curop = list(force_list(left)); 3297 81233 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop); 3298 81233 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 81233 if (!(left->op_private & OPpLVAL_INTRO)) { 3315 36082 OP *lastop = o; 3316 36082 PL_generation++; 3317 427695 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) { 3318 406741 if (PL_opargs[curop->op_type] & OA_DANGEROUS) { 3319 85897 if (curop->op_type == OP_GV) { 3320 22038 GV *gv = cGVOPx_gv(curop); 3321 22038 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation) 3322 20674 break; 3323 20674 SvCUR_set(gv, PL_generation); 3324 } 3325 63859 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 32060 if (PAD_COMPNAME_GEN(curop->op_targ) 3331 == (STRLEN)PL_generation) 3332 1158 break; 3333 30902 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation); 3334 3335 } 3336 31799 else if (curop->op_type == OP_RV2CV) 3337 ###### break; 3338 31799 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 22794 if (lastop->op_type != OP_GV) /* funny deref? */ 3343 3898 break; 3344 } 3345 9005 else if (curop->op_type == OP_PUSHRE) { 3346 297 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 ###### GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot; 3352 #endif 3353 ###### if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation) 3354 ###### break; 3355 ###### SvCUR_set(gv, PL_generation); 3356 } 3357 } 3358 else 3359 391613 break; 3360 } 3361 391613 lastop = curop; 3362 } 3363 36082 if (curop != o) 3364 15128 o->op_private |= OPpASSIGN_COMMON; 3365 } 3366 81233 if (right && right->op_type == OP_SPLIT) { 3367 2096 OP* tmpop; 3368 2096 if ((tmpop = ((LISTOP*)right)->op_first) && 3369 tmpop->op_type == OP_PUSHRE) 3370 { 3371 2096 PMOP *pm = (PMOP*)tmpop; 3372 2096 if (left->op_type == OP_RV2AV && 3373 !(left->op_private & OPpLVAL_INTRO) && 3374 !(o->op_private & OPpASSIGN_COMMON) ) 3375 { 3376 3 tmpop = ((UNOP*)left)->op_first; 3377 3 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 3 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv; 3383 3 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */ 3384 #endif 3385 3 pm->op_pmflags |= PMf_ONCE; 3386 3 tmpop = cUNOPo->op_first; /* to list (nulled) */ 3387 3 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */ 3388 3 tmpop->op_sibling = Nullop; /* don't free split */ 3389 3 right->op_next = tmpop->op_next; /* fix starting loc */ 3390 3 op_free(o); /* blow off assign */ 3391 3 right->op_flags &= ~OPf_WANT; 3392 /* "I don't know and I don't care." */ 3393 3 return right; 3394 } 3395 } 3396 else { 3397 2093 if (PL_modcount < RETURN_UNLIMITED_NUMBER && 3398 ((LISTOP*)right)->op_last->op_type == OP_CONST) 3399 { 3400 186 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv; 3401 186 if (SvIVX(sv) == 0) 3402 128 sv_setiv(sv, PL_modcount+1); 3403 } 3404 } 3405 } 3406 } 3407 81230 return o; 3408 } 3409 211249 if (!right) 3410 ###### right = newOP(OP_UNDEF, 0); 3411 211249 if (right->op_type == OP_READLINE) { 3412 2736 right->op_flags |= OPf_STACKED; 3413 2736 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right)); 3414 } 3415 else { 3416 208513 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/ 3417 208513 o = newBINOP(OP_SASSIGN, flags, 3418 scalar(right), mod(scalar(left), OP_SASSIGN) ); 3419 208513 if (PL_eval_start) 3420 208513 PL_eval_start = 0; 3421 else { 3422 ###### o = newSVOP(OP_CONST, 0, newSViv(PL_compiling.cop_arybase)); 3423 } 3424 } 3425 208513 return o; 3426 } 3427 3428 OP * 3429 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) 3430 830221 { 3431 dVAR; 3432 830221 const U32 seq = intro_my(); 3433 830221 register COP *cop; 3434 3435 830221 NewOp(1101, cop, 1, COP); 3436 830221 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) { 3437 ###### cop->op_type = OP_DBSTATE; 3438 ###### cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ]; 3439 } 3440 else { 3441 830221 cop->op_type = OP_NEXTSTATE; 3442 830221 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ]; 3443 } 3444 830221 cop->op_flags = (U8)flags; 3445 830221 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); 3446 #ifdef NATIVE_HINTS 3447 cop->op_private |= NATIVE_HINTS; 3448 #endif 3449 830221 PL_compiling.op_private = cop->op_private; 3450 830221 cop->op_next = (OP*)cop; 3451 3452 830221 if (label) { 3453 2794 cop->cop_label = label; 3454 2794 PL_hints |= HINT_BLOCK_SCOPE; 3455 } 3456 830221 cop->cop_seq = seq; 3457 830221 cop->cop_arybase = PL_curcop->cop_arybase; 3458 830221 if (specialWARN(PL_curcop->cop_warnings)) 3459 830039 cop->cop_warnings = PL_curcop->cop_warnings ; 3460 else 3461 182 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ; 3462 830221 if (specialCopIO(PL_curcop->cop_io)) 3463 830221 cop->cop_io = PL_curcop->cop_io; 3464 else 3465 ###### cop->cop_io = newSVsv(PL_curcop->cop_io) ; 3466 3467 3468 830221 if (PL_copline == NOLINE) 3469 50271 CopLINE_set(cop, CopLINE(PL_curcop)); 3470 else { 3471 779950 CopLINE_set(cop, PL_copline); 3472 779950 PL_copline = NOLINE; 3473 } 3474 #ifdef USE_ITHREADS 3475 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */ 3476 #else 3477 830221 CopFILEGV_set(cop, CopFILEGV(PL_curcop)); 3478 #endif 3479 830221 CopSTASH_set(cop, PL_curstash); 3480 3481 830221 if (PERLDB_LINE && PL_curstash != PL_debstash) { 3482 ###### SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE); 3483 ###### if (svp && *svp != &PL_sv_undef ) { 3484 ###### (void)SvIOK_on(*svp); 3485 ###### SvIV_set(*svp, PTR2IV(cop)); 3486 } 3487 } 3488 3489 830221 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 246001 { 3496 dVAR; 3497 246001 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 274317 { 3503 dVAR; 3504 274317 LOGOP *logop; 3505 274317 OP *o; 3506 274317 OP *first = *firstp; 3507 274317 OP *other = *otherp; 3508 3509 274317 if (type == OP_XOR) /* Not short circuit, but here by precedence. */ 3510 8 return newBINOP(type, flags, scalar(first), scalar(other)); 3511 3512 274309 scalarboolean(first); 3513 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */ 3514 274309 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) { 3515 11452 if (type == OP_AND || type == OP_OR) { 3516 11452 if (type == OP_AND) 3517 11452 type = OP_OR; 3518 else 3519 ###### type = OP_AND; 3520 11452 o = first; 3521 11452 first = *firstp = cUNOPo->op_first; 3522 11452 if (o->op_next) 3523 11452 first->op_next = o->op_next; 3524 11452 cUNOPo->op_first = Nullop; 3525 11452 op_free(o); 3526 } 3527 } 3528 274309 if (first->op_type == OP_CONST) { 3529 1163 if (first->op_private & OPpCONST_STRICT) 3530 ###### no_bareword_allowed(first); 3531 1163 else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE)) 3532 ###### Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional"); 3533 1163 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) || 3534 ###### (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) || 3535 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) { 3536 1162 op_free(first); 3537 1162 *firstp = Nullop; 3538 1162 if (other->op_type == OP_CONST) 3539 ###### other->op_private |= OPpCONST_SHORTCIRCUIT; 3540 1162 return other; 3541 } 3542 else { 3543 /* check for C, or C */ 3544 1 const OP *o2 = other; 3545 1 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 1 o2 = other; 3551 1 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 ###### Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), 3557 "Deprecated use of my() in false conditional"); 3558 } 3559 3560 1 op_free(other); 3561 1 *otherp = Nullop; 3562 1 if (first->op_type == OP_CONST) 3563 1 first->op_private |= OPpCONST_SHORTCIRCUIT; 3564 1 return first; 3565 } 3566 } 3567 273146 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) && 3568 type != OP_DOR) /* [#24076] Don't warn for err FOO. */ 3569 { 3570 68415 const OP *k1 = ((UNOP*)first)->op_first; 3571 68415 const OP *k2 = k1->op_sibling; 3572 68415 OPCODE warnop = 0; 3573 68415 switch (first->op_type) 3574 { 3575 case OP_NULL: 3576 19507 if (k2 && k2->op_type == OP_READLINE 3577 && (k2->op_flags & OPf_STACKED) 3578 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) 3579 { 3580 ###### warnop = k2->op_type; 3581 } 3582 ###### break; 3583 3584 case OP_SASSIGN: 3585 364 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 ###### warnop = ((k1->op_type == OP_NULL) 3591 ? (OPCODE)k1->op_targ : k1->op_type); 3592 } 3593 break; 3594 } 3595 68415 if (warnop) { 3596 ###### const line_t oldline = CopLINE(PL_curcop); 3597 ###### CopLINE_set(PL_curcop, PL_copline); 3598 ###### 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 ###### CopLINE_set(PL_curcop, oldline); 3604 } 3605 } 3606 3607 273146 if (!other) 3608 ###### return first; 3609 3610 273146 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN) 3611 9327 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */ 3612 3613 273146 NewOp(1101, logop, 1, LOGOP); 3614 3615 273146 logop->op_type = (OPCODE)type; 3616 273146 logop->op_ppaddr = PL_ppaddr[type]; 3617 273146 logop->op_first = first; 3618 273146 logop->op_flags = flags | OPf_KIDS; 3619 273146 logop->op_other = LINKLIST(other); 3620 273146 logop->op_private = (U8)(1 | (flags >> 8)); 3621 3622 /* establish postfix order */ 3623 273146 logop->op_next = LINKLIST(first); 3624 273146 first->op_next = (OP*)logop; 3625 273146 first->op_sibling = other; 3626 3627 273146 CHECKOP(type,logop); 3628 3629 273146 o = newUNOP(OP_NULL, 0, (OP*)logop); 3630 273146 other->op_next = o; 3631 3632 273146 return o; 3633 } 3634 3635 OP * 3636 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) 3637 121766 { 3638 dVAR; 3639 121766 LOGOP *logop; 3640 121766 OP *start; 3641 121766 OP *o; 3642 3643 121766 if (!falseop) 3644 53039 return newLOGOP(OP_AND, 0, first, trueop); 3645 68727 if (!trueop) 3646 ###### return newLOGOP(OP_OR, 0, first, falseop); 3647 3648 68727 scalarboolean(first); 3649 68727 if (first->op_type == OP_CONST) { 3650 1 if (first->op_private & OPpCONST_BARE && 3651 first->op_private & OPpCONST_STRICT) { 3652 ###### no_bareword_allowed(first); 3653 } 3654 1 if (SvTRUE(((SVOP*)first)->op_sv)) { 3655 1 op_free(first); 3656 1 op_free(falseop); 3657 1 return trueop; 3658 } 3659 else { 3660 ###### op_free(first); 3661 ###### op_free(trueop); 3662 ###### return falseop; 3663 } 3664 } 3665 68726 NewOp(1101, logop, 1, LOGOP); 3666 68726 logop->op_type = OP_COND_EXPR; 3667 68726 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR]; 3668 68726 logop->op_first = first; 3669 68726 logop->op_flags = flags | OPf_KIDS; 3670 68726 logop->op_private = (U8)(1 | (flags >> 8)); 3671 68726 logop->op_other = LINKLIST(trueop); 3672 68726 logop->op_next = LINKLIST(falseop); 3673 3674 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */ 3675 68726 logop); 3676 3677 /* establish postfix order */ 3678 68726 start = LINKLIST(first); 3679 68726 first->op_next = (OP*)logop; 3680 3681 68726 first->op_sibling = trueop; 3682 68726 trueop->op_sibling = falseop; 3683 68726 o = newUNOP(OP_NULL, 0, (OP*)logop); 3684 3685 68726 trueop->op_next = falseop->op_next = o; 3686 3687 68726 o->op_next = start; 3688 68726 return o; 3689 } 3690 3691 OP * 3692 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right) 3693 1502 { 3694 dVAR; 3695 1502 LOGOP *range; 3696 1502 OP *flip; 3697 1502 OP *flop; 3698 1502 OP *leftstart; 3699 1502 OP *o; 3700 3701 1502 NewOp(1101, range, 1, LOGOP); 3702 3703 1502 range->op_type = OP_RANGE; 3704 1502 range->op_ppaddr = PL_ppaddr[OP_RANGE]; 3705 1502 range->op_first = left; 3706 1502 range->op_flags = OPf_KIDS; 3707 1502 leftstart = LINKLIST(left); 3708 1502 range->op_other = LINKLIST(right); 3709 1502 range->op_private = (U8)(1 | (flags >> 8)); 3710 3711 1502 left->op_sibling = right; 3712 3713 1502 range->op_next = (OP*)range; 3714 1502 flip = newUNOP(OP_FLIP, flags, (OP*)range); 3715 1502 flop = newUNOP(OP_FLOP, 0, flip); 3716 1502 o = newUNOP(OP_NULL, 0, flop); 3717 1502 linklist(flop); 3718 1502 range->op_next = leftstart; 3719 3720 1502 left->op_next = flip; 3721 1502 right->op_next = flop; 3722 3723 1502 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY); 3724 1502 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV); 3725 1502 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY); 3726 1502 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV); 3727 3728 1502 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0; 3729 1502 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0; 3730 3731 1502 flip->op_next = o; 3732 1502 if (!flip->op_private || !flop->op_private) 3733 1324 linklist(o); /* blow off optimizer unless constant */ 3734 3735 1502 return o; 3736 } 3737 3738 OP * 3739 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) 3740 1638 { 3741 1638 OP* listop; 3742 1638 OP* o; 3743 1638 const bool once = block && block->op_flags & OPf_SPECIAL && 3744 1638 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL); 3745 1638 (void)debuggable; 3746 3747 1638 if (expr) { 3748 1638 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv)) 3749 ###### return block; /* do {} while 0 does once */ 3750 1638 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB 3751 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) { 3752 322 expr = newUNOP(OP_DEFINED, 0, 3753 newASSIGNOP(0, newDEFSVOP(), 0, expr) ); 3754 1316 } else if (expr->op_flags & OPf_KIDS) { 3755 1214 const OP *k1 = ((UNOP*)expr)->op_first; 3756 1214 const OP *k2 = (k1) ? k1->op_sibling : NULL; 3757 1214 switch (expr->op_type) { 3758 case OP_NULL: 3759 400 if (k2 && k2->op_type == OP_READLINE 3760 && (k2->op_flags & OPf_STACKED) 3761 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) 3762 ###### expr = newUNOP(OP_DEFINED, 0, expr); 3763 ###### break; 3764 3765 case OP_SASSIGN: 3766 47 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 ###### 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 1638 if (!block) 3779 ###### block = newOP(OP_NULL, 0); 3780 1638 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0)); 3781 1638 o = new_logop(OP_AND, 0, &expr, &listop); 3782 3783 1638 if (listop) 3784 1638 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o); 3785 3786 1638 if (once && o != listop) 3787 570 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other; 3788 3789 1638 if (o == listop) 3790 ###### o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */ 3791 3792 1638 o->op_flags |= flags; 3793 1638 o = scope(o); 3794 1638 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/ 3795 1638 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 30083 { 3802 dVAR; 3803 30083 OP *redo; 3804 30083 OP *next = 0; 3805 30083 OP *listop; 3806 30083 OP *o; 3807 30083 U8 loopflags = 0; 3808 30083 (void)debuggable; 3809 3810 30083 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB 3811 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) { 3812 567 expr = newUNOP(OP_DEFINED, 0, 3813 newASSIGNOP(0, newDEFSVOP(), 0, expr) ); 3814 29516 } else if (expr && (expr->op_flags & OPf_KIDS)) { 3815 4776 const OP *k1 = ((UNOP*)expr)->op_first; 3816 4776 const OP *k2 = (k1) ? k1->op_sibling : NULL; 3817 4776 switch (expr->op_type) { 3818 case OP_NULL: 3819 2024 if (k2 && k2->op_type == OP_READLINE 3820 && (k2->op_flags & OPf_STACKED) 3821 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) 3822 348 expr = newUNOP(OP_DEFINED, 0, expr); 3823 348 break; 3824 3825 case OP_SASSIGN: 3826 95 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 ###### expr = newUNOP(OP_DEFINED, 0, expr); 3831 break; 3832 } 3833 } 3834 3835 30083 if (!block) 3836 ###### block = newOP(OP_NULL, 0); 3837 30083 else if (cont || has_my) { 3838 1769 block = scope(block); 3839 } 3840 3841 30083 if (cont) { 3842 1062 next = LINKLIST(cont); 3843 } 3844 30083 if (expr) { 3845 26678 OP *unstack = newOP(OP_UNSTACK, 0); 3846 26678 if (!next) 3847 25616 next = unstack; 3848 26678 cont = append_elem(OP_LINESEQ, cont, unstack); 3849 } 3850 3851 30083 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont); 3852 30083 redo = LINKLIST(listop); 3853 3854 30083 if (expr) { 3855 26678 PL_copline = (line_t)whileline; 3856 26678 scalar(listop); 3857 26678 o = new_logop(OP_AND, 0, &expr, &listop); 3858 26678 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) { 3859 ###### op_free(expr); /* oops, it's a while (0) */ 3860 ###### op_free((OP*)loop); 3861 ###### return Nullop; /* listop already freed by new_logop */ 3862 } 3863 26678 if (listop) 3864 26678 ((LISTOP*)listop)->op_last->op_next = 3865 (o == listop ? redo : LINKLIST(o)); 3866 } 3867 else 3868 3405 o = listop; 3869 3870 30083 if (!loop) { 3871 10067 NewOp(1101,loop,1,LOOP); 3872 10067 loop->op_type = OP_ENTERLOOP; 3873 10067 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP]; 3874 10067 loop->op_private = 0; 3875 10067 loop->op_next = (OP*)loop; 3876 } 3877 3878 30083 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o); 3879 3880 30083 loop->op_redoop = redo; 3881 30083 loop->op_lastop = o; 3882 30083 o->op_private |= loopflags; 3883 3884 30083 if (next) 3885 26678 loop->op_nextop = next; 3886 else 3887 3405 loop->op_nextop = o; 3888 3889 30083 o->op_flags |= flags; 3890 30083 o->op_private |= (flags >> 8); 3891 30083 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 20016 { 3897 dVAR; 3898 20016 LOOP *loop; 3899 20016 OP *wop; 3900 20016 PADOFFSET padoff = 0; 3901 20016 I32 iterflags = 0; 3902 20016 I32 iterpflags = 0; 3903 3904 20016 if (sv) { 3905 14391 if (sv->op_type == OP_RV2SV) { /* symbol table variable */ 3906 23 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */ 3907 23 sv->op_type = OP_RV2GV; 3908 23 sv->op_ppaddr = PL_ppaddr[OP_RV2GV]; 3909 } 3910 14368 else if (sv->op_type == OP_PADSV) { /* private variable */ 3911 14368 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */ 3912 14368 padoff = sv->op_targ; 3913 14368 sv->op_targ = 0; 3914 14368 op_free(sv); 3915 14368 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 5625 const I32 offset = pad_findmy("$_"); 3929 5625 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) { 3930 5625 sv = newGVOP(OP_GV, 0, PL_defgv); 3931 } 3932 else { 3933 ###### padoff = offset; 3934 } 3935 } 3936 20016 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) { 3937 12944 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART); 3938 12944 iterflags |= OPf_STACKED; 3939 } 3940 7072 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 1264 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first; 3949 1264 LOGOP* range = (LOGOP*) flip->op_first; 3950 1264 OP* const left = range->op_first; 3951 1264 OP* const right = left->op_sibling; 3952 1264 LISTOP* listop; 3953 3954 1264 range->op_flags &= ~OPf_KIDS; 3955 1264 range->op_first = Nullop; 3956 3957 1264 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right); 3958 1264 listop->op_first->op_next = range->op_next; 3959 1264 left->op_next = range->op_other; 3960 1264 right->op_next = (OP*)listop; 3961 1264 listop->op_next = listop->op_first; 3962 3963 1264 op_free(expr); 3964 1264 expr = (OP*)(listop); 3965 1264 op_null(expr); 3966 1264 iterflags |= OPf_STACKED; 3967 } 3968 else { 3969 5808 expr = mod(force_list(expr), OP_GREPSTART); 3970 } 3971 3972 20016 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags, 3973 append_elem(OP_LIST, expr, scalar(sv)))); 3974 20016 assert(!loop->op_next); 3975 /* for my $x () sets OPpLVAL_INTRO; 3976 * for our $x () sets OPpOUR_INTRO */ 3977 20016 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 20016 Renew(loop, 1, LOOP); 3988 #endif 3989 20016 loop->op_targ = padoff; 3990 20016 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0); 3991 20016 PL_copline = forline; 3992 20016 return newSTATEOP(0, label, wop); 3993 } 3994 3995 OP* 3996 Perl_newLOOPEX(pTHX_ I32 type, OP *label) 3997 14909 { 3998 14909 OP *o; 3999 4000 14909 if (type != OP_GOTO || label->op_type == OP_CONST) { 4001 /* "last()" means "last" */ 4002 7389 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) 4003 ###### o = newOP(type, OPf_SPECIAL); 4004 else { 4005 7389 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST 4006 7389 ? SvPVx_nolen_const(((SVOP*)label)->op_sv) 4007 : "")); 4008 } 4009 7389 op_free(label); 4010 } 4011 else { 4012 /* Check whether it's going to be a goto &function */ 4013 7520 if (label->op_type == OP_ENTERSUB 4014 && !(label->op_flags & OPf_STACKED)) 4015 6880 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN)); 4016 7520 o = newUNOP(type, OPf_STACKED, label); 4017 } 4018 14909 PL_hints |= HINT_BLOCK_SCOPE; 4019 14909 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 142014 { 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 142014 if (!CvXSUB(cv) && CvROOT(cv)) { 4046 90374 if (CvDEPTH(cv)) 4047 ###### Perl_croak(aTHX_ "Can't undef active subroutine"); 4048 90374 ENTER; 4049 4050 90374 PAD_SAVE_SETNULLPAD(); 4051 4052 90374 op_free(CvROOT(cv)); 4053 90374 CvROOT(cv) = Nullop; 4054 90374 CvSTART(cv) = Nullop; 4055 90374 LEAVE; 4056 } 4057 142014 SvPOK_off((SV*)cv); /* forget prototype */ 4058 142014 CvGV(cv) = Nullgv; 4059 4060 142014 pad_undef(cv); 4061 4062 /* remove CvOUTSIDE unless this is an undef rather than a free */ 4063 142014 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) { 4064 104130 if (!CvWEAKOUTSIDE(cv)) 4065 100213 SvREFCNT_dec(CvOUTSIDE(cv)); 4066 104130 CvOUTSIDE(cv) = Nullcv; 4067 } 4068 142014 if (CvCONST(cv)) { 4069 3896 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr); 4070 3896 CvCONST_off(cv); 4071 } 4072 142014 if (CvXSUB(cv)) { 4073 24413 CvXSUB(cv) = 0; 4074 } 4075 /* delete all flags except WEAKOUTSIDE */ 4076 142014 CvFLAGS(cv) &= CVf_WEAKOUTSIDE; 4077 } 4078 4079 void 4080 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p) 4081 1988 { 4082 1988 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) { 4083 ###### SV* msg = sv_newmortal(); 4084 ###### SV* name = Nullsv; 4085 4086 ###### if (gv) 4087 ###### gv_efullname3(name = sv_newmortal(), gv, Nullch); 4088 ###### sv_setpv(msg, "Prototype mismatch:"); 4089 ###### if (name) 4090 ###### Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name); 4091 ###### if (SvPOK(cv)) 4092 ###### Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv); 4093 else 4094 ###### Perl_sv_catpv(aTHX_ msg, ": none"); 4095 ###### sv_catpv(msg, " vs "); 4096 ###### if (p) 4097 ###### Perl_sv_catpvf(aTHX_ msg, "(%s)", p); 4098 else 4099 ###### sv_catpv(msg, "none"); 4100 ###### 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 19416 { 4123 19416 if (!cv || !CvCONST(cv)) 4124 15871 return Nullsv; 4125 3545 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 4855 { 4151 4855 SV *sv = Nullsv; 4152 4153 4855 if (!o) 4154 ###### return Nullsv; 4155 4156 4855 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first) 4157 3979 o = cLISTOPo->op_first->op_sibling; 4158 4159 11453 for (; o; o = o->op_next) { 4160 8002 OPCODE type = o->op_type; 4161 4162 8002 if (sv && o->op_next == o) 4163 2144 return sv; 4164 5858 if (o->op_next != o) { 4165 3355 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK) 4166 2354 continue; 4167 2354 if (type == OP_DBSTATE) 4168 ###### continue; 4169 } 4170 4857 if (type == OP_LEAVESUB || type == OP_RETURN) 4171 4703 break; 4172 4703 if (sv) 4173 ###### return Nullsv; 4174 4703 if (type == OP_CONST && cSVOPo->op_sv) 4175 2144 sv = cSVOPo->op_sv; 4176 2559 else if (cv && type == OP_CONST) { 4177 ###### sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ); 4178 ###### if (!sv) 4179 ###### return Nullsv; 4180 } 4181 2559 else if (cv && type == OP_PADSV) { 4182 953 if (CvCONST(cv)) { /* newly cloned anon */ 4183 799 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 799 if (!sv || SvREFCNT(sv) != 2) 4187 ###### return Nullsv; 4188 799 sv = newSVsv(sv); 4189 799 SvREADONLY_on(sv); 4190 799 return sv; 4191 } 4192 else { 4193 154 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE) 4194 154 sv = &PL_sv_undef; /* an arbitrary non-null value */ 4195 } 4196 } 4197 else { 4198 1606 return Nullsv; 4199 } 4200 } 4201 306 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 9 { 4222 9 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 96565 { 4228 dVAR; 4229 96565 const char *aname; 4230 96565 GV *gv; 4231 96565 const char *ps; 4232 96565 STRLEN ps_len; 4233 96565 register CV *cv=0; 4234 96565 SV *const_sv; 4235 96565 I32 gv_fetch_flags; 4236 4237 96565 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : Nullch; 4238 4239 96565 if (proto) { 4240 6315 assert(proto->op_type == OP_CONST); 4241 6315 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len); 4242 } 4243 else 4244 90250 ps = Nullch; 4245 4246 96565 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 96565 aname = Nullch; 4255 4256 96565 gv_fetch_flags = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) 4257 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT; 4258 96565 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 96565 if (o) 4264 92648 SAVEFREEOP(o); 4265 96565 if (proto) 4266 6315 SAVEFREEOP(proto); 4267 96565 if (attrs) 4268 ###### SAVEFREEOP(attrs); 4269 4270 96565 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at 4271 maximum a prototype before. */ 4272 6980 if (SvTYPE(gv) > SVt_NULL) { 4273 17 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 17 cv_ckproto((CV*)gv, NULL, ps); 4279 } 4280 6980 if (ps) 4281 604 sv_setpvn((SV*)gv, ps, ps_len); 4282 else 4283 6376 sv_setiv((SV*)gv, -1); 4284 6980 SvREFCNT_dec(PL_compcv); 4285 6980 cv = PL_compcv = NULL; 4286 6980 PL_sub_generation++; 4287 6980 goto done; 4288 } 4289 4290 89585 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 89585 if (!block || !ps || *ps || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) 4299 85760 const_sv = Nullsv; 4300 else 4301 3825 const_sv = op_const_sv(block, Nullcv); 4302 4303 89585 if (cv) { 4304 1486 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 1486 if (exists || SvPOK(cv)) 4317 660 cv_ckproto(cv, gv, ps); 4318 /* already defined (or promised)? */ 4319 1486 if (exists || GvASSUMECV(gv)) { 4320 50 if (!block && !attrs) { 4321 ###### if (CvFLAGS(PL_compcv)) { 4322 /* might have had built-in attrs applied */ 4323 ###### CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS); 4324 } 4325 /* just a "sub foo;" when &foo is already defined */ 4326 ###### SAVEFREESV(PL_compcv); 4327 ###### goto done; 4328 } 4329 /* ahem, death to those who redefine active sort subs */ 4330 50 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv)) 4331 ###### Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name); 4332 50 if (block) { 4333 50 if (ckWARN(WARN_REDEFINE) 4334 || (CvCONST(cv) 4335 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv)))) 4336 { 4337 1 const line_t oldline = CopLINE(PL_curcop); 4338 1 if (PL_copline != NOLINE) 4339 1 CopLINE_set(PL_curcop, PL_copline); 4340 1 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), 4341 CvCONST(cv) ? "Constant subroutine %s redefined" 4342 : "Subroutine %s redefined", name); 4343 1 CopLINE_set(PL_curcop, oldline); 4344 } 4345 50 SvREFCNT_dec(cv); 4346 50 cv = Nullcv; 4347 } 4348 } 4349 } 4350 89585 if (const_sv) { 4351 2144 (void)SvREFCNT_inc(const_sv); 4352 2144 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 2144 GvCV(gv) = Nullcv; 4361 2144 cv = newCONSTSUB(NULL, name, const_sv); 4362 } 4363 2144 op_free(block); 4364 2144 SvREFCNT_dec(PL_compcv); 4365 2144 PL_compcv = NULL; 4366 2144 PL_sub_generation++; 4367 2144 goto done; 4368 } 4369 87441 if (attrs) { 4370 ###### HV *stash; 4371 ###### SV *rcv; 4372 4373 /* Need to do a C 4374 * before we clobber PL_compcv. 4375 */ 4376 ###### if (cv && !block) { 4377 ###### rcv = (SV*)cv; 4378 /* Might have had built-in attributes applied -- propagate them. */ 4379 ###### CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS); 4380 ###### if (CvGV(cv) && GvSTASH(CvGV(cv))) 4381 ###### 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 ###### rcv = (SV*)PL_compcv; 4390 ###### if (name && GvSTASH(gv)) 4391 ###### stash = GvSTASH(gv); 4392 else 4393 ###### stash = PL_curstash; 4394 } 4395 ###### apply_attrs(stash, rcv, attrs, FALSE); 4396 } 4397 87441 if (cv) { /* must reuse cv if autoloaded */ 4398 1436 if (!block) { 4399 /* got here with just attrs -- work done, so bug out */ 4400 ###### SAVEFREESV(PL_compcv); 4401 ###### goto done; 4402 } 4403 /* transfer PL_compcv to cv */ 4404 1436 cv_undef(cv); 4405 1436 CvFLAGS(cv) = CvFLAGS(PL_compcv); 4406 1436 if (!CvWEAKOUTSIDE(cv)) 4407 1436 SvREFCNT_dec(CvOUTSIDE(cv)); 4408 1436 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv); 4409 1436 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv); 4410 1436 CvOUTSIDE(PL_compcv) = 0; 4411 1436 CvPADLIST(cv) = CvPADLIST(PL_compcv); 4412 1436 CvPADLIST(PL_compcv) = 0; 4413 /* inner references to PL_compcv must be fixed up ... */ 4414 1436 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv); 4415 /* ... before we throw it away */ 4416 1436 SvREFCNT_dec(PL_compcv); 4417 1436 PL_compcv = cv; 4418 1436 if (PERLDB_INTER)/* Advice debugger on the new sub. */ 4419 ###### ++PL_sub_generation; 4420 } 4421 else { 4422 86005 cv = PL_compcv; 4423 86005 if (name) { 4424 82088 GvCV(gv) = cv; 4425 82088 GvCVGEN(gv) = 0; 4426 82088 PL_sub_generation++; 4427 } 4428 } 4429 87441 CvGV(cv) = gv; 4430 87441 CvFILE_set_from_cop(cv, PL_curcop); 4431 87441 CvSTASH(cv) = PL_curstash; 4432 4433 87441 if (ps) 4434 3567 sv_setpvn((SV*)cv, ps, ps_len); 4435 4436 87441 if (PL_error_count) { 4437 ###### op_free(block); 4438 ###### block = Nullop; 4439 ###### if (name) { 4440 ###### const char *s = strrchr(name, ':'); 4441 ###### s = s ? s+1 : name; 4442 ###### if (strEQ(s, "BEGIN")) { 4443 ###### const char not_safe[] = 4444 ###### "BEGIN not safe after errors--compilation aborted"; 4445 ###### if (PL_in_eval & EVAL_KEEPERR) 4446 ###### Perl_croak(aTHX_ not_safe); 4447 else { 4448 /* force display of errors found but not reported */ 4449 ###### sv_catpv(ERRSV, not_safe); 4450 ###### Perl_croak(aTHX_ "%"SVf, ERRSV); 4451 } 4452 } 4453 } 4454 } 4455 87441 if (!block) 4456 15 goto done; 4457 4458 87426 if (CvLVALUE(cv)) { 4459 ###### CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0, 4460 mod(scalarseq(block), OP_LEAVESUBLV)); 4461 } 4462 else { 4463 /* This makes sub {}; work as expected. */ 4464 87426 if (block->op_type == OP_STUB) { 4465 1045 op_free(block); 4466 1045 block = newSTATEOP(0, Nullch, 0); 4467 } 4468 87426 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block)); 4469 } 4470 87426 CvROOT(cv)->op_private |= OPpREFCOUNTED; 4471 87426 OpREFCNT_set(CvROOT(cv), 1); 4472 87426 CvSTART(cv) = LINKLIST(CvROOT(cv)); 4473 87426 CvROOT(cv)->op_next = 0; 4474 87426 CALL_PEEP(CvSTART(cv)); 4475 4476 /* now that optimizer has done its work, adjust pad values */ 4477 4478 87426 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB); 4479 4480 87426 if (CvCLONE(cv)) { 4481 548 assert(!CvCONST(cv)); 4482 548 if (ps && !*ps && op_const_sv(block, cv)) 4483 154 CvCONST_on(cv); 4484 } 4485 4486 87426 if (name || aname) { 4487 83509 const char *s; 4488 83509 const char *tname = (name ? name : aname); 4489 4490 83509 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) { 4491 ###### SV *sv = NEWSV(0,0); 4492 ###### SV *tmpstr = sv_newmortal(); 4493 ###### GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV); 4494 ###### CV *pcv; 4495 ###### HV *hv; 4496 4497 ###### Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld", 4498 CopFILE(PL_curcop), 4499 (long)PL_subline, (long)CopLINE(PL_curcop)); 4500 ###### gv_efullname3(tmpstr, gv, Nullch); 4501 ###### hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0); 4502 ###### hv = GvHVn(db_postponed); 4503 ###### 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 83509 if ((s = strrchr(tname,':'))) 4515 54 s++; 4516 else 4517 83455 s = tname; 4518 4519 83509 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I') 4520 58626 goto done; 4521 4522 24883 if (strEQ(s, "BEGIN") && !PL_error_count) { 4523 23564 const I32 oldscope = PL_scopestack_ix; 4524 23564 ENTER; 4525 23564 SAVECOPFILE(&PL_compiling); 4526 23564 SAVECOPLINE(&PL_compiling); 4527 4528 23564 if (!PL_beginav) 4529 522 PL_beginav = newAV(); 4530 23564 DEBUG_x( dump_sub(gv) ); 4531 23564 av_push(PL_beginav, (SV*)cv); 4532 23564 GvCV(gv) = 0; /* cv has been hijacked */ 4533 23564 call_list(oldscope, PL_beginav); 4534 4535 23564 PL_curcop = &PL_compiling; 4536 23564 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); 4537 23564 LEAVE; 4538 } 4539 1319 else if (strEQ(s, "END") && !PL_error_count) { 4540 1 if (!PL_endav) 4541 1 PL_endav = newAV(); 4542 1 DEBUG_x( dump_sub(gv) ); 4543 1 av_unshift(PL_endav, 1); 4544 1 av_store(PL_endav, 0, (SV*)cv); 4545 1 GvCV(gv) = 0; /* cv has been hijacked */ 4546 } 4547 1318 else if (strEQ(s, "CHECK") && !PL_error_count) { 4548 ###### if (!PL_checkav) 4549 ###### PL_checkav = newAV(); 4550 ###### DEBUG_x( dump_sub(gv) ); 4551 ###### if (PL_main_start && ckWARN(WARN_VOID)) 4552 ###### Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block"); 4553 ###### av_unshift(PL_checkav, 1); 4554 ###### av_store(PL_checkav, 0, (SV*)cv); 4555 ###### GvCV(gv) = 0; /* cv has been hijacked */ 4556 } 4557 1318 else if (strEQ(s, "INIT") && !PL_error_count) { 4558 ###### if (!PL_initav) 4559 ###### PL_initav = newAV(); 4560 ###### DEBUG_x( dump_sub(gv) ); 4561 ###### if (PL_main_start && ckWARN(WARN_VOID)) 4562 ###### Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block"); 4563 ###### av_push(PL_initav, (SV*)cv); 4564 ###### GvCV(gv) = 0; /* cv has been hijacked */ 4565 } 4566 } 4567 4568 done: 4569 96565 PL_copline = NOLINE; 4570 96565 LEAVE_SCOPE(floor); 4571 96565 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 2943 { 4587 dVAR; 4588 2943 CV* cv; 4589 4590 2943 ENTER; 4591 4592 2943 SAVECOPLINE(PL_curcop); 4593 2943 CopLINE_set(PL_curcop, PL_copline); 4594 4595 2943 SAVEHINTS(); 4596 2943 PL_hints &= ~HINT_BLOCK_SCOPE; 4597 4598 2943 if (stash) { 4599 799 SAVESPTR(PL_curstash); 4600 799 SAVECOPSTASH(PL_curcop); 4601 799 PL_curstash = stash; 4602 799 CopSTASH_set(PL_curcop,stash); 4603 } 4604 4605 2943 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop))); 4606 2943 CvXSUBANY(cv).any_ptr = sv; 4607 2943 CvCONST_on(cv); 4608 2943 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */ 4609 4610 2943 if (stash) 4611 CopSTASH_free(PL_curcop); 4612 4613 2943 LEAVE; 4614 4615 2943 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 24413 { 4629 24413 GV *gv = gv_fetchpv(name ? name : 4630 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"), 4631 24413 GV_ADDMULTI, SVt_PVCV); 4632 24413 register CV *cv; 4633 4634 24413 if (!subaddr) 4635 ###### Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename); 4636 4637 24413 if ((cv = (name ? GvCV(gv) : Nullcv))) { 4638 ###### if (GvCVGEN(gv)) { 4639 /* just a cached method */ 4640 ###### SvREFCNT_dec(cv); 4641 ###### cv = Nullcv; 4642 } 4643 ###### 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 ###### 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 ###### SvREFCNT_dec(cv); 4666 ###### cv = Nullcv; 4667 } 4668 } 4669 4670 24413 if (cv) /* must reuse cv if autoloaded */ 4671 ###### cv_undef(cv); 4672 else { 4673 24413 cv = (CV*)NEWSV(1105,0); 4674 24413 sv_upgrade((SV *)cv, SVt_PVCV); 4675 24413 if (name) { 4676 23614 GvCV(gv) = cv; 4677 23614 GvCVGEN(gv) = 0; 4678 23614 PL_sub_generation++; 4679 } 4680 } 4681 24413 CvGV(cv) = gv; 4682 24413 (void)gv_fetchfile(filename); 4683 24413 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be 4684 an external constant string */ 4685 24413 CvXSUB(cv) = subaddr; 4686 4687 24413 if (name) { 4688 23614 const char *s = strrchr(name,':'); 4689 23614 if (s) 4690 21470 s++; 4691 else 4692 2144 s = name; 4693 4694 23614 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I') 4695 23614 goto done; 4696 4697 ###### 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 ###### else if (strEQ(s, "END")) { 4704 ###### if (!PL_endav) 4705 ###### PL_endav = newAV(); 4706 ###### av_unshift(PL_endav, 1); 4707 ###### av_store(PL_endav, 0, (SV*)cv); 4708 ###### GvCV(gv) = 0; /* cv has been hijacked */ 4709 } 4710 ###### 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 ###### 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 799 CvANON_on(cv); 4730 4731 done: 4732 24413 return cv; 4733 } 4734 4735 void 4736 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) 4737 ###### { 4738 ###### register CV *cv; 4739 ###### GV *gv; 4740 4741 ###### if (o) 4742 ###### gv = gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM); 4743 else 4744 ###### 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 ###### GvMULTI_on(gv); 4752 ###### if ((cv = GvFORM(gv))) { 4753 ###### if (ckWARN(WARN_REDEFINE)) { 4754 ###### const line_t oldline = CopLINE(PL_curcop); 4755 ###### if (PL_copline != NOLINE) 4756 ###### CopLINE_set(PL_curcop, PL_copline); 4757 ###### Perl_warner(aTHX_ packWARN(WARN_REDEFINE), 4758 o ? "Format %"SVf" redefined" 4759 : "Format STDOUT redefined" ,cSVOPo->op_sv); 4760 ###### CopLINE_set(PL_curcop, oldline); 4761 } 4762 ###### SvREFCNT_dec(cv); 4763 } 4764 ###### cv = PL_compcv; 4765 ###### GvFORM(gv) = cv; 4766 ###### CvGV(cv) = gv; 4767 ###### CvFILE_set_from_cop(cv, PL_curcop); 4768 4769 4770 ###### pad_tidy(padtidy_FORMAT); 4771 ###### CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block)); 4772 ###### CvROOT(cv)->op_private |= OPpREFCOUNTED; 4773 ###### OpREFCNT_set(CvROOT(cv), 1); 4774 ###### CvSTART(cv) = LINKLIST(CvROOT(cv)); 4775 ###### CvROOT(cv)->op_next = 0; 4776 ###### CALL_PEEP(CvSTART(cv)); 4777 ###### op_free(o); 4778 ###### PL_copline = NOLINE; 4779 ###### LEAVE_SCOPE(floor); 4780 } 4781 4782 OP * 4783 Perl_newANONLIST(pTHX_ OP *o) 4784 4825 { 4785 4825 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 6058 { 4792 6058 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 3917 { 4805 3917 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 23908 { 4813 dVAR; 4814 23908 switch (o->op_type) { 4815 case OP_PADSV: 4816 8390 o->op_type = OP_PADAV; 4817 8390 o->op_ppaddr = PL_ppaddr[OP_PADAV]; 4818 8390 return ref(o, OP_RV2AV); 4819 4820 case OP_RV2SV: 4821 15518 o->op_type = OP_RV2AV; 4822 15518 o->op_ppaddr = PL_ppaddr[OP_RV2AV]; 4823 15518 ref(o, OP_RV2AV); 4824 15518 break; 4825 4826 default: 4827 ###### if (ckWARN_d(WARN_INTERNAL)) 4828 ###### Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV"); 4829 15518 break; 4830 } 4831 15518 return o; 4832 } 4833 4834 OP * 4835 Perl_oopsHV(pTHX_ OP *o) 4836 67351 { 4837 dVAR; 4838 67351 switch (o->op_type) { 4839 case OP_PADSV: 4840 case OP_PADAV: 4841 21978 o->op_type = OP_PADHV; 4842 21978 o->op_ppaddr = PL_ppaddr[OP_PADHV]; 4843 21978 return ref(o, OP_RV2HV); 4844 4845 case OP_RV2SV: 4846 case OP_RV2AV: 4847 45373 o->op_type = OP_RV2HV; 4848 45373 o->op_ppaddr = PL_ppaddr[OP_RV2HV]; 4849 45373 ref(o, OP_RV2HV); 4850 45373 break; 4851 4852 default: 4853 ###### if (ckWARN_d(WARN_INTERNAL)) 4854 ###### Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV"); 4855 45373 break; 4856 } 4857 45373 return o; 4858 } 4859 4860 OP * 4861 Perl_newAVREF(pTHX_ OP *o) 4862 176367 { 4863 dVAR; 4864 176367 if (o->op_type == OP_PADANY) { 4865 69200 o->op_type = OP_PADAV; 4866 69200 o->op_ppaddr = PL_ppaddr[OP_PADAV]; 4867 69200 return o; 4868 } 4869 107167 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV) 4870 && ckWARN(WARN_DEPRECATED)) { 4871 ###### Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), 4872 "Using an array as a reference is deprecated"); 4873 } 4874 107167 return newUNOP(OP_RV2AV, 0, scalar(o)); 4875 } 4876 4877 OP * 4878 Perl_newGVREF(pTHX_ I32 type, OP *o) 4879 32719 { 4880 32719 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT) 4881 5887 return newUNOP(OP_NULL, 0, o); 4882 26832 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type); 4883 } 4884 4885 OP * 4886 Perl_newHVREF(pTHX_ OP *o) 4887 68499 { 4888 dVAR; 4889 68499 if (o->op_type == OP_PADANY) { 4890 13343 o->op_type = OP_PADHV; 4891 13343 o->op_ppaddr = PL_ppaddr[OP_PADHV]; 4892 13343 return o; 4893 } 4894 55156 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV) 4895 && ckWARN(WARN_DEPRECATED)) { 4896 ###### Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), 4897 "Using a hash as a reference is deprecated"); 4898 } 4899 55156 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 113417 { 4914 113417 return newUNOP(OP_RV2CV, flags, scalar(o)); 4915 } 4916 4917 OP * 4918 Perl_newSVREF(pTHX_ OP *o) 4919 1130743 { 4920 dVAR; 4921 1130743 if (o->op_type == OP_PADANY) { 4922 853136 o->op_type = OP_PADSV; 4923 853136 o->op_ppaddr = PL_ppaddr[OP_PADSV]; 4924 853136 return o; 4925 } 4926 277607 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) { 4927 ###### o->op_flags |= OPpDONE_SVREF; 4928 ###### return o; 4929 } 4930 277607 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 3917 { 4939 3917 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type); 4940 3917 cSVOPo->op_sv = Nullsv; 4941 3917 return o; 4942 } 4943 4944 OP * 4945 Perl_ck_bitop(pTHX_ OP *o) 4946 16637 { 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 16637 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); 4956 16637 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 3412 const OP * const left = cBINOPo->op_first; 4962 3412 const OP * const right = left->op_sibling; 4963 3412 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 ###### if (ckWARN(WARN_PRECEDENCE)) 4968 ###### 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 16637 return o; 4975 } 4976 4977 OP * 4978 Perl_ck_concat(pTHX_ OP *o) 4979 215069 { 4980 215069 const OP *kid = cUNOPo->op_first; 4981 215069 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) && 4982 !(kUNOP->op_first->op_flags & OPf_MOD)) 4983 110827 o->op_flags |= OPf_STACKED; 4984 215069 return o; 4985 } 4986 4987 OP * 4988 Perl_ck_spair(pTHX_ OP *o) 4989 45359 { 4990 dVAR; 4991 45359 if (o->op_flags & OPf_KIDS) { 4992 45045 OP* newop; 4993 45045 OP* kid; 4994 45045 const OPCODE type = o->op_type; 4995 45045 o = modkids(ck_fun(o), type); 4996 45045 kid = cUNOPo->op_first; 4997 45045 newop = kUNOP->op_first->op_sibling; 4998 45045 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 28318 return o; 5005 } 5006 16727 op_free(kUNOP->op_first); 5007 16727 kUNOP->op_first = newop; 5008 } 5009 17041 o->op_ppaddr = PL_ppaddr[++o->op_type]; 5010 17041 return ck_fun(o); 5011 } 5012 5013 OP * 5014 Perl_ck_delete(pTHX_ OP *o) 5015 1660 { 5016 1660 o = ck_fun(o); 5017 1660 o->op_private = 0; 5018 1660 if (o->op_flags & OPf_KIDS) { 5019 1660 OP *kid = cUNOPo->op_first; 5020 1660 switch (kid->op_type) { 5021 case OP_ASLICE: 5022 ###### o->op_flags |= OPf_SPECIAL; 5023 /* FALL THROUGH */ 5024 case OP_HSLICE: 5025 42 o->op_private |= OPpSLICE; 5026 42 break; 5027 case OP_AELEM: 5028 ###### o->op_flags |= OPf_SPECIAL; 5029 /* FALL THROUGH */ 5030 case OP_HELEM: 5031 ###### break; 5032 default: 5033 ###### Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice", 5034 OP_DESC(o)); 5035 } 5036 1660 op_null(kid); 5037 } 5038 1660 return o; 5039 } 5040 5041 OP * 5042 Perl_ck_die(pTHX_ OP *o) 5043 8846 { 5044 #ifdef VMS 5045 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH; 5046 #endif 5047 8846 return ck_fun(o); 5048 } 5049 5050 OP * 5051 Perl_ck_eof(pTHX_ OP *o) 5052 49 { 5053 49 const I32 type = o->op_type; 5054 5055 49 if (o->op_flags & OPf_KIDS) { 5056 48 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 48 return ck_fun(o); 5061 } 5062 1 return o; 5063 } 5064 5065 OP * 5066 Perl_ck_eval(pTHX_ OP *o) 5067 5930 { 5068 dVAR; 5069 5930 PL_hints |= HINT_BLOCK_SCOPE; 5070 5930 if (o->op_flags & OPf_KIDS) { 5071 5930 SVOP *kid = (SVOP*)cUNOPo->op_first; 5072 5073 5930 if (!kid) { 5074 ###### o->op_flags &= ~OPf_KIDS; 5075 ###### op_null(o); 5076 } 5077 5930 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) { 5078 3455 LOGOP *enter; 5079 5080 3455 cUNOPo->op_first = 0; 5081 3455 op_free(o); 5082 5083 3455 NewOp(1101, enter, 1, LOGOP); 5084 3455 enter->op_type = OP_ENTERTRY; 5085 3455 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY]; 5086 3455 enter->op_private = 0; 5087 5088 /* establish postfix order */ 5089 3455 enter->op_next = (OP*)enter; 5090 5091 3455 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid); 5092 3455 o->op_type = OP_LEAVETRY; 5093 3455 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY]; 5094 3455 enter->op_other = o; 5095 3455 return o; 5096 } 5097 else { 5098 2475 scalar((OP*)kid); 5099 2475 PL_cv_has_eval = 1; 5100 } 5101 } 5102 else { 5103 ###### op_free(o); 5104 ###### o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP()); 5105 } 5106 2475 o->op_targ = (PADOFFSET)PL_hints; 5107 2475 return o; 5108 } 5109 5110 OP * 5111 Perl_ck_exit(pTHX_ OP *o) 5112 729 { 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 729 return ck_fun(o); 5123 } 5124 5125 OP * 5126 Perl_ck_exec(pTHX_ OP *o) 5127 611 { 5128 611 if (o->op_flags & OPf_STACKED) { 5129 ###### OP *kid; 5130 ###### o = ck_fun(o); 5131 ###### kid = cUNOPo->op_first->op_sibling; 5132 ###### if (kid->op_type == OP_RV2GV) 5133 ###### op_null(kid); 5134 } 5135 else 5136 611 o = listkids(o); 5137 611 return o; 5138 } 5139 5140 OP * 5141 Perl_ck_exists(pTHX_ OP *o) 5142 6042 { 5143 6042 o = ck_fun(o); 5144 6042 if (o->op_flags & OPf_KIDS) { 5145 6042 OP *kid = cUNOPo->op_first; 5146 6042 if (kid->op_type == OP_ENTERSUB) { 5147 ###### (void) ref(kid, o->op_type); 5148 ###### if (kid->op_type != OP_RV2CV && !PL_error_count) 5149 ###### Perl_croak(aTHX_ "%s argument is not a subroutine name", 5150 OP_DESC(o)); 5151 ###### o->op_private |= OPpEXISTS_SUB; 5152 } 5153 6042 else if (kid->op_type == OP_AELEM) 5154 ###### o->op_flags |= OPf_SPECIAL; 5155 6042 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 6042 op_null(kid); 5159 } 5160 6042 return o; 5161 } 5162 5163 OP * 5164 Perl_ck_rvconst(pTHX_ register OP *o) 5165 606434 { 5166 dVAR; 5167 606434 SVOP *kid = (SVOP*)cUNOPo->op_first; 5168 5169 606434 o->op_private |= (PL_hints & HINT_STRICT_REFS); 5170 606434 if (kid->op_type == OP_CONST) { 5171 481156 int iscv; 5172 481156 GV *gv; 5173 481156 SV * const kidsv = kid->op_sv; 5174 5175 /* Is it a constant from cv_const_sv()? */ 5176 481156 if (SvROK(kidsv) && SvREADONLY(kidsv)) { 5177 ###### SV *rsv = SvRV(kidsv); 5178 ###### const int svtype = SvTYPE(rsv); 5179 ###### const char *badtype = Nullch; 5180 5181 ###### switch (o->op_type) { 5182 case OP_RV2SV: 5183 ###### if (svtype > SVt_PVMG) 5184 ###### badtype = "a SCALAR"; 5185 ###### break; 5186 case OP_RV2AV: 5187 ###### if (svtype != SVt_PVAV) 5188 ###### badtype = "an ARRAY"; 5189 ###### break; 5190 case OP_RV2HV: 5191 ###### if (svtype != SVt_PVHV) 5192 ###### badtype = "a HASH"; 5193 ###### break; 5194 case OP_RV2CV: 5195 ###### if (svtype != SVt_PVCV) 5196 ###### badtype = "a CODE"; 5197 break; 5198 } 5199 ###### if (badtype) 5200 ###### Perl_croak(aTHX_ "Constant is not %s reference", badtype); 5201 ###### return o; 5202 } 5203 481156 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) { 5204 40124 const char *badthing = Nullch; 5205 40124 switch (o->op_type) { 5206 case OP_RV2SV: 5207 ###### badthing = "a SCALAR"; 5208 ###### break; 5209 case OP_RV2AV: 5210 ###### badthing = "an ARRAY"; 5211 ###### break; 5212 case OP_RV2HV: 5213 ###### badthing = "a HASH"; 5214 break; 5215 } 5216 40124 if (badthing) 5217 ###### 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 481156 iscv = (o->op_type == OP_RV2CV) * 2; 5230 481156 do { 5231 481156 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 481156 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++); 5243 481156 if (gv) { 5244 481156 kid->op_type = OP_GV; 5245 481156 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 481156 kid->op_sv = SvREFCNT_inc(gv); 5254 #endif 5255 481156 kid->op_private = 0; 5256 481156 kid->op_ppaddr = PL_ppaddr[OP_GV]; 5257 } 5258 } 5259 606434 return o; 5260 } 5261 5262 OP * 5263 Perl_ck_ftst(pTHX_ OP *o) 5264 27470 { 5265 dVAR; 5266 27470 const I32 type = o->op_type; 5267 5268 27470 if (o->op_flags & OPf_REF) { 5269 /* nothing */ 5270 } 5271 23800 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) { 5272 22835 SVOP *kid = (SVOP*)cUNOPo->op_first; 5273 5274 22835 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { 5275 3670 OP *newop = newGVOP(type, OPf_REF, 5276 3670 gv_fetchsv(kid->op_sv, TRUE, SVt_PVIO)); 5277 3670 op_free(o); 5278 3670 o = newop; 5279 3670 return o; 5280 } 5281 else { 5282 19165 if ((PL_hints & HINT_FILETEST_ACCESS) && 5283 OP_IS_FILETEST_ACCESS(o)) 5284 ###### o->op_private |= OPpFT_ACCESS; 5285 } 5286 19165 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst) 5287 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT) 5288 ###### o->op_private |= OPpFT_STACKED; 5289 } 5290 else { 5291 965 op_free(o); 5292 965 if (type == OP_FTTTY) 5293 ###### o = newGVOP(type, OPf_REF, PL_stdingv); 5294 else 5295 965 o = newUNOP(type, 0, newDEFSVOP()); 5296 } 5297 23800 return o; 5298 } 5299 5300 OP * 5301 Perl_ck_fun(pTHX_ OP *o) 5302 491136 { 5303 491136 const int type = o->op_type; 5304 491136 register I32 oa = PL_opargs[type] >> OASHIFT; 5305 5306 491136 if (o->op_flags & OPf_STACKED) { 5307 ###### if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL)) 5308 ###### oa &= ~OA_OPTIONAL; 5309 else 5310 ###### return no_fh_allowed(o); 5311 } 5312 5313 491136 if (o->op_flags & OPf_KIDS) { 5314 481321 OP **tokid = &cLISTOPo->op_first; 5315 481321 register OP *kid = cLISTOPo->op_first; 5316 481321 OP *sibl; 5317 481321 I32 numargs = 0; 5318 5319 481321 if (kid->op_type == OP_PUSHMARK || 5320 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK)) 5321 { 5322 244728 tokid = &kid->op_sibling; 5323 244728 kid = kid->op_sibling; 5324 } 5325 481321 if (!kid && PL_opargs[type] & OA_DEFGV) 5326 ###### *tokid = kid = newDEFSVOP(); 5327 5328 1042025 while (oa && kid) { 5329 560704 numargs++; 5330 560704 sibl = kid->op_sibling; 5331 560704 switch (oa & 7) { 5332 case OA_SCALAR: 5333 /* list seen where single (scalar) arg expected? */ 5334 360567 if (numargs == 1 && !(oa >> 4) 5335 && kid->op_type == OP_LIST && type != OP_SCALAR) 5336 { 5337 ###### return too_many_arguments(o,PL_op_desc[type]); 5338 } 5339 360567 scalar(kid); 5340 360567 break; 5341 case OA_LIST: 5342 120660 if (oa < 16) { 5343 120660 kid = 0; 5344 120660 continue; 5345 } 5346 else 5347 ###### list(kid); 5348 ###### break; 5349 case OA_AVREF: 5350 43289 if ((type == OP_PUSH || type == OP_UNSHIFT) 5351 && !kid->op_sibling && ckWARN(WARN_SYNTAX)) 5352 ###### Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 5353 "Useless use of %s with no values", 5354 PL_op_desc[type]); 5355 5356 43289 if (kid->op_type == OP_CONST && 5357 (kid->op_private & OPpCONST_BARE)) 5358 { 5359 ###### OP *newop = newAVREF(newGVOP(OP_GV, 0, 5360 ###### gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVAV) )); 5361 ###### if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) 5362 ###### 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 ###### op_free(kid); 5366 ###### kid = newop; 5367 ###### kid->op_sibling = sibl; 5368 ###### *tokid = kid; 5369 } 5370 43289 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) 5371 ###### bad_type(numargs, "array", PL_op_desc[type], kid); 5372 43289 mod(kid, type); 5373 43289 break; 5374 case OA_HVREF: 5375 6595 if (kid->op_type == OP_CONST && 5376 (kid->op_private & OPpCONST_BARE)) 5377 { 5378 ###### OP *newop = newHVREF(newGVOP(OP_GV, 0, 5379 ###### gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVHV) )); 5380 ###### if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) 5381 ###### 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 ###### op_free(kid); 5385 ###### kid = newop; 5386 ###### kid->op_sibling = sibl; 5387 ###### *tokid = kid; 5388 } 5389 6595 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV) 5390 ###### bad_type(numargs, "hash", PL_op_desc[type], kid); 5391 6595 mod(kid, type); 5392 6595 break; 5393 case OA_CVREF: 5394 { 5395 10850 OP *newop = newUNOP(OP_NULL, 0, kid); 5396 10850 kid->op_sibling = 0; 5397 10850 linklist(kid); 5398 10850 newop->op_next = newop; 5399 10850 kid = newop; 5400 10850 kid->op_sibling = sibl; 5401 10850 *tokid = kid; 5402 } 5403 10850 break; 5404 case OA_FILEREF: 5405 16114 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) { 5406 16068 if (kid->op_type == OP_CONST && 5407 (kid->op_private & OPpCONST_BARE)) 5408 { 5409 9826 OP *newop = newGVOP(OP_GV, 0, 5410 9826 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVIO) ); 5411 9826 if (!(o->op_private & 1) && /* if not unop */ 5412 kid == cLISTOPo->op_last) 5413 695 cLISTOPo->op_last = newop; 5414 9826 op_free(kid); 5415 9826 kid = newop; 5416 } 5417 6242 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 6242 I32 flags = OPf_SPECIAL; 5423 6242 I32 priv = 0; 5424 6242 PADOFFSET targ = 0; 5425 5426 /* is this op a FH constructor? */ 5427 6242 if (is_handle_constructor(o,numargs)) { 5428 1856 const char *name = Nullch; 5429 1856 STRLEN len = 0; 5430 5431 1856 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 1856 priv = OPpDEREF; 5437 1856 if (kid->op_type == OP_PADSV) { 5438 1670 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 1670 if (name) 5443 1670 len = strlen(name); 5444 5445 } 5446 186 else if (kid->op_type == OP_RV2SV 5447 && kUNOP->op_first->op_type == OP_GV) 5448 { 5449 94 GV *gv = cGVOPx_gv(kUNOP->op_first); 5450 94 name = GvNAME(gv); 5451 94 len = GvNAMELEN(gv); 5452 } 5453 92 else if (kid->op_type == OP_AELEM 5454 || kid->op_type == OP_HELEM) 5455 { 5456 47 OP *op; 5457 5458 47 name = 0; 5459 47 if ((op = ((BINOP*)kid)->op_first)) { 5460 47 SV *tmpstr = Nullsv; 5461 47 const char *a = 5462 kid->op_type == OP_AELEM ? 5463 47 "[]" : "{}"; 5464 47 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 ###### GV *gv = cGVOPx_gv(op); 5470 ###### if (gv) 5471 ###### tmpstr = 5472 Perl_newSVpvf(aTHX_ 5473 "%s%c...%c", 5474 GvNAME(gv), 5475 a[0], a[1]); 5476 } 5477 47 else if (op->op_type == OP_PADAV 5478 || op->op_type == OP_PADHV) { 5479 /* lexicalvar $a[] or $h{} */ 5480 47 const char *padname = 5481 47 PAD_COMPNAME_PV(op->op_targ); 5482 47 if (padname) 5483 47 tmpstr = 5484 Perl_newSVpvf(aTHX_ 5485 "%s%c...%c", 5486 padname + 1, 5487 a[0], a[1]); 5488 5489 } 5490 47 if (tmpstr) { 5491 47 name = SvPV_const(tmpstr, len); 5492 47 sv_2mortal(tmpstr); 5493 } 5494 } 5495 47 if (!name) { 5496 ###### name = "__ANONIO__"; 5497 ###### len = 10; 5498 } 5499 47 mod(kid, type); 5500 } 5501 1856 if (name) { 5502 1811 SV *namesv; 5503 1811 targ = pad_alloc(OP_RV2GV, SVs_PADTMP); 5504 1811 namesv = PAD_SVl(targ); 5505 1811 SvUPGRADE(namesv, SVt_PV); 5506 1811 if (*name != '$') 5507 141 sv_setpvn(namesv, "$", 1); 5508 1811 sv_catpvn(namesv, name, len); 5509 } 5510 } 5511 6242 kid->op_sibling = 0; 5512 6242 kid = newUNOP(OP_RV2GV, flags, scalar(kid)); 5513 6242 kid->op_targ = targ; 5514 6242 kid->op_private |= priv; 5515 } 5516 16068 kid->op_sibling = sibl; 5517 16068 *tokid = kid; 5518 } 5519 16114 scalar(kid); 5520 16114 break; 5521 case OA_SCALARREF: 5522 2629 mod(scalar(kid), type); 5523 break; 5524 } 5525 440044 oa >>= 4; 5526 440044 tokid = &kid->op_sibling; 5527 440044 kid = kid->op_sibling; 5528 } 5529 481321 o->op_private |= numargs; 5530 481321 if (kid) 5531 ###### return too_many_arguments(o,OP_DESC(o)); 5532 481321 listkids(o); 5533 } 5534 9815 else if (PL_opargs[type] & OA_DEFGV) { 5535 1020 op_free(o); 5536 1020 return newUNOP(type, 0, newDEFSVOP()); 5537 } 5538 5539 490116 if (oa) { 5540 163267 while (oa & OA_OPTIONAL) 5541 18974 oa >>= 4; 5542 144293 if (oa && oa != OA_LIST) 5543 ###### return too_few_arguments(o,OP_DESC(o)); 5544 } 5545 490116 return o; 5546 } 5547 5548 OP * 5549 Perl_ck_glob(pTHX_ OP *o) 5550 279 { 5551 dVAR; 5552 279 GV *gv; 5553 5554 279 o = ck_fun(o); 5555 279 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling) 5556 ###### append_elem(OP_GLOB, o, newDEFSVOP()); 5557 5558 279 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) 5559 && GvCVu(gv) && GvIMPORTED_CV(gv))) 5560 { 5561 279 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 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) { 5567 GV *glob_gv; 5568 ENTER; 5569 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, 5570 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv); 5571 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV); 5572 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV); 5573 GvCV(gv) = GvCV(glob_gv); 5574 (void)SvREFCNT_inc((SV*)GvCV(gv)); 5575 GvIMPORTED_CV_on(gv); 5576 LEAVE; 5577 } 5578 #endif /* PERL_EXTERNAL_GLOB */ 5579 5580 279 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) { 5581 ###### append_elem(OP_GLOB, o, 5582 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++))); 5583 ###### o->op_type = OP_LIST; 5584 ###### o->op_ppaddr = PL_ppaddr[OP_LIST]; 5585 ###### cLISTOPo->op_first->op_type = OP_PUSHMARK; 5586 ###### cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK]; 5587 ###### cLISTOPo->op_first->op_targ = 0; 5588 ###### 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 ###### o = newUNOP(OP_NULL, 0, ck_subr(o)); 5593 ###### o->op_targ = OP_GLOB; /* hint at what it used to be */ 5594 ###### return o; 5595 } 5596 279 gv = newGVgen("main"); 5597 279 gv_IOadd(gv); 5598 279 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv)); 5599 279 scalarkids(o); 5600 279 return o; 5601 } 5602 5603 OP * 5604 Perl_ck_grep(pTHX_ OP *o) 5605 10850 { 5606 dVAR; 5607 10850 LOGOP *gwop; 5608 10850 OP *kid; 5609 10850 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE; 5610 10850 I32 offset; 5611 5612 10850 o->op_ppaddr = PL_ppaddr[OP_GREPSTART]; 5613 10850 NewOp(1101, gwop, 1, LOGOP); 5614 5615 10850 if (o->op_flags & OPf_STACKED) { 5616 5064 OP* k; 5617 5064 o = ck_sort(o); 5618 5064 kid = cLISTOPo->op_first->op_sibling; 5619 5064 if (!cUNOPx(kid)->op_next) 5620 ###### Perl_croak(aTHX_ "panic: ck_grep"); 5621 10128 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) { 5622 5064 kid = k; 5623 } 5624 5064 kid->op_next = (OP*)gwop; 5625 5064 o->op_flags &= ~OPf_STACKED; 5626 } 5627 10850 kid = cLISTOPo->op_first->op_sibling; 5628 10850 if (type == OP_MAPWHILE) 5629 6507 list(kid); 5630 else 5631 4343 scalar(kid); 5632 10850 o = ck_fun(o); 5633 10850 if (PL_error_count) 5634 ###### return o; 5635 10850 kid = cLISTOPo->op_first->op_sibling; 5636 10850 if (kid->op_type != OP_NULL) 5637 ###### Perl_croak(aTHX_ "panic: ck_grep"); 5638 10850 kid = kUNOP->op_first; 5639 5640 10850 gwop->op_type = type; 5641 10850 gwop->op_ppaddr = PL_ppaddr[type]; 5642 10850 gwop->op_first = listkids(o); 5643 10850 gwop->op_flags |= OPf_KIDS; 5644 10850 gwop->op_other = LINKLIST(kid); 5645 10850 kid->op_next = (OP*)gwop; 5646 10850 offset = pad_findmy("$_"); 5647 10850 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) { 5648 10850 o->op_private = gwop->op_private = 0; 5649 10850 gwop->op_targ = pad_alloc(type, SVs_PADTMP); 5650 } 5651 else { 5652 ###### o->op_private = gwop->op_private = OPpGREP_LEX; 5653 ###### gwop->op_targ = o->op_targ = offset; 5654 } 5655 5656 10850 kid = cLISTOPo->op_first->op_sibling; 5657 10850 if (!kid || !kid->op_sibling) 5658 ###### return too_few_arguments(o,OP_DESC(o)); 5659 24525 for (kid = kid->op_sibling; kid; kid = kid->op_sibling) 5660 13675 mod(kid, OP_GREPSTART); 5661 5662 10850 return (OP*)gwop; 5663 } 5664 5665 OP * 5666 Perl_ck_index(pTHX_ OP *o) 5667 1014 { 5668 1014 if (o->op_flags & OPf_KIDS) { 5669 1014 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ 5670 1014 if (kid) 5671 1014 kid = kid->op_sibling; /* get past "big" */ 5672 1014 if (kid && kid->op_type == OP_CONST) 5673 690 fbm_compile(((SVOP*)kid)->op_sv, 0); 5674 } 5675 1014 return ck_fun(o); 5676 } 5677 5678 OP * 5679 Perl_ck_lengthconst(pTHX_ OP *o) 5680 5594 { 5681 /* XXX length optimization goes here */ 5682 5594 return ck_fun(o); 5683 } 5684 5685 OP * 5686 Perl_ck_lfun(pTHX_ OP *o) 5687 16798 { 5688 16798 const OPCODE type = o->op_type; 5689 16798 return modkids(ck_fun(o), type); 5690 } 5691 5692 OP * 5693 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ 5694 35094 { 5695 35094 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) { 5696 10285 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 ###### break; /* Globals via GV can be undef */ 5703 case OP_PADAV: 5704 case OP_AASSIGN: /* Is this a good idea? */ 5705 ###### Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), 5706 "defined(@array) is deprecated"); 5707 ###### Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), 5708 "\t(Maybe you should just omit the defined()?)\n"); 5709 ###### break; 5710 case OP_RV2HV: 5711 /* This is needed for 5712 if (defined %stash::) 5713 to work. Do not break Tk. 5714 */ 5715 ###### break; /* Globals via GV can be undef */ 5716 case OP_PADHV: 5717 ###### Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), 5718 "defined(%%hash) is deprecated"); 5719 ###### 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 35094 break; 5725 } 5726 } 5727 35094 return ck_rfun(o); 5728 } 5729 5730 OP * 5731 Perl_ck_rfun(pTHX_ OP *o) 5732 35094 { 5733 35094 const OPCODE type = o->op_type; 5734 35094 return refkids(ck_fun(o), type); 5735 } 5736 5737 OP * 5738 Perl_ck_listiob(pTHX_ OP *o) 5739 18501 { 5740 18501 register OP *kid; 5741 5742 18501 kid = cLISTOPo->op_first; 5743 18501 if (!kid) { 5744 ###### o = force_list(o); 5745 ###### kid = cLISTOPo->op_first; 5746 } 5747 18501 if (kid->op_type == OP_PUSHMARK) 5748 18501 kid = kid->op_sibling; 5749 18501 if (kid && o->op_flags & OPf_STACKED) 5750 7937 kid = kid->op_sibling; 5751 10564 else if (kid && !kid->op_sibling) { /* print HANDLE; */ 5752 9817 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) { 5753 3 o->op_flags |= OPf_STACKED; /* make it a filehandle */ 5754 3 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid)); 5755 3 cLISTOPo->op_first->op_sibling = kid; 5756 3 cLISTOPo->op_last = kid; 5757 3 kid = kid->op_sibling; 5758 } 5759 } 5760 5761 18501 if (!kid) 5762 283 append_elem(o->op_type, o, newDEFSVOP()); 5763 5764 18501 return listkids(o); 5765 } 5766 5767 OP * 5768 Perl_ck_sassign(pTHX_ OP *o) 5769 217840 { 5770 217840 OP *kid = cLISTOPo->op_first; 5771 /* has a disposable target? */ 5772 217840 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 15287 OP *kkid = kid->op_sibling; 5778 5779 /* Can just relocate the target. */ 5780 15287 if (kkid && kkid->op_type == OP_PADSV 5781 && !(kkid->op_private & OPpLVAL_INTRO)) 5782 { 5783 8608 kid->op_targ = kkid->op_targ; 5784 8608 kkid->op_targ = 0; 5785 /* Now we do not need PADSV and SASSIGN. */ 5786 8608 kid->op_sibling = o->op_sibling; /* NULL */ 5787 8608 cLISTOPo->op_first = NULL; 5788 8608 op_free(o); 5789 8608 op_free(kkid); 5790 8608 kid->op_private |= OPpTARGET_MY; /* Used for context settings */ 5791 8608 return kid; 5792 } 5793 } 5794 /* optimise C to C */ 5795 209232 if (kid->op_type == OP_UNDEF) { 5796 1085 OP *kkid = kid->op_sibling; 5797 1085 if (kkid && kkid->op_type == OP_PADSV 5798 && (kkid->op_private & OPpLVAL_INTRO)) 5799 { 5800 7 cLISTOPo->op_first = NULL; 5801 7 kid->op_sibling = NULL; 5802 7 op_free(o); 5803 7 op_free(kid); 5804 7 return kkid; 5805 } 5806 } 5807 209225 return o; 5808 } 5809 5810 OP * 5811 Perl_ck_match(pTHX_ OP *o) 5812 71465 { 5813 71465 if (o->op_type != OP_QR) { 5814 70818 const I32 offset = pad_findmy("$_"); 5815 70818 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) { 5816 ###### o->op_targ = offset; 5817 ###### o->op_private |= OPpTARGET_MY; 5818 } 5819 } 5820 71465 if (o->op_type == OP_MATCH || o->op_type == OP_QR) 5821 46080 o->op_private |= OPpRUNTIME; 5822 71465 return o; 5823 } 5824 5825 OP * 5826 Perl_ck_method(pTHX_ OP *o) 5827 30963 { 5828 30963 OP *kid = cUNOPo->op_first; 5829 30963 if (kid->op_type == OP_CONST) { 5830 30838 SV* sv = kSVOP->op_sv; 5831 30838 if (!(strchr(SvPVX_const(sv), ':') || strchr(SvPVX_const(sv), '\''))) { 5832 30567 OP *cmop; 5833 30567 if (!SvREADONLY(sv) || !SvFAKE(sv)) { 5834 30567 sv = newSVpvn_share(SvPVX_const(sv), SvCUR(sv), 0); 5835 } 5836 else { 5837 ###### kSVOP->op_sv = Nullsv; 5838 } 5839 30567 cmop = newSVOP(OP_METHOD_NAMED, 0, sv); 5840 30567 op_free(o); 5841 30567 return cmop; 5842 } 5843 } 5844 396 return o; 5845 } 5846 5847 OP * 5848 Perl_ck_null(pTHX_ OP *o) 5849 4850472 { 5850 4850472 return o; 5851 } 5852 5853 OP * 5854 Perl_ck_open(pTHX_ OP *o) 5855 4551 { 5856 4551 HV *table = GvHV(PL_hintgv); 5857 4551 if (table) { 5858 ###### SV **svp; 5859 ###### I32 mode; 5860 ###### svp = hv_fetch(table, "open_IN", 7, FALSE); 5861 ###### if (svp && *svp) { 5862 ###### mode = mode_from_discipline(*svp); 5863 ###### if (mode & O_BINARY) 5864 ###### o->op_private |= OPpOPEN_IN_RAW; 5865 ###### else if (mode & O_TEXT) 5866 ###### o->op_private |= OPpOPEN_IN_CRLF; 5867 } 5868 5869 ###### svp = hv_fetch(table, "open_OUT", 8, FALSE); 5870 ###### if (svp && *svp) { 5871 ###### mode = mode_from_discipline(*svp); 5872 4551 if (mode & O_BINARY) 5873 4551 o->op_private |= OPpOPEN_OUT_RAW; 5874 4551 else if (mode & O_TEXT) 5875 4551 o->op_private |= OPpOPEN_OUT_CRLF; 5876 } 5877 } 5878 4551 if (o->op_type == OP_BACKTICK) 5879 779 return o; 5880 { 5881 /* In case of three-arg dup open remove strictness 5882 * from the last arg if it is a bareword. */ 5883 3772 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */ 5884 3772 OP *last = cLISTOPx(o)->op_last; /* The bareword. */ 5885 3772 OP *oa; 5886 3772 const char *mode; 5887 5888 3772 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 ###### last->op_private &= ~OPpCONST_STRICT; 5898 } 5899 3772 return ck_fun(o); 5900 } 5901 5902 OP * 5903 Perl_ck_repeat(pTHX_ OP *o) 5904 1844 { 5905 1844 if (cBINOPo->op_first->op_flags & OPf_PARENS) { 5906 1558 o->op_private |= OPpREPEAT_DOLIST; 5907 1558 cBINOPo->op_first = force_list(cBINOPo->op_first); 5908 } 5909 else 5910 286 scalar(o); 5911 1844 return o; 5912 } 5913 5914 OP * 5915 Perl_ck_require(pTHX_ OP *o) 5916 47694 { 5917 47694 GV* gv; 5918 5919 47694 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */ 5920 47694 SVOP *kid = (SVOP*)cUNOPo->op_first; 5921 5922 47694 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { 5923 42123 SV *sv = kid->op_sv; 5924 42123 U32 was_readonly = SvREADONLY(sv); 5925 42123 char *s; 5926 5927 42123 if (was_readonly) { 5928 42123 if (SvFAKE(sv)) { 5929 ###### sv_force_normal_flags(sv, 0); 5930 ###### assert(!SvREADONLY(sv)); 5931 ###### was_readonly = 0; 5932 } else { 5933 42123 SvREADONLY_off(sv); 5934 } 5935 } 5936 5937 339944 for (s = SvPVX(sv); *s; s++) { 5938 297821 if (*s == ':' && s[1] == ':') { 5939 10492 *s = '/'; 5940 10492 Move(s+2, s+1, strlen(s+2)+1, char); 5941 10492 SvCUR_set(sv, SvCUR(sv) - 1); 5942 } 5943 } 5944 42123 sv_catpvn(sv, ".pm", 3); 5945 42123 SvFLAGS(sv) |= was_readonly; 5946 } 5947 } 5948 5949 /* handle override, if any */ 5950 47694 gv = gv_fetchpv("require", FALSE, SVt_PVCV); 5951 47694 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) 5952 47694 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV); 5953 5954 47694 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) { 5955 ###### OP *kid = cUNOPo->op_first; 5956 ###### cUNOPo->op_first = 0; 5957 ###### op_free(o); 5958 ###### 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 47694 return ck_fun(o); 5966 } 5967 5968 OP * 5969 Perl_ck_return(pTHX_ OP *o) 5970 44139 { 5971 44139 if (CvLVALUE(PL_compcv)) { 5972 ###### OP *kid; 5973 ###### for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling) 5974 ###### mod(kid, OP_LEAVESUBLV); 5975 } 5976 44139 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 281 { 5992 dVAR; 5993 281 OP* kid; 5994 281 if (o->op_flags & OPf_KIDS) { 5995 281 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ 5996 281 if (kid && kid->op_sibling) { 5997 ###### o->op_type = OP_SSELECT; 5998 ###### o->op_ppaddr = PL_ppaddr[OP_SSELECT]; 5999 ###### o = ck_fun(o); 6000 ###### return fold_constants(o); 6001 } 6002 } 6003 281 o = ck_fun(o); 6004 281 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ 6005 281 if (kid && kid->op_type == OP_RV2GV) 6006 184 kid->op_private &= ~HINT_STRICT_REFS; 6007 281 return o; 6008 } 6009 6010 OP * 6011 Perl_ck_shift(pTHX_ OP *o) 6012 44591 { 6013 44591 const I32 type = o->op_type; 6014 6015 44591 if (!(o->op_flags & OPf_KIDS)) { 6016 19681 OP *argop; 6017 6018 19681 op_free(o); 6019 19681 argop = newUNOP(OP_RV2AV, 0, 6020 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv))); 6021 19681 return newUNOP(type, 0, scalar(argop)); 6022 } 6023 24910 return scalar(modkids(ck_fun(o), type)); 6024 } 6025 6026 OP * 6027 Perl_ck_sort(pTHX_ OP *o) 6028 7997 { 6029 7997 OP *firstkid; 6030 6031 7997 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED) 6032 823 simplify_sort(o); 6033 7997 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ 6034 7997 if (o->op_flags & OPf_STACKED) { /* may have been cleared */ 6035 5880 OP *k = NULL; 6036 5880 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */ 6037 6038 5880 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) { 6039 5698 linklist(kid); 6040 5698 if (kid->op_type == OP_SCOPE) { 6041 3432 k = kid->op_next; 6042 3432 kid->op_next = 0; 6043 } 6044 2266 else if (kid->op_type == OP_LEAVE) { 6045 2266 if (o->op_type == OP_SORT) { 6046 50 op_null(kid); /* wipe out leave */ 6047 50 kid->op_next = kid; 6048 6049 2050 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) { 6050 2000 if (k->op_next == kid) 6051 50 k->op_next = 0; 6052 /* don't descend into loops */ 6053 1950 else if (k->op_type == OP_ENTERLOOP 6054 || k->op_type == OP_ENTERITER) 6055 { 6056 84 k = cLOOPx(k)->op_lastop; 6057 } 6058 } 6059 } 6060 else 6061 2216 kid->op_next = 0; /* just disconnect the leave */ 6062 2266 k = kLISTOP->op_first; 6063 } 6064 5698 CALL_PEEP(k); 6065 6066 5698 kid = firstkid; 6067 5698 if (o->op_type == OP_SORT) { 6068 /* provide scalar context for comparison function/block */ 6069 634 kid = scalar(kid); 6070 634 kid->op_next = kid; 6071 } 6072 else 6073 5064 kid->op_next = k; 6074 5698 o->op_flags |= OPf_SPECIAL; 6075 } 6076 182 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV) 6077 ###### op_null(firstkid); 6078 6079 5880 firstkid = firstkid->op_sibling; 6080 } 6081 6082 /* provide list context for arguments */ 6083 7997 if (o->op_type == OP_SORT) 6084 2933 list(firstkid); 6085 6086 7997 return o; 6087 } 6088 6089 STATIC void 6090 S_simplify_sort(pTHX_ OP *o) 6091 823 { 6092 823 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ 6093 823 OP *k; 6094 823 int descending; 6095 823 GV *gv; 6096 823 const char *gvname; 6097 823 if (!(o->op_flags & OPf_STACKED)) 6098 ###### return; 6099 823 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV)); 6100 823 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV)); 6101 823 kid = kUNOP->op_first; /* get past null */ 6102 823 if (kid->op_type != OP_SCOPE) 6103 232 return; 6104 591 kid = kLISTOP->op_last; /* get past scope */ 6105 591 switch(kid->op_type) { 6106 case OP_NCMP: 6107 case OP_I_NCMP: 6108 case OP_SCMP: 6109 564 break; 6110 default: 6111 564 return; 6112 } 6113 564 k = kid; /* remember this node*/ 6114 564 if (kBINOP->op_first->op_type != OP_RV2SV) 6115 557 return; 6116 7 kid = kBINOP->op_first; /* get past cmp */ 6117 7 if (kUNOP->op_first->op_type != OP_GV) 6118 ###### return; 6119 7 kid = kUNOP->op_first; /* get past rv2sv */ 6120 7 gv = kGVOP_gv; 6121 7 if (GvSTASH(gv) != PL_curstash) 6122 ###### return; 6123 7 gvname = GvNAME(gv); 6124 7 if (*gvname == 'a' && gvname[1] == '\0') 6125 7 descending = 0; 6126 ###### else if (*gvname == 'b' && gvname[1] == '\0') 6127 ###### descending = 1; 6128 else 6129 7 return; 6130 6131 7 kid = k; /* back to cmp */ 6132 7 if (kBINOP->op_last->op_type != OP_RV2SV) 6133 ###### return; 6134 7 kid = kBINOP->op_last; /* down to 2nd arg */ 6135 7 if (kUNOP->op_first->op_type != OP_GV) 6136 ###### return; 6137 7 kid = kUNOP->op_first; /* get past rv2sv */ 6138 7 gv = kGVOP_gv; 6139 7 if (GvSTASH(gv) != PL_curstash) 6140 ###### return; 6141 7 gvname = GvNAME(gv); 6142 7 if ( descending 6143 ? !(*gvname == 'a' && gvname[1] == '\0') 6144 : !(*gvname == 'b' && gvname[1] == '\0')) 6145 7 return; 6146 7 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL); 6147 7 if (descending) 6148 ###### o->op_private |= OPpSORT_DESCEND; 6149 7 if (k->op_type == OP_NCMP) 6150 7 o->op_private |= OPpSORT_NUMERIC; 6151 7 if (k->op_type == OP_I_NCMP) 6152 ###### o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER; 6153 7 kid = cLISTOPo->op_first->op_sibling; 6154 7 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */ 6155 7 op_free(kid); /* then delete it */ 6156 } 6157 6158 OP * 6159 Perl_ck_split(pTHX_ OP *o) 6160 4498 { 6161 dVAR; 6162 4498 register OP *kid; 6163 6164 4498 if (o->op_flags & OPf_STACKED) 6165 ###### return no_fh_allowed(o); 6166 6167 4498 kid = cLISTOPo->op_first; 6168 4498 if (kid->op_type != OP_NULL) 6169 ###### Perl_croak(aTHX_ "panic: ck_split"); 6170 4498 kid = kid->op_sibling; 6171 4498 op_free(cLISTOPo->op_first); 6172 4498 cLISTOPo->op_first = kid; 6173 4498 if (!kid) { 6174 ###### cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1)); 6175 ###### cLISTOPo->op_last = kid; /* There was only one element previously */ 6176 } 6177 6178 4498 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) { 6179 1380 OP *sibl = kid->op_sibling; 6180 1380 kid->op_sibling = 0; 6181 1380 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0); 6182 1380 if (cLISTOPo->op_first == cLISTOPo->op_last) 6183 ###### cLISTOPo->op_last = kid; 6184 1380 cLISTOPo->op_first = kid; 6185 1380 kid->op_sibling = sibl; 6186 } 6187 6188 4498 kid->op_type = OP_PUSHRE; 6189 4498 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE]; 6190 4498 scalar(kid); 6191 4498 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) { 6192 ###### Perl_warner(aTHX_ packWARN(WARN_REGEXP), 6193 "Use of /g modifier is meaningless in split"); 6194 } 6195 6196 4498 if (!kid->op_sibling) 6197 13 append_elem(OP_SPLIT, o, newDEFSVOP()); 6198 6199 4498 kid = kid->op_sibling; 6200 4498 scalar(kid); 6201 6202 4498 if (!kid->op_sibling) 6203 3994 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0))); 6204 6205 4498 kid = kid->op_sibling; 6206 4498 scalar(kid); 6207 6208 4498 if (kid->op_sibling) 6209 ###### return too_many_arguments(o,OP_DESC(o)); 6210 6211 4498 return o; 6212 } 6213 6214 OP * 6215 Perl_ck_join(pTHX_ OP *o) 6216 11295 { 6217 11295 if (ckWARN(WARN_SYNTAX)) { 6218 663 const OP *kid = cLISTOPo->op_first->op_sibling; 6219 663 if (kid && kid->op_type == OP_MATCH) { 6220 ###### const REGEXP *re = PM_GETRE(kPMOP); 6221 ###### const char *pmstr = re ? re->precomp : "STRING"; 6222 ###### Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 6223 "/%s/ should probably be written as \"%s\"", 6224 pmstr, pmstr); 6225 } 6226 } 6227 11295 return ck_fun(o); 6228 } 6229 6230 OP * 6231 Perl_ck_subr(pTHX_ OP *o) 6232 163081 { 6233 163081 OP *prev = ((cUNOPo->op_first->op_sibling) 6234 163081 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first; 6235 163081 OP *o2 = prev->op_sibling; 6236 163081 OP *cvop; 6237 163081 char *proto = 0; 6238 163081 CV *cv = 0; 6239 163081 GV *namegv = 0; 6240 163081 int optional = 0; 6241 163081 I32 arg = 0; 6242 163081 I32 contextclass = 0; 6243 163081 char *e = 0; 6244 163081 bool delete_op = 0; 6245 6246 163081 o->op_private |= OPpENTERSUB_HASTARG; 6247 163081 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ; 6248 163081 if (cvop->op_type == OP_RV2CV) { 6249 113417 SVOP* tmpop; 6250 113417 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER); 6251 113417 op_null(cvop); /* disable rv2cv */ 6252 113417 tmpop = (SVOP*)((UNOP*)cvop)->op_first; 6253 113417 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) { 6254 87656 GV *gv = cGVOPx_gv(tmpop); 6255 87656 cv = GvCVu(gv); 6256 87656 if (!cv) 6257 30120 tmpop->op_private |= OPpEARLY_CV; 6258 else { 6259 57536 if (SvPOK(cv)) { 6260 2055 namegv = CvANON(cv) ? gv : CvGV(cv); 6261 2055 proto = SvPV_nolen((SV*)cv); 6262 } 6263 57536 if (CvASSERTION(cv)) { 6264 ###### if (PL_hints & HINT_ASSERTING) { 6265 ###### if (PERLDB_ASSERTION && PL_curstash != PL_debstash) 6266 ###### o->op_private |= OPpENTERSUB_DB; 6267 } 6268 else { 6269 ###### delete_op = 1; 6270 ###### 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 49664 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) { 6280 49664 if (o2->op_type == OP_CONST) 6281 25891 o2->op_private &= ~OPpCONST_STRICT; 6282 23773 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 163081 o->op_private |= (PL_hints & HINT_STRICT_REFS); 6289 163081 if (PERLDB_SUB && PL_curstash != PL_debstash) 6290 ###### o->op_private |= OPpENTERSUB_DB; 6291 372066 while (o2 != cvop) { 6292 208985 if (proto) { 6293 3035 switch (*proto) { 6294 case '\0': 6295 ###### return too_many_arguments(o, gv_ename(namegv)); 6296 case ';': 6297 150 optional = 1; 6298 150 proto++; 6299 150 continue; 6300 case '$': 6301 1884 proto++; 6302 1884 arg++; 6303 1884 scalar(o2); 6304 1884 break; 6305 case '%': 6306 case '@': 6307 869 list(o2); 6308 869 arg++; 6309 869 break; 6310 case '&': 6311 125 proto++; 6312 125 arg++; 6313 125 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF) 6314 ###### bad_type(arg, 6315 arg == 1 ? "block or sub {}" : "sub {}", 6316 gv_ename(namegv), o2); 6317 ###### break; 6318 case '*': 6319 /* '*' allows any scalar type, including bareword */ 6320 ###### proto++; 6321 ###### arg++; 6322 ###### if (o2->op_type == OP_RV2GV) 6323 ###### goto wrapref; /* autoconvert GLOB -> GLOBref */ 6324 ###### else if (o2->op_type == OP_CONST) 6325 ###### o2->op_private &= ~OPpCONST_STRICT; 6326 ###### else if (o2->op_type == OP_ENTERSUB) { 6327 /* accidental subroutine, revert to bareword */ 6328 ###### OP *gvop = ((UNOP*)o2)->op_first; 6329 ###### if (gvop && gvop->op_type == OP_NULL) { 6330 ###### gvop = ((UNOP*)gvop)->op_first; 6331 ###### if (gvop) { 6332 ###### for (; gvop->op_sibling; gvop = gvop->op_sibling) 6333 ; 6334 ###### if (gvop && 6335 (gvop->op_private & OPpENTERSUB_NOPAREN) && 6336 (gvop = ((UNOP*)gvop)->op_first) && 6337 gvop->op_type == OP_GV) 6338 { 6339 ###### GV *gv = cGVOPx_gv(gvop); 6340 ###### OP *sibling = o2->op_sibling; 6341 ###### SV *n = newSVpvn("",0); 6342 ###### op_free(o2); 6343 ###### gv_fullname4(n, gv, "", FALSE); 6344 ###### o2 = newSVOP(OP_CONST, 0, n); 6345 ###### prev->op_sibling = o2; 6346 ###### o2->op_sibling = sibling; 6347 } 6348 } 6349 } 6350 } 6351 ###### scalar(o2); 6352 ###### break; 6353 case '[': case ']': 6354 7 goto oops; 6355 7 break; 6356 case '\\': 6357 7 proto++; 6358 7 arg++; 6359 again: 6360 7 switch (*proto++) { 6361 case '[': 6362 ###### if (contextclass++ == 0) { 6363 ###### e = strchr(proto, ']'); 6364 ###### if (!e || e == proto) 6365 ###### goto oops; 6366 } 6367 else 6368 ###### goto oops; 6369 ###### goto again; 6370 ###### break; 6371 case ']': 6372 ###### if (contextclass) { 6373 ###### char *p = proto; 6374 ###### const char s = *p; 6375 ###### contextclass = 0; 6376 ###### *p = '\0'; 6377 ###### while (*--p != '['); 6378 ###### bad_type(arg, Perl_form(aTHX_ "one of %s", p), 6379 gv_ename(namegv), o2); 6380 ###### *proto = s; 6381 } else 6382 ###### goto oops; 6383 ###### break; 6384 case '*': 6385 ###### if (o2->op_type == OP_RV2GV) 6386 ###### goto wrapref; 6387 ###### if (!contextclass) 6388 ###### bad_type(arg, "symbol", gv_ename(namegv), o2); 6389 ###### break; 6390 case '&': 6391 ###### if (o2->op_type == OP_ENTERSUB) 6392 ###### goto wrapref; 6393 ###### if (!contextclass) 6394 ###### bad_type(arg, "subroutine entry", gv_ename(namegv), o2); 6395 ###### break; 6396 case '$': 6397 ###### 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 ###### goto wrapref; 6403 ###### if (!contextclass) 6404 ###### bad_type(arg, "scalar", gv_ename(namegv), o2); 6405 ###### break; 6406 case '@': 6407 7 if (o2->op_type == OP_RV2AV || 6408 o2->op_type == OP_PADAV) 6409 ###### goto wrapref; 6410 ###### if (!contextclass) 6411 ###### bad_type(arg, "array", gv_ename(namegv), o2); 6412 ###### break; 6413 case '%': 6414 ###### if (o2->op_type == OP_RV2HV || 6415 o2->op_type == OP_PADHV) 6416 ###### goto wrapref; 6417 ###### if (!contextclass) 6418 ###### bad_type(arg, "hash", gv_ename(namegv), o2); 6419 ###### break; 6420 wrapref: 6421 { 6422 7 OP* kid = o2; 6423 7 OP* sib = kid->op_sibling; 6424 7 kid->op_sibling = 0; 6425 7 o2 = newUNOP(OP_REFGEN, 0, kid); 6426 7 o2->op_sibling = sib; 6427 7 prev->op_sibling = o2; 6428 } 6429 7 if (contextclass && e) { 6430 ###### proto = e + 1; 6431 ###### contextclass = 0; 6432 } 6433 break; 6434 7 default: goto oops; 6435 } 6436 7 if (contextclass) 6437 ###### 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 205950 list(o2); 6450 208835 mod(o2, OP_ENTERSUB); 6451 208835 prev = o2; 6452 208835 o2 = o2->op_sibling; 6453 } 6454 163081 if (proto && !optional && 6455 (*proto && *proto != '@' && *proto != '%' && *proto != ';')) 6456 ###### return too_few_arguments(o, gv_ename(namegv)); 6457 163081 if(delete_op) { 6458 ###### op_free(o); 6459 ###### o=newSVOP(OP_CONST, 0, newSViv(0)); 6460 } 6461 163081 return o; 6462 } 6463 6464 OP * 6465 Perl_ck_svconst(pTHX_ OP *o) 6466 1705458 { 6467 1705458 SvREADONLY_on(cSVOPo->op_sv); 6468 1705458 return o; 6469 } 6470 6471 OP * 6472 Perl_ck_trunc(pTHX_ OP *o) 6473 ###### { 6474 ###### if (o->op_flags & OPf_KIDS) { 6475 ###### SVOP *kid = (SVOP*)cUNOPo->op_first; 6476 6477 ###### if (kid->op_type == OP_NULL) 6478 ###### kid = (SVOP*)kid->op_sibling; 6479 ###### if (kid && kid->op_type == OP_CONST && 6480 (kid->op_private & OPpCONST_BARE)) 6481 { 6482 ###### o->op_flags |= OPf_SPECIAL; 6483 ###### kid->op_private &= ~OPpCONST_STRICT; 6484 } 6485 } 6486 ###### return ck_fun(o); 6487 } 6488 6489 OP * 6490 Perl_ck_unpack(pTHX_ OP *o) 6491 261 { 6492 261 OP *kid = cLISTOPo->op_first; 6493 261 if (kid->op_sibling) { 6494 261 kid = kid->op_sibling; 6495 261 if (!kid->op_sibling) 6496 ###### kid->op_sibling = newDEFSVOP(); 6497 } 6498 261 return ck_fun(o); 6499 } 6500 6501 OP * 6502 Perl_ck_substr(pTHX_ OP *o) 6503 4856 { 6504 4856 o = ck_fun(o); 6505 4856 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) { 6506 ###### OP *kid = cLISTOPo->op_first; 6507 6508 ###### if (kid->op_type == OP_NULL) 6509 ###### kid = kid->op_sibling; 6510 ###### if (kid) 6511 ###### kid->op_flags |= OPf_MOD; 6512 6513 } 6514 4856 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 614813 { 6524 dVAR; 6525 614813 register OP* oldop = 0; 6526 6527 614813 if (!o || o->op_opt) 6528 464967 return; 6529 464967 ENTER; 6530 464967 SAVEOP(); 6531 464967 SAVEVPTR(PL_curcop); 6532 16263763 for (; o; o = o->op_next) { 6533 8252267 if (o->op_opt) 6534 352869 break; 6535 7899398 PL_op = o; 6536 7899398 switch (o->op_type) { 6537 case OP_SETSTATE: 6538 case OP_NEXTSTATE: 6539 case OP_DBSTATE: 6540 774722 PL_curcop = ((COP*)o); /* for warnings */ 6541 774722 o->op_opt = 1; 6542 774722 break; 6543 6544 case OP_CONST: 6545 899697 if (cSVOPo->op_private & OPpCONST_STRICT) 6546 ###### 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 899697 o->op_opt = 1; 6573 899697 break; 6574 6575 case OP_CONCAT: 6576 214692 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) { 6577 73678 if (o->op_next->op_private & OPpTARGET_MY) { 6578 5346 if (o->op_flags & OPf_STACKED) /* chained concats */ 6579 2305 goto ignore_optimization; 6580 else { 6581 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */ 6582 3041 o->op_targ = o->op_next->op_targ; 6583 3041 o->op_next->op_targ = 0; 6584 3041 o->op_private |= OPpTARGET_MY; 6585 } 6586 } 6587 71373 op_null(o->op_next); 6588 } 6589 ignore_optimization: 6590 214692 o->op_opt = 1; 6591 214692 break; 6592 case OP_STUB: 6593 6165 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) { 6594 2665 o->op_opt = 1; 6595 2665 break; /* Scalar stub must produce undef. List stub is noop */ 6596 } 6597 1437660 goto nothin; 6598 case OP_NULL: 6599 1437660 if (o->op_targ == OP_NEXTSTATE 6600 || o->op_targ == OP_DBSTATE 6601 || o->op_targ == OP_SETSTATE) 6602 { 6603 25066 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 1437660 if (oldop && o->op_next) { 6611 1433856 oldop->op_next = o->op_next; 6612 1433856 continue; 6613 } 6614 192374 break; 6615 case OP_SCALAR: 6616 case OP_LINESEQ: 6617 case OP_SCOPE: 6618 nothin: 6619 192374 if (oldop && o->op_next) { 6620 188939 oldop->op_next = o->op_next; 6621 188939 continue; 6622 } 6623 3435 o->op_opt = 1; 6624 3435 break; 6625 6626 case OP_PADAV: 6627 case OP_GV: 6628 605899 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) { 6629 198855 OP* pop = (o->op_type == OP_PADAV) ? 6630 198855 o->op_next : o->op_next->op_next; 6631 198855 IV i; 6632 198855 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 16039 GV *gv; 6642 16039 if (cSVOPx(pop)->op_private & OPpCONST_STRICT) 6643 ###### no_bareword_allowed(pop); 6644 16039 if (o->op_type == OP_GV) 6645 9733 op_null(o->op_next); 6646 16039 op_null(pop->op_next); 6647 16039 op_null(pop); 6648 16039 o->op_flags |= pop->op_next->op_flags & OPf_MOD; 6649 16039 o->op_next = pop->op_next->op_next; 6650 16039 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST]; 6651 16039 o->op_private = (U8)i; 6652 16039 if (o->op_type == OP_GV) { 6653 9733 gv = cGVOPo_gv; 6654 9733 GvAVn(gv); 6655 } 6656 else 6657 6306 o->op_flags |= OPf_SPECIAL; 6658 16039 o->op_type = OP_AELEMFAST; 6659 } 6660 198855 o->op_opt = 1; 6661 198855 break; 6662 } 6663 6664 407044 if (o->op_next->op_type == OP_RV2SV) { 6665 216187 if (!(o->op_next->op_private & OPpDEREF)) { 6666 215942 op_null(o->op_next); 6667 215942 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO 6668 | OPpOUR_INTRO); 6669 215942 o->op_next = o->op_next->op_next; 6670 215942 o->op_type = OP_GVSV; 6671 215942 o->op_ppaddr = PL_ppaddr[OP_GVSV]; 6672 } 6673 } 6674 190857 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) { 6675 5587 GV *gv = cGVOPo_gv; 6676 5587 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) { 6677 /* XXX could check prototype here instead of just carping */ 6678 ###### SV *sv = sv_newmortal(); 6679 ###### gv_efullname3(sv, gv, Nullch); 6680 ###### Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), 6681 "%"SVf"() called too early to check prototype", 6682 sv); 6683 } 6684 } 6685 185270 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 ###### o->op_type = OP_RCATLINE; 6691 ###### o->op_flags |= OPf_STACKED; 6692 ###### o->op_ppaddr = PL_ppaddr[OP_RCATLINE]; 6693 ###### op_null(o->op_next->op_next); 6694 ###### op_null(o->op_next); 6695 } 6696 6697 407044 o->op_opt = 1; 6698 407044 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 352960 o->op_opt = 1; 6711 398187 while (cLOGOP->op_other->op_type == OP_NULL) 6712 45227 cLOGOP->op_other = cLOGOP->op_other->op_next; 6713 352960 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */ 6714 352960 break; 6715 6716 case OP_ENTERLOOP: 6717 case OP_ENTERITER: 6718 30083 o->op_opt = 1; 6719 30438 while (cLOOP->op_redoop->op_type == OP_NULL) 6720 355 cLOOP->op_redoop = cLOOP->op_redoop->op_next; 6721 30083 peep(cLOOP->op_redoop); 6722 30083 while (cLOOP->op_nextop->op_type == OP_NULL) 6723 ###### cLOOP->op_nextop = cLOOP->op_nextop->op_next; 6724 30083 peep(cLOOP->op_nextop); 6725 30083 while (cLOOP->op_lastop->op_type == OP_NULL) 6726 ###### cLOOP->op_lastop = cLOOP->op_lastop->op_next; 6727 30083 peep(cLOOP->op_lastop); 6728 30083 break; 6729 6730 case OP_QR: 6731 case OP_MATCH: 6732 case OP_SUBST: 6733 65650 o->op_opt = 1; 6734 66514 while (cPMOP->op_pmreplstart && 6735 cPMOP->op_pmreplstart->op_type == OP_NULL) 6736 864 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next; 6737 65650 peep(cPMOP->op_pmreplstart); 6738 65650 break; 6739 6740 case OP_EXEC: 6741 191 o->op_opt = 1; 6742 191 if (ckWARN(WARN_SYNTAX) && o->op_next 6743 && o->op_next->op_type == OP_NEXTSTATE) { 6744 ###### 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 ###### const line_t oldline = CopLINE(PL_curcop); 6749 6750 ###### CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next)); 6751 ###### Perl_warner(aTHX_ packWARN(WARN_EXEC), 6752 "Statement unlikely to be reached"); 6753 ###### Perl_warner(aTHX_ packWARN(WARN_EXEC), 6754 "\t(Maybe you meant system() when you said exec()?)\n"); 6755 ###### CopLINE_set(PL_curcop, oldline); 6756 } 6757 } 6758 ###### break; 6759 6760 case OP_HELEM: { 6761 100723 UNOP *rop; 6762 100723 SV *lexname; 6763 100723 GV **fields; 6764 100723 SV **svp, *sv; 6765 100723 const char *key = NULL; 6766 100723 STRLEN keylen; 6767 6768 100723 o->op_opt = 1; 6769 6770 100723 if (((BINOP*)o)->op_last->op_type != OP_CONST) 6771 35352 break; 6772 6773 /* Make the CONST have a shared SV */ 6774 65371 svp = cSVOPx_svp(((BINOP*)o)->op_last); 6775 65371 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) { 6776 65371 key = SvPV_const(sv, keylen); 6777 65371 lexname = newSVpvn_share(key, 6778 SvUTF8(sv) ? -(I32)keylen : keylen, 6779 0); 6780 65371 SvREFCNT_dec(sv); 6781 65371 *svp = lexname; 6782 } 6783 6784 65371 if ((o->op_private & (OPpLVAL_INTRO))) 6785 2962 break; 6786 6787 62409 rop = (UNOP*)((BINOP*)o)->op_first; 6788 62409 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV) 6789 28996 break; 6790 28996 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE); 6791 28996 if (!(SvFLAGS(lexname) & SVpad_TYPED)) 6792 28996 break; 6793 ###### fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE); 6794 ###### if (!fields || !GvHV(*fields)) 6795 ###### break; 6796 ###### key = SvPV_const(*svp, keylen); 6797 ###### if (!hv_fetch(GvHV(*fields), key, 6798 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE)) 6799 { 6800 ###### 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 2765 break; 6806 } 6807 6808 case OP_HSLICE: { 6809 2765 UNOP *rop; 6810 2765 SV *lexname; 6811 2765 GV **fields; 6812 2765 SV **svp; 6813 2765 const char *key; 6814 2765 STRLEN keylen; 6815 2765 SVOP *first_key_op, *key_op; 6816 6817 2765 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 1189 break; 6822 1189 rop = (UNOP*)((LISTOP*)o)->op_last; 6823 1189 if (rop->op_type != OP_RV2HV) 6824 723 break; 6825 466 if (rop->op_first->op_type == OP_PADSV) 6826 /* @$hash{qw(keys here)} */ 6827 16 rop = (UNOP*)rop->op_first; 6828 else { 6829 /* @{$hash}{qw(keys here)} */ 6830 450 if (rop->op_first->op_type == OP_SCOPE 6831 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV) 6832 { 6833 182 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last; 6834 } 6835 else 6836 198 break; 6837 } 6838 6839 198 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE); 6840 198 if (!(SvFLAGS(lexname) & SVpad_TYPED)) 6841 198 break; 6842 ###### fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE); 6843 ###### if (!fields || !GvHV(*fields)) 6844 ###### break; 6845 /* Again guessing that the pushmark can be jumped over.... */ 6846 ###### first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling) 6847 ->op_first->op_sibling; 6848 ###### for (key_op = first_key_op; key_op; 6849 key_op = (SVOP*)key_op->op_sibling) { 6850 ###### if (key_op->op_type != OP_CONST) 6851 ###### continue; 6852 ###### svp = cSVOPx_svp(key_op); 6853 ###### key = SvPV_const(*svp, keylen); 6854 ###### if (!hv_fetch(GvHV(*fields), key, 6855 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE)) 6856 { 6857 ###### 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 2933 break; 6863 } 6864 6865 case OP_SORT: { 6866 /* will point to RV2AV or PADAV op on LHS/RHS of assign */ 6867 2933 OP *oleft, *oright; 6868 2933 OP *o2; 6869 6870 /* check that RHS of sort is a single plain array */ 6871 2933 oright = cUNOPo->op_first; 6872 2933 if (!oright || oright->op_type != OP_PUSHMARK) 6873 2933 break; 6874 6875 /* reverse sort ... can be optimised. */ 6876 2933 if (!cUNOPo->op_sibling) { 6877 /* Nothing follows us on the list. */ 6878 2762 OP *reverse = o->op_next; 6879 6880 2762 if (reverse->op_type == OP_REVERSE && 6881 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) { 6882 42 OP *pushmark = cUNOPx(reverse)->op_first; 6883 42 if (pushmark && (pushmark->op_type == OP_PUSHMARK) 6884 && (cUNOPx(pushmark)->op_sibling == o)) { 6885 /* reverse -> pushmark -> sort */ 6886 42 o->op_private |= OPpSORT_REVERSE; 6887 42 op_null(reverse); 6888 42 pushmark->op_next = oright->op_next; 6889 42 op_null(oright); 6890 } 6891 } 6892 } 6893 6894 /* make @a = sort @a act in-place */ 6895 6896 2933 o->op_opt = 1; 6897 6898 2933 oright = cUNOPx(oright)->op_sibling; 6899 2933 if (!oright) 6900 ###### break; 6901 2933 if (oright->op_type == OP_NULL) { /* skip sort block/sub */ 6902 816 oright = cUNOPx(oright)->op_sibling; 6903 } 6904 6905 2933 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 340 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 340 o2 = o->op_next; 6915 340 if (!o2 || o2->op_type != OP_NULL) 6916 111 break; 6917 111 o2 = o2->op_next; 6918 111 if (!o2 || o2->op_type != OP_PUSHMARK) 6919 2 break; 6920 2 o2 = o2->op_next; 6921 2 if (o2 && o2->op_type == OP_GV) 6922 ###### o2 = o2->op_next; 6923 2 if (!o2 6924 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV) 6925 || (o2->op_private & OPpLVAL_INTRO) 6926 ) 6927 ###### break; 6928 ###### oleft = o2; 6929 ###### o2 = o2->op_next; 6930 ###### if (!o2 || o2->op_type != OP_NULL) 6931 ###### break; 6932 ###### o2 = o2->op_next; 6933 ###### if (!o2 || o2->op_type != OP_AASSIGN 6934 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID) 6935 ###### break; 6936 6937 /* check that the sort is the first arg on RHS of assign */ 6938 6939 ###### o2 = cUNOPx(o2)->op_first; 6940 ###### if (!o2 || o2->op_type != OP_NULL) 6941 ###### break; 6942 ###### o2 = cUNOPx(o2)->op_first; 6943 ###### if (!o2 || o2->op_type != OP_PUSHMARK) 6944 ###### break; 6945 ###### if (o2->op_sibling != o) 6946 ###### break; 6947 6948 /* check the array is the same on both sides */ 6949 ###### if (oleft->op_type == OP_RV2AV) { 6950 ###### 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 ###### break; 6957 } 6958 ###### else if (oright->op_type != OP_PADAV 6959 || oright->op_targ != oleft->op_targ 6960 ) 6961 ###### break; 6962 6963 /* transfer MODishness etc from LHS arg to RHS arg */ 6964 ###### oright->op_flags = oleft->op_flags; 6965 ###### o->op_private |= OPpSORT_INPLACE; 6966 6967 /* excise push->gv->rv2av->null->aassign */ 6968 ###### o2 = o->op_next->op_next; 6969 ###### op_null(o2); /* PUSHMARK */ 6970 ###### o2 = o2->op_next; 6971 ###### if (o2->op_type == OP_GV) { 6972 ###### op_null(o2); /* GV */ 6973 ###### o2 = o2->op_next; 6974 } 6975 ###### op_null(o2); /* RV2AV or PADAV */ 6976 ###### o2 = o2->op_next->op_next; 6977 ###### op_null(o2); /* AASSIGN */ 6978 6979 ###### o->op_next = o2->op_next; 6980 6981 ###### break; 6982 } 6983 6984 case OP_REVERSE: { 6985 410 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av; 6986 410 OP *gvop = NULL; 6987 410 LISTOP *enter, *exlist; 6988 410 o->op_opt = 1; 6989 6990 410 enter = (LISTOP *) o->op_next; 6991 410 if (!enter) 6992 ###### break; 6993 410 if (enter->op_type == OP_NULL) { 6994 408 enter = (LISTOP *) enter->op_next; 6995 408 if (!enter) 6996 ###### break; 6997 } 6998 /* for $a (...) will have OP_GV then OP_RV2GV here. 6999 for (...) just has an OP_GV. */ 7000 410 if (enter->op_type == OP_GV) { 7001 ###### gvop = (OP *) enter; 7002 ###### enter = (LISTOP *) enter->op_next; 7003 ###### if (!enter) 7004 ###### break; 7005 ###### if (enter->op_type == OP_RV2GV) { 7006 ###### enter = (LISTOP *) enter->op_next; 7007 ###### if (!enter) 7008 ###### break; 7009 } 7010 } 7011 7012 410 if (enter->op_type != OP_ENTERITER) 7013 410 break; 7014 7015 ###### iter = enter->op_next; 7016 ###### if (!iter || iter->op_type != OP_ITER) 7017 ###### break; 7018 7019 ###### expushmark = enter->op_first; 7020 ###### if (!expushmark || expushmark->op_type != OP_NULL 7021 || expushmark->op_targ != OP_PUSHMARK) 7022 ###### break; 7023 7024 ###### exlist = (LISTOP *) expushmark->op_sibling; 7025 ###### if (!exlist || exlist->op_type != OP_NULL 7026 || exlist->op_targ != OP_LIST) 7027 ###### break; 7028 7029 ###### if (exlist->op_last != o) { 7030 /* Mmm. Was expecting to point back to this op. */ 7031 ###### break; 7032 } 7033 ###### theirmark = exlist->op_first; 7034 ###### if (!theirmark || theirmark->op_type != OP_PUSHMARK) 7035 ###### break; 7036 7037 ###### 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 ###### break; 7042 } 7043 7044 ###### ourmark = ((LISTOP *)o)->op_first; 7045 ###### if (!ourmark || ourmark->op_type != OP_PUSHMARK) 7046 ###### break; 7047 7048 ###### ourlast = ((LISTOP *)o)->op_last; 7049 ###### if (!ourlast || ourlast->op_next != o) 7050 ###### break; 7051 7052 ###### rv2av = ourmark->op_sibling; 7053 ###### 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 ###### rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF; 7058 ###### enter->op_flags |= OPf_STACKED; 7059 } 7060 7061 /* We don't have control over who points to theirmark, so sacrifice 7062 ours. */ 7063 ###### theirmark->op_next = ourmark->op_next; 7064 ###### theirmark->op_flags = ourmark->op_flags; 7065 ###### ourlast->op_next = gvop ? gvop : (OP *) enter; 7066 ###### op_null(ourmark); 7067 ###### op_null(o); 7068 ###### enter->op_private |= OPpITER_REVERSED; 7069 ###### iter->op_private |= OPpITER_REVERSED; 7070 7071 ###### break; 7072 } 7073 7074 default: 7075 3215974 o->op_opt = 1; 7076 6276603 break; 7077 } 7078 6276603 oldop = o; 7079 } 7080 464967 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 769 { 7127 769 dXSARGS; 7128 769 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 769 EXTEND(sp, 1); 7135 769 ST(0) = (SV*)XSANY.any_ptr; 7136 769 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 */