1 /* op.c 2 * 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 4 * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others 5 * 6 * You may distribute under the terms of either the GNU General Public 7 * License or the Artistic License, as specified in the README file. 8 * 9 */ 10 11 /* 12 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was 13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the 14 * youngest of the Old Took's daughters); and Mr. Drogo was his second 15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed 16 * either way, as the saying is, if you follow me." --the Gaffer 17 */ 18 19 /* This file contains the functions that create, manipulate and optimize 20 * the OP structures that hold a compiled perl program. 21 * 22 * A Perl program is compiled into a tree of OPs. Each op contains 23 * structural pointers (eg to its siblings and the next op in the 24 * execution sequence), a pointer to the function that would execute the 25 * op, plus any data specific to that op. For example, an OP_CONST op 26 * points to the pp_const() function and to an SV containing the constant 27 * value. When pp_const() is executed, its job is to push that SV onto the 28 * stack. 29 * 30 * OPs are mainly created by the newFOO() functions, which are mainly 31 * called from the parser (in perly.y) as the code is parsed. For example 32 * the Perl code $a + $b * $c would cause the equivalent of the following 33 * to be called (oversimplifying a bit): 34 * 35 * newBINOP(OP_ADD, flags, 36 * newSVREF($a), 37 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c)) 38 * ) 39 * 40 * Note that during the build of miniperl, a temporary copy of this file 41 * is made, called opmini.c. 42 */ 43 44 /* 45 Perl's compiler is essentially a 3-pass compiler with interleaved phases: 46 47 A bottom-up pass 48 A top-down pass 49 An execution-order pass 50 51 The bottom-up pass is represented by all the "newOP" routines and 52 the ck_ routines. The bottom-upness is actually driven by yacc. 53 So at the point that a ck_ routine fires, we have no idea what the 54 context is, either upward in the syntax tree, or either forward or 55 backward in the execution order. (The bottom-up parser builds that 56 part of the execution order it knows about, but if you follow the "next" 57 links around, you'll find it's actually a closed loop through the 58 top level node. 59 60 Whenever the bottom-up parser gets to a node that supplies context to 61 its components, it invokes that portion of the top-down pass that applies 62 to that part of the subtree (and marks the top node as processed, so 63 if a node further up supplies context, it doesn't have to take the 64 plunge again). As a particular subcase of this, as the new node is 65 built, it takes all the closed execution loops of its subcomponents 66 and links them into a new closed loop for the higher level node. But 67 it's still not the real execution order. 68 69 The actual execution order is not known till we get a grammar reduction 70 to a top-level unit like a subroutine or file that will be called by 71 "name" rather than via a "next" pointer. At that point, we can call 72 into peep() to do that code's portion of the 3rd pass. It has to be 73 recursive, but it's recursive on basic blocks, not on tree nodes. 74 */ 75 76 #include "EXTERN.h" 77 #define PERL_IN_OP_C 78 #include "perl.h" 79 #include "keywords.h" 80 81 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o) 82 83 #if defined(PL_OP_SLAB_ALLOC) 84 85 #ifndef PERL_SLAB_SIZE 86 #define PERL_SLAB_SIZE 2048 87 #endif 88 89 void * 90 Perl_Slab_Alloc(pTHX_ int m, size_t sz) 91 { 92 /* 93 * To make incrementing use count easy PL_OpSlab is an I32 * 94 * To make inserting the link to slab PL_OpPtr is I32 ** 95 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments 96 * Add an overhead for pointer to slab and round up as a number of pointers 97 */ 98 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *); 99 if ((PL_OpSpace -= sz) < 0) { 100 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*)); 101 if (!PL_OpPtr) { 102 return NULL; 103 } 104 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **); 105 /* We reserve the 0'th I32 sized chunk as a use count */ 106 PL_OpSlab = (I32 *) PL_OpPtr; 107 /* Reduce size by the use count word, and by the size we need. 108 * Latter is to mimic the '-=' in the if() above 109 */ 110 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz; 111 /* Allocation pointer starts at the top. 112 Theory: because we build leaves before trunk allocating at end 113 means that at run time access is cache friendly upward 114 */ 115 PL_OpPtr += PERL_SLAB_SIZE; 116 } 117 assert( PL_OpSpace >= 0 ); 118 /* Move the allocation pointer down */ 119 PL_OpPtr -= sz; 120 assert( PL_OpPtr > (I32 **) PL_OpSlab ); 121 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */ 122 (*PL_OpSlab)++; /* Increment use count of slab */ 123 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) ); 124 assert( *PL_OpSlab > 0 ); 125 return (void *)(PL_OpPtr + 1); 126 } 127 128 void 129 Perl_Slab_Free(pTHX_ void *op) 130 { 131 I32 **ptr = (I32 **) op; 132 I32 *slab = ptr[-1]; 133 assert( ptr-1 > (I32 **) slab ); 134 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) ); 135 assert( *slab > 0 ); 136 if (--(*slab) == 0) { 137 # ifdef NETWARE 138 # define PerlMemShared PerlMem 139 # endif 140 141 PerlMemShared_free(slab); 142 if (slab == PL_OpSlab) { 143 PL_OpSpace = 0; 144 } 145 } 146 } 147 #endif 148 /* 149 * In the following definition, the ", Nullop" is just to make the compiler 150 * think the expression is of the right type: croak actually does a Siglongjmp. 151 */ 152 #define CHECKOP(type,o) \ 153 ((PL_op_mask && PL_op_mask[type]) \ 154 ? ( op_free((OP*)o), \ 155 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \ 156 Nullop ) \ 157 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o)) 158 159 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2) 160 161 STATIC const char* 162 S_gv_ename(pTHX_ GV *gv) 163 24 { 164 24 SV* tmpsv = sv_newmortal(); 165 24 gv_efullname3(tmpsv, gv, Nullch); 166 24 return SvPV_nolen_const(tmpsv); 167 } 168 169 STATIC OP * 170 S_no_fh_allowed(pTHX_ OP *o) 171 ###### { 172 ###### yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function", 173 OP_DESC(o))); 174 ###### return o; 175 } 176 177 STATIC OP * 178 S_too_few_arguments(pTHX_ OP *o, const char *name) 179 16 { 180 16 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name)); 181 16 return o; 182 } 183 184 STATIC OP * 185 S_too_many_arguments(pTHX_ OP *o, const char *name) 186 6 { 187 6 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name)); 188 6 return o; 189 } 190 191 STATIC void 192 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid) 193 7 { 194 7 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)", 195 (int)n, name, t, OP_DESC(kid))); 196 } 197 198 STATIC void 199 S_no_bareword_allowed(pTHX_ const OP *o) 200 61 { 201 61 qerror(Perl_mess(aTHX_ 202 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use", 203 cSVOPo_sv)); 204 } 205 206 /* "register" allocation */ 207 208 PADOFFSET 209 Perl_allocmy(pTHX_ char *name) 210 635090 { 211 635090 PADOFFSET off; 212 213 /* complain about "my $" etc etc */ 214 635090 if (!(PL_in_my == KEY_our || 215 isALPHA(name[1]) || 216 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) || 217 (name[1] == '_' && (*name == '$' || (int)strlen(name) > 2)))) 218 { 219 2 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) { 220 /* 1999-02-27 mjd@plover.com */ 221 2 char *p; 222 2 p = strchr(name, '\0'); 223 /* The next block assumes the buffer is at least 205 chars 224 long. At present, it's always at least 256 chars. */ 225 2 if (p-name > 200) { 226 ###### strcpy(name+200, "..."); 227 ###### p = name+199; 228 } 229 else { 230 2 p[1] = '\0'; 231 } 232 /* Move everything else down one character */ 233 6 for (; p-name > 2; p--) 234 2 *p = *(p-1); 235 2 name[2] = toCTRL(name[1]); 236 2 name[1] = '^'; 237 } 238 2 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name)); 239 } 240 241 /* check for duplicate declaration */ 242 635090 pad_check_dup(name, 243 (bool)(PL_in_my == KEY_our), 244 (PL_curstash ? PL_curstash : PL_defstash) 245 ); 246 247 635090 if (PL_in_my_stash && *name != '$') { 248 1 yyerror(Perl_form(aTHX_ 249 "Can't declare class for non-scalar %s in \"%s\"", 250 name, PL_in_my == KEY_our ? "our" : "my")); 251 } 252 253 /* allocate a spare slot and store the name in that slot */ 254 255 635090 off = pad_add_name(name, 256 PL_in_my_stash, 257 (PL_in_my == KEY_our 258 /* $_ is always in main::, even with our */ 259 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash) 260 : Nullhv 261 ), 262 0 /* not fake */ 263 ); 264 635090 return off; 265 } 266 267 /* Destructor */ 268 269 void 270 Perl_op_free(pTHX_ OP *o) 271 25397547 { 272 dVAR; 273 25397547 OPCODE type; 274 25397547 PADOFFSET refcnt; 275 276 25397547 if (!o || o->op_static) 277 25355803 return; 278 279 25355803 if (o->op_private & OPpREFCOUNTED) { 280 1728901 switch (o->op_type) { 281 case OP_LEAVESUB: 282 case OP_LEAVESUBLV: 283 case OP_LEAVEEVAL: 284 case OP_LEAVE: 285 case OP_SCOPE: 286 case OP_LEAVEWRITE: 287 366706 OP_REFCNT_LOCK; 288 366706 refcnt = OpREFCNT_dec(o); 289 366706 OP_REFCNT_UNLOCK; 290 366706 if (refcnt) 291 12516 return; 292 25343287 break; 293 default: 294 25343287 break; 295 } 296 } 297 298 25343287 if (o->op_flags & OPf_KIDS) { 299 11234144 register OP *kid, *nextkid; 300 34846211 for (kid = cUNOPo->op_first; kid; kid = nextkid) { 301 23612067 nextkid = kid->op_sibling; /* Get before next freeing kid */ 302 23612067 op_free(kid); 303 } 304 } 305 25343287 type = o->op_type; 306 25343287 if (type == OP_NULL) 307 3935573 type = (OPCODE)o->op_targ; 308 309 /* COP* is not cleared by op_clear() so that we may track line 310 * numbers etc even after null() */ 311 25343287 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE) 312 2388025 cop_free((COP*)o); 313 314 25343287 op_clear(o); 315 25343287 FreeOp(o); 316 #ifdef DEBUG_LEAKING_SCALARS 317 if (PL_op == o) 318 PL_op = Nullop; 319 #endif 320 } 321 322 void 323 Perl_op_clear(pTHX_ OP *o) 324 28359880 { 325 326 dVAR; 327 28359880 switch (o->op_type) { 328 case OP_NULL: /* Was holding old type, if any. */ 329 case OP_ENTEREVAL: /* Was holding hints. */ 330 3951762 o->op_targ = 0; 331 3951762 break; 332 default: 333 18371238 if (!(o->op_flags & OPf_REF) 334 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst))) 335 1456277 break; 336 /* FALL THROUGH */ 337 case OP_GVSV: 338 case OP_GV: 339 case OP_AELEMFAST: 340 1456277 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) { 341 /* not an OP_PADAV replacement */ 342 #ifdef USE_ITHREADS 343 if (cPADOPo->op_padix > 0) { 344 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references 345 * may still exist on the pad */ 346 pad_swipe(cPADOPo->op_padix, TRUE); 347 cPADOPo->op_padix = 0; 348 } 349 #else 350 1440787 SvREFCNT_dec(cSVOPo->op_sv); 351 1440787 cSVOPo->op_sv = Nullsv; 352 #endif 353 } 354 1440787 break; 355 case OP_METHOD_NAMED: 356 case OP_CONST: 357 4357772 SvREFCNT_dec(cSVOPo->op_sv); 358 4357772 cSVOPo->op_sv = Nullsv; 359 #ifdef USE_ITHREADS 360 /** Bug #15654 361 Even if op_clear does a pad_free for the target of the op, 362 pad_free doesn't actually remove the sv that exists in the pad; 363 instead it lives on. This results in that it could be reused as 364 a target later on when the pad was reallocated. 365 **/ 366 if(o->op_targ) { 367 pad_swipe(o->op_targ,1); 368 o->op_targ = 0; 369 } 370 #endif 371 4357772 break; 372 case OP_GOTO: 373 case OP_NEXT: 374 case OP_LAST: 375 case OP_REDO: 376 60131 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS)) 377 51862 break; 378 /* FALL THROUGH */ 379 case OP_TRANS: 380 13413 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) { 381 47 SvREFCNT_dec(cSVOPo->op_sv); 382 47 cSVOPo->op_sv = Nullsv; 383 } 384 else { 385 13366 Safefree(cPVOPo->op_pv); 386 13366 cPVOPo->op_pv = Nullch; 387 } 388 13366 break; 389 case OP_SUBST: 390 53389 op_free(cPMOPo->op_pmreplroot); 391 53389 goto clear_pmop; 392 case OP_PUSHRE: 393 #ifdef USE_ITHREADS 394 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) { 395 /* No GvIN_PAD_off here, because other references may still 396 * exist on the pad */ 397 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE); 398 } 399 #else 400 8472 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot); 401 #endif 402 /* FALL THROUGH */ 403 case OP_MATCH: 404 case OP_QR: 405 clear_pmop: 406 { 407 160789 HV *pmstash = PmopSTASH(cPMOPo); 408 160789 if (pmstash && SvREFCNT(pmstash)) { 409 149836 MAGIC *mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab); 410 149836 if (mg) { 411 149836 PMOP *pmop = (PMOP*) mg->mg_obj; 412 149836 PMOP *lastpmop = NULL; 413 1444779 while (pmop) { 414 1444779 if (cPMOPo == pmop) { 415 149836 if (lastpmop) 416 111331 lastpmop->op_pmnext = pmop->op_pmnext; 417 else 418 38505 mg->mg_obj = (SV*) pmop->op_pmnext; 419 38505 break; 420 } 421 1294943 lastpmop = pmop; 422 1294943 pmop = pmop->op_pmnext; 423 } 424 } 425 } 426 PmopSTASH_free(cPMOPo); 427 } 428 160789 cPMOPo->op_pmreplroot = Nullop; 429 /* we use the "SAFE" version of the PM_ macros here 430 * since sv_clean_all might release some PMOPs 431 * after PL_regex_padav has been cleared 432 * and the clearing of PL_regex_padav needs to 433 * happen before sv_clean_all 434 */ 435 160789 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo)); 436 160789 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL); 437 #ifdef USE_ITHREADS 438 if(PL_regex_pad) { /* We could be in destruction */ 439 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]); 440 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]); 441 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset); 442 } 443 #endif 444 445 28359880 break; 446 } 447 448 28359880 if (o->op_targ > 0) { 449 5851428 pad_free(o->op_targ); 450 5851428 o->op_targ = 0; 451 } 452 } 453 454 STATIC void 455 S_cop_free(pTHX_ COP* cop) 456 2388025 { 457 2388025 Safefree(cop->cop_label); /* FIXME: treaddead ??? */ 458 2388025 CopFILE_free(cop); 459 CopSTASH_free(cop); 460 2388025 if (! specialWARN(cop->cop_warnings)) 461 34807 SvREFCNT_dec(cop->cop_warnings); 462 2388025 if (! specialCopIO(cop->cop_io)) { 463 #ifdef USE_ITHREADS 464 #if 0 465 STRLEN len; 466 char *s = SvPV(cop->cop_io,len); 467 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */ 468 #endif 469 #else 470 26 SvREFCNT_dec(cop->cop_io); 471 #endif 472 } 473 } 474 475 void 476 Perl_op_null(pTHX_ OP *o) 477 3016634 { 478 dVAR; 479 3016634 if (o->op_type == OP_NULL) 480 41 return; 481 3016593 op_clear(o); 482 3016593 o->op_targ = o->op_type; 483 3016593 o->op_type = OP_NULL; 484 3016593 o->op_ppaddr = PL_ppaddr[OP_NULL]; 485 } 486 487 void 488 Perl_op_refcnt_lock(pTHX) 489 ###### { 490 dVAR; 491 ###### OP_REFCNT_LOCK; 492 } 493 494 void 495 Perl_op_refcnt_unlock(pTHX) 496 ###### { 497 dVAR; 498 ###### OP_REFCNT_UNLOCK; 499 } 500 501 /* Contextualizers */ 502 503 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o)) 504 505 OP * 506 Perl_linklist(pTHX_ OP *o) 507 9806890 { 508 509 9806890 if (o->op_next) 510 17335 return o->op_next; 511 512 /* establish postfix order */ 513 9789555 if (cUNOPo->op_first) { 514 9758927 register OP *kid; 515 9758927 o->op_next = LINKLIST(cUNOPo->op_first); 516 30837684 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { 517 21078757 if (kid->op_sibling) 518 11319830 kid->op_next = LINKLIST(kid->op_sibling); 519 else 520 9758927 kid->op_next = o; 521 } 522 } 523 else 524 30628 o->op_next = o; 525 526 9789555 return o->op_next; 527 } 528 529 OP * 530 Perl_scalarkids(pTHX_ OP *o) 531 3934 { 532 3934 if (o && o->op_flags & OPf_KIDS) { 533 3934 OP *kid; 534 7868 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 535 3934 scalar(kid); 536 } 537 3934 return o; 538 } 539 540 STATIC OP * 541 S_scalarboolean(pTHX_ OP *o) 542 838502 { 543 838502 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) { 544 4 if (ckWARN(WARN_SYNTAX)) { 545 1 const line_t oldline = CopLINE(PL_curcop); 546 547 1 if (PL_copline != NOLINE) 548 1 CopLINE_set(PL_curcop, PL_copline); 549 1 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be =="); 550 1 CopLINE_set(PL_curcop, oldline); 551 } 552 } 553 838502 return scalar(o); 554 } 555 556 OP * 557 Perl_scalar(pTHX_ OP *o) 558 35092526 { 559 dVAR; 560 35092526 OP *kid; 561 562 /* assumes no premature commitment */ 563 35092526 if (!o || (o->op_flags & OPf_WANT) || PL_error_count 564 || o->op_type == OP_RETURN) 565 { 566 18361743 return o; 567 } 568 569 16730783 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR; 570 571 16730783 switch (o->op_type) { 572 case OP_REPEAT: 573 3344 scalar(cBINOPo->op_first); 574 3344 break; 575 case OP_OR: 576 case OP_AND: 577 case OP_COND_EXPR: 578 434216 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) 579 239298 scalar(kid); 580 7 break; 581 case OP_SPLIT: 582 7 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) { 583 7 if (!kPMOP->op_pmreplroot) 584 6 deprecate_old("implicit split to @_"); 585 } 586 /* FALL THROUGH */ 587 case OP_MATCH: 588 case OP_QR: 589 case OP_SUBST: 590 case OP_NULL: 591 default: 592 16296827 if (o->op_flags & OPf_KIDS) { 593 15758785 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) 594 9816246 scalar(kid); 595 } 596 11485 break; 597 case OP_LEAVE: 598 case OP_LEAVETRY: 599 11485 kid = cLISTOPo->op_first; 600 11485 scalar(kid); 601 43007 while ((kid = kid->op_sibling)) { 602 31522 if (kid->op_sibling) 603 20037 scalarvoid(kid); 604 else 605 11485 scalar(kid); 606 } 607 11485 WITH_THR(PL_curcop = &PL_compiling); 608 11485 break; 609 case OP_SCOPE: 610 case OP_LINESEQ: 611 case OP_LIST: 612 1246987 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { 613 1022782 if (kid->op_sibling) 614 798577 scalarvoid(kid); 615 else 616 224205 scalar(kid); 617 } 618 224205 WITH_THR(PL_curcop = &PL_compiling); 619 224205 break; 620 case OP_SORT: 621 4 if (ckWARN(WARN_VOID)) 622 1 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context"); 623 } 624 16730783 return o; 625 } 626 627 OP * 628 Perl_scalarvoid(pTHX_ OP *o) 629 9869337 { 630 dVAR; 631 9869337 OP *kid; 632 9869337 const char* useless = 0; 633 9869337 SV* sv; 634 9869337 U8 want; 635 636 9869337 if (o->op_type == OP_NEXTSTATE 637 || o->op_type == OP_SETSTATE 638 || o->op_type == OP_DBSTATE 639 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE 640 || o->op_targ == OP_SETSTATE 641 || o->op_targ == OP_DBSTATE))) 642 4637165 PL_curcop = (COP*)o; /* for warning below */ 643 644 /* assumes no premature commitment */ 645 9869337 want = o->op_flags & OPf_WANT; 646 9869337 if ((want && want != OPf_WANT_SCALAR) || PL_error_count 647 || o->op_type == OP_RETURN) 648 { 649 3876459 return o; 650 } 651 652 5992878 if ((o->op_private & OPpTARGET_MY) 653 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */ 654 { 655 32885 return scalar(o); /* As if inside SASSIGN */ 656 } 657 658 5959993 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID; 659 660 5959993 switch (o->op_type) { 661 default: 662 1406876 if (!(PL_opargs[o->op_type] & OA_FOLDCONST)) 663 1342523 break; 664 /* FALL THROUGH */ 665 case OP_REPEAT: 666 64362 if (o->op_flags & OPf_STACKED) 667 64273 break; 668 121 goto func_ops; 669 case OP_SUBSTR: 670 121 if (o->op_private == 4) 671 118 break; 672 /* FALL THROUGH */ 673 case OP_GVSV: 674 case OP_WANTARRAY: 675 case OP_GV: 676 case OP_PADSV: 677 case OP_PADAV: 678 case OP_PADHV: 679 case OP_PADANY: 680 case OP_AV2ARYLEN: 681 case OP_REF: 682 case OP_REFGEN: 683 case OP_SREFGEN: 684 case OP_DEFINED: 685 case OP_HEX: 686 case OP_OCT: 687 case OP_LENGTH: 688 case OP_VEC: 689 case OP_INDEX: 690 case OP_RINDEX: 691 case OP_SPRINTF: 692 case OP_AELEM: 693 case OP_AELEMFAST: 694 case OP_ASLICE: 695 case OP_HELEM: 696 case OP_HSLICE: 697 case OP_UNPACK: 698 case OP_PACK: 699 case OP_JOIN: 700 case OP_LSLICE: 701 case OP_ANONLIST: 702 case OP_ANONHASH: 703 case OP_SORT: 704 case OP_REVERSE: 705 case OP_RANGE: 706 case OP_FLIP: 707 case OP_FLOP: 708 case OP_CALLER: 709 case OP_FILENO: 710 case OP_EOF: 711 case OP_TELL: 712 case OP_GETSOCKNAME: 713 case OP_GETPEERNAME: 714 case OP_READLINK: 715 case OP_TELLDIR: 716 case OP_GETPPID: 717 case OP_GETPGRP: 718 case OP_GETPRIORITY: 719 case OP_TIME: 720 case OP_TMS: 721 case OP_LOCALTIME: 722 case OP_GMTIME: 723 case OP_GHBYNAME: 724 case OP_GHBYADDR: 725 case OP_GHOSTENT: 726 case OP_GNBYNAME: 727 case OP_GNBYADDR: 728 case OP_GNETENT: 729 case OP_GPBYNAME: 730 case OP_GPBYNUMBER: 731 case OP_GPROTOENT: 732 case OP_GSBYNAME: 733 case OP_GSBYPORT: 734 case OP_GSERVENT: 735 case OP_GPWNAM: 736 case OP_GPWUID: 737 case OP_GGRNAM: 738 case OP_GGRGID: 739 case OP_GETLOGIN: 740 case OP_PROTOTYPE: 741 func_ops: 742 98206 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO))) 743 286 useless = OP_DESC(o); 744 286 break; 745 746 case OP_NOT: 747 1 kid = cUNOPo->op_first; 748 1 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST && 749 kid->op_type != OP_TRANS) { 750 1 goto func_ops; 751 } 752 ###### useless = "negative pattern binding (!~)"; 753 ###### break; 754 755 case OP_RV2GV: 756 case OP_RV2SV: 757 case OP_RV2AV: 758 case OP_RV2HV: 759 33354 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) && 760 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE)) 761 23 useless = "a variable"; 762 23 break; 763 764 case OP_CONST: 765 3579 sv = cSVOPo_sv; 766 3579 if (cSVOPo->op_private & OPpCONST_STRICT) 767 3 no_bareword_allowed(o); 768 else { 769 3576 if (ckWARN(WARN_VOID)) { 770 2076 useless = "a constant"; 771 /* don't warn on optimised away booleans, eg 772 * use constant Foo, 5; Foo || print; */ 773 2076 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT) 774 1798 useless = 0; 775 /* the constants 0 and 1 are permitted as they are 776 conventionally used as dummies in constructs like 777 1 while some_condition_with_side_effects; */ 778 278 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0)) 779 276 useless = 0; 780 2 else if (SvPOK(sv)) { 781 /* perl4's way of mixing documentation and code 782 (before the invention of POD) was based on a 783 trick to mix nroff and perl code. The trick was 784 built upon these three nroff macros being used in 785 void context. The pink camel has the details in 786 the script wrapman near page 319. */ 787 1 if (strnEQ(SvPVX_const(sv), "di", 2) || 788 strnEQ(SvPVX_const(sv), "ds", 2) || 789 strnEQ(SvPVX_const(sv), "ig", 2)) 790 ###### useless = 0; 791 } 792 } 793 } 794 3579 op_null(o); /* don't execute or even remember it */ 795 3579 break; 796 797 case OP_POSTINC: 798 13447 o->op_type = OP_PREINC; /* pre-increment is faster */ 799 13447 o->op_ppaddr = PL_ppaddr[OP_PREINC]; 800 13447 break; 801 802 case OP_POSTDEC: 803 1222 o->op_type = OP_PREDEC; /* pre-decrement is faster */ 804 1222 o->op_ppaddr = PL_ppaddr[OP_PREDEC]; 805 1222 break; 806 807 case OP_OR: 808 case OP_AND: 809 case OP_DOR: 810 case OP_COND_EXPR: 811 1235379 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) 812 673645 scalarvoid(kid); 813 580709 break; 814 815 case OP_NULL: 816 580709 if (o->op_flags & OPf_STACKED) 817 3461 break; 818 /* FALL THROUGH */ 819 case OP_NEXTSTATE: 820 case OP_DBSTATE: 821 case OP_ENTERTRY: 822 case OP_ENTER: 823 3162015 if (!(o->op_flags & OPf_KIDS)) 824 2585077 break; 825 /* FALL THROUGH */ 826 case OP_SCOPE: 827 case OP_LEAVE: 828 case OP_LEAVETRY: 829 case OP_LEAVELOOP: 830 case OP_LINESEQ: 831 case OP_LIST: 832 3929768 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 833 2839883 scalarvoid(kid); 834 3934 break; 835 case OP_ENTEREVAL: 836 3934 scalarkids(o); 837 3934 break; 838 case OP_REQUIRE: 839 /* all requires must return a boolean value */ 840 159090 o->op_flags &= ~OPf_WANT; 841 /* FALL THROUGH */ 842 case OP_SCALAR: 843 159095 return scalar(o); 844 case OP_SPLIT: 845 81 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) { 846 81 if (!kPMOP->op_pmreplroot) 847 9 deprecate_old("implicit split to @_"); 848 } 849 5800894 break; 850 } 851 5800894 if (useless && ckWARN(WARN_VOID)) 852 80 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless); 853 5800891 return o; 854 } 855 856 OP * 857 Perl_listkids(pTHX_ OP *o) 858 2808023 { 859 2808023 if (o && o->op_flags & OPf_KIDS) { 860 2808023 OP *kid; 861 9062762 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 862 6254739 list(kid); 863 } 864 2808023 return o; 865 } 866 867 OP * 868 Perl_list(pTHX_ OP *o) 869 7761601 { 870 dVAR; 871 7761601 OP *kid; 872 873 /* assumes no premature commitment */ 874 7761601 if (!o || (o->op_flags & OPf_WANT) || PL_error_count 875 || o->op_type == OP_RETURN) 876 { 877 5736022 return o; 878 } 879 880 2025579 if ((o->op_private & OPpTARGET_MY) 881 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */ 882 { 883 ###### return o; /* As if inside SASSIGN */ 884 } 885 886 2025579 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST; 887 888 2025579 switch (o->op_type) { 889 case OP_FLOP: 890 case OP_REPEAT: 891 5549 list(cBINOPo->op_first); 892 5549 break; 893 case OP_OR: 894 case OP_AND: 895 case OP_COND_EXPR: 896 52114 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) 897 33927 list(kid); 898 1967855 break; 899 default: 900 case OP_MATCH: 901 case OP_QR: 902 case OP_SUBST: 903 case OP_NULL: 904 1967855 if (!(o->op_flags & OPf_KIDS)) 905 675202 break; 906 1292653 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) { 907 1028 list(cBINOPo->op_first); 908 1028 return gen_constant_list(o); 909 } 910 case OP_LIST: 911 1315409 listkids(o); 912 1315409 break; 913 case OP_LEAVE: 914 case OP_LEAVETRY: 915 4373 kid = cLISTOPo->op_first; 916 4373 list(kid); 917 15946 while ((kid = kid->op_sibling)) { 918 11573 if (kid->op_sibling) 919 7200 scalarvoid(kid); 920 else 921 4373 list(kid); 922 } 923 4373 WITH_THR(PL_curcop = &PL_compiling); 924 4373 break; 925 case OP_SCOPE: 926 case OP_LINESEQ: 927 17495 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { 928 11665 if (kid->op_sibling) 929 5835 scalarvoid(kid); 930 else 931 5830 list(kid); 932 } 933 5830 WITH_THR(PL_curcop = &PL_compiling); 934 5830 break; 935 case OP_REQUIRE: 936 /* all requires must return a boolean value */ 937 1 o->op_flags &= ~OPf_WANT; 938 1 return scalar(o); 939 } 940 2024550 return o; 941 } 942 943 OP * 944 Perl_scalarseq(pTHX_ OP *o) 945 1339510 { 946 1339510 if (o) { 947 1332461 if (o->op_type == OP_LINESEQ || 948 o->op_type == OP_SCOPE || 949 o->op_type == OP_LEAVE || 950 o->op_type == OP_LEAVETRY) 951 { 952 1124644 OP *kid; 953 7757236 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { 954 6632595 if (kid->op_sibling) { 955 5507954 scalarvoid(kid); 956 } 957 } 958 1124641 PL_curcop = &PL_compiling; 959 } 960 1332458 o->op_flags &= ~OPf_PARENS; 961 1332458 if (PL_hints & HINT_BLOCK_SCOPE) 962 1003351 o->op_flags |= OPf_PARENS; 963 } 964 else 965 7049 o = newOP(OP_STUB, 0); 966 1339507 return o; 967 } 968 969 STATIC OP * 970 S_modkids(pTHX_ OP *o, I32 type) 971 306638 { 972 306638 if (o && o->op_flags & OPf_KIDS) { 973 279746 OP *kid; 974 559492 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 975 279746 mod(kid, type); 976 } 977 306638 return o; 978 } 979 980 /* Propagate lvalue ("modifiable") context to an op and it's children. 981 * 'type' represents the context type, roughly based on the type of op that 982 * would do the modifying, although local() is represented by OP_NULL. 983 * It's responsible for detecting things that can't be modified, flag 984 * things that need to behave specially in an lvalue context (e.g., "$$x = 5" 985 * might have to vivify a reference in $x), and so on. 986 * 987 * For example, "$a+1 = 2" would cause mod() to be called with o being 988 * OP_ADD and type being OP_SASSIGN, and would output an error. 989 */ 990 991 OP * 992 Perl_mod(pTHX_ OP *o, I32 type) 993 3468262 { 994 dVAR; 995 3468262 OP *kid; 996 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */ 997 3468262 int localize = -1; 998 999 3468262 if (!o || PL_error_count) 1000 1385 return o; 1001 1002 3466877 if ((o->op_private & OPpTARGET_MY) 1003 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */ 1004 { 1005 70 return o; 1006 } 1007 1008 3466807 switch (o->op_type) { 1009 case OP_UNDEF: 1010 3908 localize = 0; 1011 3908 PL_modcount++; 1012 3908 return o; 1013 case OP_CONST: 1014 360069 if (!(o->op_private & (OPpCONST_ARYBASE))) 1015 360050 goto nomod; 1016 19 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) { 1017 14 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv); 1018 14 PL_eval_start = 0; 1019 } 1020 5 else if (!type) { 1021 2 SAVEI32(PL_compiling.cop_arybase); 1022 2 PL_compiling.cop_arybase = 0; 1023 } 1024 3 else if (type == OP_REFGEN) 1025 ###### goto nomod; 1026 else 1027 3 Perl_croak(aTHX_ "That use of $[ is unsupported"); 1028 2062 break; 1029 case OP_STUB: 1030 2062 if (o->op_flags & OPf_PARENS) 1031 2062 break; 1032 77895 goto nomod; 1033 case OP_ENTERSUB: 1034 77895 if ((type == OP_UNDEF || type == OP_REFGEN) && 1035 !(o->op_flags & OPf_STACKED)) { 1036 46193 o->op_type = OP_RV2CV; /* entersub => rv2cv */ 1037 46193 o->op_ppaddr = PL_ppaddr[OP_RV2CV]; 1038 46193 assert(cUNOPo->op_first->op_type == OP_NULL); 1039 46193 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */ 1040 46193 break; 1041 } 1042 31702 else if (o->op_private & OPpENTERSUB_NOMOD) 1043 1 return o; 1044 else { /* lvalue subroutine call */ 1045 31701 o->op_private |= OPpLVAL_INTRO; 1046 31701 PL_modcount = RETURN_UNLIMITED_NUMBER; 1047 31701 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) { 1048 /* Backward compatibility mode: */ 1049 31632 o->op_private |= OPpENTERSUB_INARGS; 1050 31632 break; 1051 } 1052 else { /* Compile-time error message: */ 1053 69 OP *kid = cUNOPo->op_first; 1054 69 CV *cv; 1055 69 OP *okid; 1056 1057 69 if (kid->op_type == OP_PUSHMARK) 1058 4 goto skip_kids; 1059 65 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST) 1060 ###### Perl_croak(aTHX_ 1061 "panic: unexpected lvalue entersub " 1062 "args: type/targ %ld:%"UVuf, 1063 (long)kid->op_type, (UV)kid->op_targ); 1064 65 kid = kLISTOP->op_first; 1065 skip_kids: 1066 161 while (kid->op_sibling) 1067 92 kid = kid->op_sibling; 1068 69 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) { 1069 /* Indirect call */ 1070 4 if (kid->op_type == OP_METHOD_NAMED 1071 || kid->op_type == OP_METHOD) 1072 { 1073 4 UNOP *newop; 1074 1075 4 NewOp(1101, newop, 1, UNOP); 1076 4 newop->op_type = OP_RV2CV; 1077 4 newop->op_ppaddr = PL_ppaddr[OP_RV2CV]; 1078 4 newop->op_first = Nullop; 1079 4 newop->op_next = (OP*)newop; 1080 4 kid->op_sibling = (OP*)newop; 1081 4 newop->op_private |= OPpLVAL_INTRO; 1082 4 break; 1083 } 1084 1085 ###### if (kid->op_type != OP_RV2CV) 1086 ###### Perl_croak(aTHX_ 1087 "panic: unexpected lvalue entersub " 1088 "entry via type/targ %ld:%"UVuf, 1089 (long)kid->op_type, (UV)kid->op_targ); 1090 ###### kid->op_private |= OPpLVAL_INTRO; 1091 ###### break; /* Postpone until runtime */ 1092 } 1093 1094 65 okid = kid; 1095 65 kid = kUNOP->op_first; 1096 65 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV) 1097 ###### kid = kUNOP->op_first; 1098 65 if (kid->op_type == OP_NULL) 1099 ###### Perl_croak(aTHX_ 1100 "Unexpected constant lvalue entersub " 1101 "entry via type/targ %ld:%"UVuf, 1102 (long)kid->op_type, (UV)kid->op_targ); 1103 65 if (kid->op_type != OP_GV) { 1104 /* Restore RV2CV to check lvalueness */ 1105 restore_2cv: 1106 4 if (kid->op_next && kid->op_next != kid) { /* Happens? */ 1107 ###### okid->op_next = kid->op_next; 1108 ###### kid->op_next = okid; 1109 } 1110 else 1111 4 okid->op_next = Nullop; 1112 4 okid->op_type = OP_RV2CV; 1113 4 okid->op_targ = 0; 1114 4 okid->op_ppaddr = PL_ppaddr[OP_RV2CV]; 1115 4 okid->op_private |= OPpLVAL_INTRO; 1116 4 break; 1117 } 1118 1119 62 cv = GvCV(kGVOP_gv); 1120 62 if (!cv) 1121 1 goto restore_2cv; 1122 61 if (CvLVALUE(cv)) 1123 57 break; 1124 } 1125 } 1126 /* FALL THROUGH */ 1127 default: 1128 nomod: 1129 /* grep, foreach, subcalls, refgen */ 1130 630442 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) 1131 28 break; 1132 28 yyerror(Perl_form(aTHX_ "Can't modify %s in %s", 1133 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL) 1134 ? "do block" 1135 : (o->op_type == OP_ENTERSUB 1136 ? "non-lvalue subroutine call" 1137 : OP_DESC(o))), 1138 type ? PL_op_desc[type] : "local")); 1139 28 return o; 1140 1141 case OP_PREINC: 1142 case OP_PREDEC: 1143 case OP_POW: 1144 case OP_MULTIPLY: 1145 case OP_DIVIDE: 1146 case OP_MODULO: 1147 case OP_REPEAT: 1148 case OP_ADD: 1149 case OP_SUBTRACT: 1150 case OP_CONCAT: 1151 case OP_LEFT_SHIFT: 1152 case OP_RIGHT_SHIFT: 1153 case OP_BIT_AND: 1154 case OP_BIT_XOR: 1155 case OP_BIT_OR: 1156 case OP_I_MULTIPLY: 1157 case OP_I_DIVIDE: 1158 case OP_I_MODULO: 1159 case OP_I_ADD: 1160 case OP_I_SUBTRACT: 1161 9252 if (!(o->op_flags & OPf_STACKED)) 1162 7521 goto nomod; 1163 1731 PL_modcount++; 1164 1731 break; 1165 1166 case OP_COND_EXPR: 1167 4967 localize = 1; 1168 14901 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) 1169 9934 mod(kid, type); 1170 334273 break; 1171 1172 case OP_RV2AV: 1173 case OP_RV2HV: 1174 334273 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) { 1175 34 PL_modcount = RETURN_UNLIMITED_NUMBER; 1176 34 return o; /* Treat \(@foo) like ordinary list. */ 1177 } 1178 /* FALL THROUGH */ 1179 case OP_RV2GV: 1180 375818 if (scalar_mod_type(o, type)) 1181 1 goto nomod; 1182 375817 ref(cUNOPo->op_first, o->op_type); 1183 /* FALL THROUGH */ 1184 case OP_ASLICE: 1185 case OP_HSLICE: 1186 383996 if (type == OP_LEAVESUBLV) 1187 6 o->op_private |= OPpMAYBE_LVSUB; 1188 383996 localize = 1; 1189 /* FALL THROUGH */ 1190 case OP_AASSIGN: 1191 case OP_NEXTSTATE: 1192 case OP_DBSTATE: 1193 384078 PL_modcount = RETURN_UNLIMITED_NUMBER; 1194 384078 break; 1195 case OP_RV2SV: 1196 267244 ref(cUNOPo->op_first, o->op_type); 1197 267244 localize = 1; 1198 /* FALL THROUGH */ 1199 case OP_GV: 1200 case OP_AV2ARYLEN: 1201 268025 PL_hints |= HINT_BLOCK_SCOPE; 1202 case OP_SASSIGN: 1203 case OP_ANDASSIGN: 1204 case OP_ORASSIGN: 1205 case OP_DORASSIGN: 1206 272844 PL_modcount++; 1207 272844 break; 1208 1209 case OP_AELEMFAST: 1210 ###### localize = -1; 1211 ###### PL_modcount++; 1212 ###### break; 1213 1214 case OP_PADAV: 1215 case OP_PADHV: 1216 132972 PL_modcount = RETURN_UNLIMITED_NUMBER; 1217 132972 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) 1218 4 return o; /* Treat \(@foo) like ordinary list. */ 1219 132968 if (scalar_mod_type(o, type)) 1220 1 goto nomod; 1221 132967 if (type == OP_LEAVESUBLV) 1222 3 o->op_private |= OPpMAYBE_LVSUB; 1223 /* FALL THROUGH */ 1224 case OP_PADSV: 1225 1317582 PL_modcount++; 1226 1317582 if (!type) /* local() */ 1227 1 Perl_croak(aTHX_ "Can't localize lexical variable %s", 1228 PAD_COMPNAME_PV(o->op_targ)); 1229 292295 break; 1230 1231 case OP_PUSHMARK: 1232 292295 localize = 0; 1233 292295 break; 1234 1235 case OP_KEYS: 1236 5519 if (type != OP_SASSIGN) 1237 5515 goto nomod; 1238 1605 goto lvalue_func; 1239 case OP_SUBSTR: 1240 1605 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */ 1241 8 goto nomod; 1242 /* FALL THROUGH */ 1243 case OP_POS: 1244 case OP_VEC: 1245 10070 if (type == OP_LEAVESUBLV) 1246 4 o->op_private |= OPpMAYBE_LVSUB; 1247 lvalue_func: 1248 10074 pad_free(o->op_targ); 1249 10074 o->op_targ = pad_alloc(o->op_type, SVs_PADMY); 1250 10074 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL); 1251 10074 if (o->op_flags & OPf_KIDS) 1252 10074 mod(cBINOPo->op_first->op_sibling, type); 1253 10074 break; 1254 1255 case OP_AELEM: 1256 case OP_HELEM: 1257 169902 ref(cBINOPo->op_first, o->op_type); 1258 169902 if (type == OP_ENTERSUB && 1259 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF))) 1260 41682 o->op_private |= OPpLVAL_DEFER; 1261 169902 if (type == OP_LEAVESUBLV) 1262 8 o->op_private |= OPpMAYBE_LVSUB; 1263 169902 localize = 1; 1264 169902 PL_modcount++; 1265 169902 break; 1266 1267 case OP_SCOPE: 1268 case OP_LEAVE: 1269 case OP_ENTER: 1270 case OP_LINESEQ: 1271 47 localize = 0; 1272 47 if (o->op_flags & OPf_KIDS) 1273 47 mod(cLISTOPo->op_last, type); 1274 47 break; 1275 1276 case OP_NULL: 1277 204277 localize = 0; 1278 204277 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */ 1279 706 goto nomod; 1280 203571 else if (!(o->op_flags & OPf_KIDS)) 1281 1 break; 1282 203570 if (o->op_targ != OP_LIST) { 1283 6625 mod(cBINOPo->op_first, type); 1284 6625 break; 1285 } 1286 /* FALL THROUGH */ 1287 case OP_LIST: 1288 292295 localize = 0; 1289 1067644 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 1290 775350 mod(kid, type); 1291 6 break; 1292 1293 case OP_RETURN: 1294 6 if (type != OP_LEAVESUBLV) 1295 ###### goto nomod; 1296 3462827 break; /* mod()ing was handled by ck_return() */ 1297 } 1298 1299 /* [20011101.069] File test operators interpret OPf_REF to mean that 1300 their argument is a filehandle; thus \stat(".") should not set 1301 it. AMS 20011102 */ 1302 3462827 if (type == OP_REFGEN && 1303 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)) 1304 4 return o; 1305 1306 3462823 if (type != OP_LEAVESUBLV) 1307 3462722 o->op_flags |= OPf_MOD; 1308 1309 3462823 if (type == OP_AASSIGN || type == OP_SASSIGN) 1310 1201076 o->op_flags |= OPf_SPECIAL|OPf_REF; 1311 2261747 else if (!type) { /* local() */ 1312 58000 switch (localize) { 1313 case 1: 1314 45520 o->op_private |= OPpLVAL_INTRO; 1315 45520 o->op_flags &= ~OPf_SPECIAL; 1316 45520 PL_hints |= HINT_BLOCK_SCOPE; 1317 45520 break; 1318 case 0: 1319 30 break; 1320 case -1: 1321 30 if (ckWARN(WARN_SYNTAX)) { 1322 28 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), 1323 "Useless localization of %s", OP_DESC(o)); 1324 } 1325 } 1326 } 1327 2203747 else if (type != OP_GREPSTART && type != OP_ENTERSUB 1328 && type != OP_LEAVESUBLV) 1329 1047079 o->op_flags |= OPf_REF; 1330 3462823 return o; 1331 } 1332 1333 STATIC bool 1334 S_scalar_mod_type(pTHX_ const OP *o, I32 type) 1335 508786 { 1336 508786 switch (type) { 1337 case OP_SASSIGN: 1338 24665 if (o->op_type == OP_RV2GV) 1339 24665 return FALSE; 1340 /* FALL THROUGH */ 1341 case OP_PREINC: 1342 case OP_PREDEC: 1343 case OP_POSTINC: 1344 case OP_POSTDEC: 1345 case OP_I_PREINC: 1346 case OP_I_PREDEC: 1347 case OP_I_POSTINC: 1348 case OP_I_POSTDEC: 1349 case OP_POW: 1350 case OP_MULTIPLY: 1351 case OP_DIVIDE: 1352 case OP_MODULO: 1353 case OP_REPEAT: 1354 case OP_ADD: 1355 case OP_SUBTRACT: 1356 case OP_I_MULTIPLY: 1357 case OP_I_DIVIDE: 1358 case OP_I_MODULO: 1359 case OP_I_ADD: 1360 case OP_I_SUBTRACT: 1361 case OP_LEFT_SHIFT: 1362 case OP_RIGHT_SHIFT: 1363 case OP_BIT_AND: 1364 case OP_BIT_XOR: 1365 case OP_BIT_OR: 1366 case OP_CONCAT: 1367 case OP_SUBST: 1368 case OP_TRANS: 1369 case OP_READ: 1370 case OP_SYSREAD: 1371 case OP_RECV: 1372 case OP_ANDASSIGN: 1373 case OP_ORASSIGN: 1374 2 return TRUE; 1375 default: 1376 484119 return FALSE; 1377 } 1378 } 1379 1380 STATIC bool 1381 S_is_handle_constructor(pTHX_ const OP *o, I32 numargs) 1382 10881 { 1383 10881 switch (o->op_type) { 1384 case OP_PIPE_OP: 1385 case OP_SOCKPAIR: 1386 140 if (numargs == 2) 1387 70 return TRUE; 1388 /* FALL THROUGH */ 1389 case OP_SYSOPEN: 1390 case OP_OPEN: 1391 case OP_SELECT: /* XXX c.f. SelectSaver.pm */ 1392 case OP_SOCKET: 1393 case OP_OPEN_DIR: 1394 case OP_ACCEPT: 1395 3895 if (numargs == 1) 1396 3883 return TRUE; 1397 /* FALL THROUGH */ 1398 default: 1399 6928 return FALSE; 1400 } 1401 } 1402 1403 OP * 1404 Perl_refkids(pTHX_ OP *o, I32 type) 1405 91533 { 1406 91533 if (o && o->op_flags & OPf_KIDS) { 1407 91533 OP *kid; 1408 183066 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 1409 91533 ref(kid, type); 1410 } 1411 91533 return o; 1412 } 1413 1414 OP * 1415 Perl_ref(pTHX_ OP *o, I32 type) 1416 2387799 { 1417 dVAR; 1418 2387799 OP *kid; 1419 1420 2387799 if (!o || PL_error_count) 1421 3 return o; 1422 1423 2387796 switch (o->op_type) { 1424 case OP_ENTERSUB: 1425 10696 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) && 1426 !(o->op_flags & OPf_STACKED)) { 1427 8712 o->op_type = OP_RV2CV; /* entersub => rv2cv */ 1428 8712 o->op_ppaddr = PL_ppaddr[OP_RV2CV]; 1429 8712 assert(cUNOPo->op_first->op_type == OP_NULL); 1430 8712 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */ 1431 8712 o->op_flags |= OPf_SPECIAL; 1432 } 1433 8712 break; 1434 1435 case OP_COND_EXPR: 1436 15 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) 1437 10 ref(kid, type); 1438 20894 break; 1439 case OP_RV2SV: 1440 20894 if (type == OP_DEFINED) 1441 9073 o->op_flags |= OPf_SPECIAL; /* don't create GV */ 1442 20894 ref(cUNOPo->op_first, o->op_type); 1443 /* FALL THROUGH */ 1444 case OP_PADSV: 1445 456588 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) { 1446 366432 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV 1447 : type == OP_RV2HV ? OPpDEREF_HV 1448 : OPpDEREF_SV); 1449 366432 o->op_flags |= OPf_MOD; 1450 } 1451 366432 break; 1452 1453 case OP_THREADSV: 1454 ###### o->op_flags |= OPf_MOD; /* XXX ??? */ 1455 ###### break; 1456 1457 case OP_RV2AV: 1458 case OP_RV2HV: 1459 645881 o->op_flags |= OPf_REF; 1460 /* FALL THROUGH */ 1461 case OP_RV2GV: 1462 708066 if (type == OP_DEFINED) 1463 78 o->op_flags |= OPf_SPECIAL; /* don't create GV */ 1464 708066 ref(cUNOPo->op_first, o->op_type); 1465 708066 break; 1466 1467 case OP_PADAV: 1468 case OP_PADHV: 1469 142682 o->op_flags |= OPf_REF; 1470 142682 break; 1471 1472 case OP_SCALAR: 1473 case OP_NULL: 1474 2660 if (!(o->op_flags & OPf_KIDS)) 1475 ###### break; 1476 2660 ref(cBINOPo->op_first, type); 1477 2660 break; 1478 case OP_AELEM: 1479 case OP_HELEM: 1480 55551 ref(cBINOPo->op_first, o->op_type); 1481 55551 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) { 1482 39697 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV 1483 : type == OP_RV2HV ? OPpDEREF_HV 1484 : OPpDEREF_SV); 1485 39697 o->op_flags |= OPf_MOD; 1486 } 1487 39697 break; 1488 1489 case OP_SCOPE: 1490 case OP_LEAVE: 1491 case OP_ENTER: 1492 case OP_LIST: 1493 72449 if (!(o->op_flags & OPf_KIDS)) 1494 ###### break; 1495 72449 ref(cLISTOPo->op_last, type); 1496 break; 1497 default: 1498 2387796 break; 1499 } 1500 2387796 return scalar(o); 1501 1502 } 1503 1504 STATIC OP * 1505 S_dup_attrlist(pTHX_ OP *o) 1506 77 { 1507 77 OP *rop = Nullop; 1508 1509 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids, 1510 * where the first kid is OP_PUSHMARK and the remaining ones 1511 * are OP_CONST. We need to push the OP_CONST values. 1512 */ 1513 77 if (o->op_type == OP_CONST) 1514 70 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv)); 1515 else { 1516 7 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS)); 1517 28 for (o = cLISTOPo->op_first; o; o=o->op_sibling) { 1518 21 if (o->op_type == OP_CONST) 1519 14 rop = append_elem(OP_LIST, rop, 1520 newSVOP(OP_CONST, o->op_flags, 1521 14 SvREFCNT_inc(cSVOPo->op_sv))); 1522 } 1523 } 1524 77 return rop; 1525 } 1526 1527 STATIC void 1528 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my) 1529 77 { 1530 dVAR; 1531 77 SV *stashsv; 1532 1533 /* fake up C */ 1534 77 ENTER; /* need to protect against side-effects of 'use' */ 1535 77 SAVEINT(PL_expect); 1536 77 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no; 1537 1538 #define ATTRSMODULE "attributes" 1539 #define ATTRSMODULE_PM "attributes.pm" 1540 1541 77 if (for_my) { 1542 /* Don't force the C if we don't need it. */ 1543 44 SV **svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM, 1544 44 sizeof(ATTRSMODULE_PM)-1, 0); 1545 44 if (svp && *svp != &PL_sv_undef) 1546 ; /* already in %INC */ 1547 else 1548 ###### Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, 1549 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1), 1550 Nullsv); 1551 } 1552 else { 1553 33 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS, 1554 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1), 1555 Nullsv, 1556 prepend_elem(OP_LIST, 1557 newSVOP(OP_CONST, 0, stashsv), 1558 prepend_elem(OP_LIST, 1559 newSVOP(OP_CONST, 0, 1560 newRV(target)), 1561 dup_attrlist(attrs)))); 1562 } 1563 70 LEAVE; 1564 } 1565 1566 STATIC void 1567 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) 1568 44 { 1569 44 OP *pack, *imop, *arg; 1570 44 SV *meth, *stashsv; 1571 1572 44 if (!attrs) 1573 ###### return; 1574 1575 assert(target->op_type == OP_PADSV || 1576 target->op_type == OP_PADHV || 1577 44 target->op_type == OP_PADAV); 1578 1579 /* Ensure that attributes.pm is loaded. */ 1580 44 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE); 1581 1582 /* Need package name for method call. */ 1583 44 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1)); 1584 1585 /* Build up the real arg-list. */ 1586 44 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no; 1587 1588 44 arg = newOP(OP_PADSV, 0); 1589 44 arg->op_targ = target->op_targ; 1590 44 arg = prepend_elem(OP_LIST, 1591 newSVOP(OP_CONST, 0, stashsv), 1592 prepend_elem(OP_LIST, 1593 newUNOP(OP_REFGEN, 0, 1594 mod(arg, OP_REFGEN)), 1595 dup_attrlist(attrs))); 1596 1597 /* Fake up a method call to import */ 1598 44 meth = newSVpvn_share("import", 6, 0); 1599 44 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID, 1600 append_elem(OP_LIST, 1601 prepend_elem(OP_LIST, pack, list(arg)), 1602 newSVOP(OP_METHOD_NAMED, 0, meth))); 1603 44 imop->op_private |= OPpENTERSUB_NOMOD; 1604 1605 /* Combine the ops. */ 1606 44 *imopsp = append_elem(OP_LIST, *imopsp, imop); 1607 } 1608 1609 /* 1610 =notfor apidoc apply_attrs_string 1611 1612 Attempts to apply a list of attributes specified by the C and 1613 C arguments to the subroutine identified by the C argument which 1614 is expected to be associated with the package identified by the C 1615 argument (see L). It gets this wrong, though, in that it 1616 does not correctly identify the boundaries of the individual attribute 1617 specifications within C. This is not really intended for the 1618 public API, but has to be listed here for systems such as AIX which 1619 need an explicit export list for symbols. (It's called from XS code 1620 in support of the C keyword from F.) Patches to fix it 1621 to respect attribute syntax properly would be welcome. 1622 1623 =cut 1624 */ 1625 1626 void 1627 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv, 1628 const char *attrstr, STRLEN len) 1629 ###### { 1630 ###### OP *attrs = Nullop; 1631 1632 ###### if (!len) { 1633 ###### len = strlen(attrstr); 1634 } 1635 1636 ###### while (len) { 1637 ###### for (; isSPACE(*attrstr) && len; --len, ++attrstr) ; 1638 ###### if (len) { 1639 ###### const char *sstr = attrstr; 1640 ###### for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ; 1641 ###### attrs = append_elem(OP_LIST, attrs, 1642 newSVOP(OP_CONST, 0, 1643 newSVpvn(sstr, attrstr-sstr))); 1644 } 1645 } 1646 1647 ###### Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS, 1648 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1), 1649 Nullsv, prepend_elem(OP_LIST, 1650 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)), 1651 prepend_elem(OP_LIST, 1652 newSVOP(OP_CONST, 0, 1653 newRV((SV*)cv)), 1654 attrs))); 1655 } 1656 1657 STATIC OP * 1658 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) 1659 804990 { 1660 804990 I32 type; 1661 1662 804990 if (!o || PL_error_count) 1663 10 return o; 1664 1665 804980 type = o->op_type; 1666 804980 if (type == OP_LIST) { 1667 84786 OP *kid; 1668 410750 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) 1669 325964 my_kid(kid, attrs, imopsp); 1670 720194 } else if (type == OP_UNDEF) { 1671 327 return o; 1672 719867 } else if (type == OP_RV2SV || /* "our" declaration */ 1673 type == OP_RV2AV || 1674 type == OP_RV2HV) { /* XXX does this let anything illegal in? */ 1675 46669 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */ 1676 6 yyerror(Perl_form(aTHX_ "Can't declare %s in %s", 1677 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my")); 1678 46663 } else if (attrs) { 1679 2 GV *gv = cGVOPx_gv(cUNOPo->op_first); 1680 2 PL_in_my = FALSE; 1681 2 PL_in_my_stash = Nullhv; 1682 2 apply_attrs(GvSTASH(gv), 1683 (type == OP_RV2SV ? GvSV(gv) : 1684 type == OP_RV2AV ? (SV*)GvAV(gv) : 1685 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv), 1686 attrs, FALSE); 1687 } 1688 46669 o->op_private |= OPpOUR_INTRO; 1689 46669 return o; 1690 } 1691 673198 else if (type != OP_PADSV && 1692 type != OP_PADAV && 1693 type != OP_PADHV && 1694 type != OP_PUSHMARK) 1695 { 1696 ###### yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"", 1697 OP_DESC(o), 1698 PL_in_my == KEY_our ? "our" : "my")); 1699 ###### return o; 1700 } 1701 673198 else if (attrs && type != OP_PUSHMARK) { 1702 44 HV *stash; 1703 1704 44 PL_in_my = FALSE; 1705 44 PL_in_my_stash = Nullhv; 1706 1707 /* check for C when deciding package */ 1708 44 stash = PAD_COMPNAME_TYPE(o->op_targ); 1709 44 if (!stash) 1710 37 stash = PL_curstash; 1711 44 apply_attrs_my(stash, o, attrs, imopsp); 1712 } 1713 757984 o->op_flags |= OPf_MOD; 1714 757984 o->op_private |= OPpLVAL_INTRO; 1715 757984 return o; 1716 } 1717 1718 OP * 1719 Perl_my_attrs(pTHX_ OP *o, OP *attrs) 1720 479026 { 1721 479026 OP *rops = Nullop; 1722 479026 int maybe_scalar = 0; 1723 1724 /* [perl #17376]: this appears to be premature, and results in code such as 1725 C< our(%x); > executing in list mode rather than void mode */ 1726 #if 0 1727 if (o->op_flags & OPf_PARENS) 1728 list(o); 1729 else 1730 maybe_scalar = 1; 1731 #else 1732 479026 maybe_scalar = 1; 1733 #endif 1734 479026 if (attrs) 1735 46 SAVEFREEOP(attrs); 1736 479026 o = my_kid(o, attrs, &rops); 1737 479026 if (rops) { 1738 42 if (maybe_scalar && o->op_type == OP_PADSV) { 1739 26 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o)); 1740 26 o->op_private |= OPpLVAL_INTRO; 1741 } 1742 else 1743 16 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops); 1744 } 1745 479026 PL_in_my = FALSE; 1746 479026 PL_in_my_stash = Nullhv; 1747 479026 return o; 1748 } 1749 1750 OP * 1751 Perl_my(pTHX_ OP *o) 1752 478132 { 1753 478132 return my_attrs(o, Nullop); 1754 } 1755 1756 OP * 1757 Perl_sawparens(pTHX_ OP *o) 1758 378092 { 1759 378092 if (o) 1760 378092 o->op_flags |= OPf_PARENS; 1761 378092 return o; 1762 } 1763 1764 OP * 1765 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) 1766 130387 { 1767 130387 OP *o; 1768 130387 bool ismatchop = 0; 1769 1770 130387 if (ckWARN(WARN_MISC) && 1771 (left->op_type == OP_RV2AV || 1772 left->op_type == OP_RV2HV || 1773 left->op_type == OP_PADAV || 1774 left->op_type == OP_PADHV)) { 1775 12 const char *desc = PL_op_desc[(right->op_type == OP_SUBST || 1776 right->op_type == OP_TRANS) 1777 12 ? right->op_type : OP_MATCH]; 1778 12 const char *sample = ((left->op_type == OP_RV2AV || 1779 left->op_type == OP_PADAV) 1780 12 ? "@array" : "%hash"); 1781 12 Perl_warner(aTHX_ packWARN(WARN_MISC), 1782 "Applying %s to %s will act on scalar(%s)", 1783 desc, sample, sample); 1784 } 1785 1786 130387 if (right->op_type == OP_CONST && 1787 cSVOPx(right)->op_private & OPpCONST_BARE && 1788 cSVOPx(right)->op_private & OPpCONST_STRICT) 1789 { 1790 1 no_bareword_allowed(right); 1791 } 1792 1793 130387 ismatchop = right->op_type == OP_MATCH || 1794 right->op_type == OP_SUBST || 1795 right->op_type == OP_TRANS; 1796 130387 if (ismatchop && right->op_private & OPpTARGET_MY) { 1797 16 right->op_targ = 0; 1798 16 right->op_private &= ~OPpTARGET_MY; 1799 } 1800 130387 if (!(right->op_flags & OPf_STACKED) && ismatchop) { 1801 124281 right->op_flags |= OPf_STACKED; 1802 124281 if (right->op_type != OP_MATCH && 1803 ! (right->op_type == OP_TRANS && 1804 right->op_private & OPpTRANS_IDENTICAL)) 1805 48428 left = mod(left, right->op_type); 1806 124281 if (right->op_type == OP_TRANS) 1807 4873 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right); 1808 else 1809 119408 o = prepend_elem(right->op_type, scalar(left), right); 1810 124281 if (type == OP_NOT) 1811 11589 return newUNOP(OP_NOT, 0, scalar(o)); 1812 112692 return o; 1813 } 1814 else 1815 6106 return bind_match(type, left, 1816 pmruntime(newPMOP(OP_MATCH, 0), right, 0)); 1817 } 1818 1819 OP * 1820 Perl_invert(pTHX_ OP *o) 1821 22605 { 1822 22605 if (!o) 1823 ###### return o; 1824 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */ 1825 22605 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o)); 1826 } 1827 1828 OP * 1829 Perl_scope(pTHX_ OP *o) 1830 443748 { 1831 dVAR; 1832 443748 if (o) { 1833 443748 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) { 1834 292800 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o); 1835 292800 o->op_type = OP_LEAVE; 1836 292800 o->op_ppaddr = PL_ppaddr[OP_LEAVE]; 1837 } 1838 150948 else if (o->op_type == OP_LINESEQ) { 1839 149892 OP *kid; 1840 149892 o->op_type = OP_SCOPE; 1841 149892 o->op_ppaddr = PL_ppaddr[OP_SCOPE]; 1842 149892 kid = ((LISTOP*)o)->op_first; 1843 149892 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) 1844 149892 op_null(kid); 1845 } 1846 else 1847 1056 o = newLISTOP(OP_SCOPE, 0, o, Nullop); 1848 } 1849 443748 return o; 1850 } 1851 1852 /* XXX kept for BINCOMPAT only */ 1853 void 1854 Perl_save_hints(pTHX) 1855 ###### { 1856 ###### Perl_croak(aTHX_ "internal error: obsolete function save_hints() called"); 1857 } 1858 1859 int 1860 Perl_block_start(pTHX_ int full) 1861 1080196 { 1862 1080196 const int retval = PL_savestack_ix; 1863 1080196 pad_block_start(full); 1864 1080196 SAVEHINTS(); 1865 1080196 PL_hints &= ~HINT_BLOCK_SCOPE; 1866 1080196 SAVESPTR(PL_compiling.cop_warnings); 1867 1080196 if (! specialWARN(PL_compiling.cop_warnings)) { 1868 14317 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ; 1869 14317 SAVEFREESV(PL_compiling.cop_warnings) ; 1870 } 1871 1080196 SAVESPTR(PL_compiling.cop_io); 1872 1080196 if (! specialCopIO(PL_compiling.cop_io)) { 1873 3 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ; 1874 3 SAVEFREESV(PL_compiling.cop_io) ; 1875 } 1876 1080196 return retval; 1877 } 1878 1879 OP* 1880 Perl_block_end(pTHX_ I32 floor, OP *seq) 1881 1079382 { 1882 1079382 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE; 1883 1079382 OP* retval = scalarseq(seq); 1884 1079379 LEAVE_SCOPE(floor); 1885 1079379 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); 1886 1079379 if (needblockscope) 1887 754568 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */ 1888 1079379 pad_leavemy(); 1889 1079379 return retval; 1890 } 1891 1892 STATIC OP * 1893 S_newDEFSVOP(pTHX) 1894 5878 { 1895 5878 const I32 offset = pad_findmy("$_"); 1896 5878 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) { 1897 5871 return newSVREF(newGVOP(OP_GV, 0, PL_defgv)); 1898 } 1899 else { 1900 7 OP *o = newOP(OP_PADSV, 0); 1901 7 o->op_targ = offset; 1902 7 return o; 1903 } 1904 } 1905 1906 void 1907 Perl_newPROG(pTHX_ OP *o) 1908 92813 { 1909 92813 if (PL_in_eval) { 1910 88965 if (PL_eval_root) 1911 ###### return; 1912 88965 PL_eval_root = newUNOP(OP_LEAVEEVAL, 1913 ((PL_in_eval & EVAL_KEEPERR) 1914 ? OPf_SPECIAL : 0), o); 1915 88964 PL_eval_start = linklist(PL_eval_root); 1916 88964 PL_eval_root->op_private |= OPpREFCOUNTED; 1917 88964 OpREFCNT_set(PL_eval_root, 1); 1918 88964 PL_eval_root->op_next = 0; 1919 88964 CALL_PEEP(PL_eval_start); 1920 } 1921 else { 1922 3848 if (o->op_type == OP_STUB) { 1923 51 PL_comppad_name = 0; 1924 51 PL_compcv = 0; 1925 51 FreeOp(o); 1926 51 return; 1927 } 1928 3797 PL_main_root = scope(sawparens(scalarvoid(o))); 1929 3797 PL_curcop = &PL_compiling; 1930 3797 PL_main_start = LINKLIST(PL_main_root); 1931 3797 PL_main_root->op_private |= OPpREFCOUNTED; 1932 3797 OpREFCNT_set(PL_main_root, 1); 1933 3797 PL_main_root->op_next = 0; 1934 3797 CALL_PEEP(PL_main_start); 1935 3797 PL_compcv = 0; 1936 1937 /* Register with debugger */ 1938 3797 if (PERLDB_INTER) { 1939 1 CV *cv = get_cv("DB::postponed", FALSE); 1940 1 if (cv) { 1941 ###### dSP; 1942 ###### PUSHMARK(SP); 1943 ###### XPUSHs((SV*)CopFILEGV(&PL_compiling)); 1944 ###### PUTBACK; 1945 ###### call_sv((SV*)cv, G_DISCARD); 1946 } 1947 } 1948 } 1949 } 1950 1951 OP * 1952 Perl_localize(pTHX_ OP *o, I32 lex) 1953 491899 { 1954 491899 if (o->op_flags & OPf_PARENS) 1955 /* [perl #17376]: this appears to be premature, and results in code such as 1956 C< our(%x); > executing in list mode rather than void mode */ 1957 #if 0 1958 list(o); 1959 #else 1960 ; 1961 #endif 1962 else { 1963 374026 if (ckWARN(WARN_PARENTHESIS) 1964 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') 1965 { 1966 388 char *s = PL_bufptr; 1967 388 bool sigil = FALSE; 1968 1969 /* some heuristics to detect a potential error */ 1970 757 while (*s && (strchr(", \t\n", *s))) 1971 369 s++; 1972 1973 644 while (1) { 1974 644 if (*s && strchr("@$%*", *s) && *++s 1975 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) { 1976 256 s++; 1977 256 sigil = TRUE; 1978 1023 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) 1979 767 s++; 1980 266 while (*s && (strchr(", \t\n", *s))) 1981 10 s++; 1982 } 1983 else 1984 388 break; 1985 } 1986 388 if (sigil && (*s == ';' || *s == '=')) { 1987 5 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS), 1988 "Parentheses missing around \"%s\" list", 1989 lex ? (PL_in_my == KEY_our ? "our" : "my") 1990 : "local"); 1991 } 1992 } 1993 } 1994 491899 if (lex) 1995 454897 o = my(o); 1996 else 1997 37002 o = mod(o, OP_NULL); /* a bit kludgey */ 1998 491898 PL_in_my = FALSE; 1999 491898 PL_in_my_stash = Nullhv; 2000 491898 return o; 2001 } 2002 2003 OP * 2004 Perl_jmaybe(pTHX_ OP *o) 2005 363792 { 2006 363792 if (o->op_type == OP_LIST) { 2007 319 OP *o2; 2008 319 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))), 2009 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o)); 2010 } 2011 363792 return o; 2012 } 2013 2014 OP * 2015 Perl_fold_constants(pTHX_ register OP *o) 2016 7844394 { 2017 dVAR; 2018 7844394 register OP *curop; 2019 7844394 I32 type = o->op_type; 2020 7844394 SV *sv; 2021 2022 7844394 if (PL_opargs[type] & OA_RETSCALAR) 2023 4212522 scalar(o); 2024 7844394 if (PL_opargs[type] & OA_TARGET && !o->op_targ) 2025 2902338 o->op_targ = pad_alloc(type, SVs_PADTMP); 2026 2027 /* integerize op, unless it happens to be C<-foo>. 2028 * XXX should pp_i_negate() do magic string negation instead? */ 2029 7844394 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER) 2030 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST 2031 && (cUNOPo->op_first->op_private & OPpCONST_BARE))) 2032 { 2033 7842 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)]; 2034 } 2035 2036 7844394 if (!(PL_opargs[type] & OA_FOLDCONST)) 2037 6288381 goto nope; 2038 2039 1556013 switch (type) { 2040 case OP_NEGATE: 2041 /* XXX might want a ck_negate() for this */ 2042 23444 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT; 2043 23444 break; 2044 case OP_SPRINTF: 2045 case OP_UCFIRST: 2046 case OP_LCFIRST: 2047 case OP_UC: 2048 case OP_LC: 2049 case OP_SLT: 2050 case OP_SGT: 2051 case OP_SLE: 2052 case OP_SGE: 2053 case OP_SCMP: 2054 /* XXX what about the numeric ops? */ 2055 28437 if (PL_hints & HINT_LOCALE) 2056 11157 goto nope; 2057 } 2058 2059 1544856 if (PL_error_count) 2060 29 goto nope; /* Don't try to run w/ errors */ 2061 2062 3032026 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) { 2063 2779119 if ((curop->op_type != OP_CONST || 2064 (curop->op_private & OPpCONST_BARE)) && 2065 curop->op_type != OP_LIST && 2066 curop->op_type != OP_SCALAR && 2067 curop->op_type != OP_NULL && 2068 curop->op_type != OP_PUSHMARK) 2069 { 2070 1291920 goto nope; 2071 } 2072 } 2073 2074 252907 curop = LINKLIST(o); 2075 252907 o->op_next = 0; 2076 252907 PL_op = curop; 2077 252907 CALLRUNOPS(aTHX); 2078 252904 sv = *(PL_stack_sp--); 2079 252904 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */ 2080 251054 pad_swipe(o->op_targ, FALSE); 2081 1850 else if (SvTEMP(sv)) { /* grab mortal temp? */ 2082 410 (void)SvREFCNT_inc(sv); 2083 410 SvTEMP_off(sv); 2084 } 2085 252904 op_free(o); 2086 252904 if (type == OP_RV2GV) 2087 ###### return newGVOP(OP_GV, 0, (GV*)sv); 2088 252904 return newSVOP(OP_CONST, 0, sv); 2089 2090 nope: 2091 7591487 return o; 2092 } 2093 2094 OP * 2095 Perl_gen_constant_list(pTHX_ register OP *o) 2096 1028 { 2097 dVAR; 2098 1028 register OP *curop; 2099 1028 const I32 oldtmps_floor = PL_tmps_floor; 2100 2101 1028 list(o); 2102 1028 if (PL_error_count) 2103 ###### return o; /* Don't attempt to run with errors */ 2104 2105 1028 PL_op = curop = LINKLIST(o); 2106 1028 o->op_next = 0; 2107 1028 CALL_PEEP(curop); 2108 1028 pp_pushmark(); 2109 1028 CALLRUNOPS(aTHX); 2110 1028 PL_op = curop; 2111 1028 pp_anonlist(); 2112 1028 PL_tmps_floor = oldtmps_floor; 2113 2114 1028 o->op_type = OP_RV2AV; 2115 1028 o->op_ppaddr = PL_ppaddr[OP_RV2AV]; 2116 1028 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */ 2117 1028 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */ 2118 1028 o->op_opt = 0; /* needs to be revisited in peep() */ 2119 1028 curop = ((UNOP*)o)->op_first; 2120 1028 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--)); 2121 1028 op_free(curop); 2122 1028 linklist(o); 2123 1028 return list(o); 2124 } 2125 2126 OP * 2127 Perl_convert(pTHX_ I32 type, I32 flags, OP *o) 2128 1209235 { 2129 dVAR; 2130 1209235 if (!o || o->op_type != OP_LIST) 2131 689267 o = newLISTOP(OP_LIST, 0, o, Nullop); 2132 else 2133 519968 o->op_flags &= ~OPf_WANT; 2134 2135 1209234 if (!(PL_opargs[type] & OA_MARK)) 2136 547354 op_null(cLISTOPo->op_first); 2137 2138 1209234 o->op_type = (OPCODE)type; 2139 1209234 o->op_ppaddr = PL_ppaddr[type]; 2140 1209234 o->op_flags |= flags; 2141 2142 1209234 o = CHECKOP(type, o); 2143 1209141 if (o->op_type != (unsigned)type) 2144 22288 return o; 2145 2146 1186853 return fold_constants(o); 2147 } 2148 2149 /* List constructors */ 2150 2151 OP * 2152 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last) 2153 2727098 { 2154 2727098 if (!first) 2155 108082 return last; 2156 2157 2619016 if (!last) 2158 33052 return first; 2159 2160 2585964 if (first->op_type != (unsigned)type 2161 || (type == OP_LIST && (first->op_flags & OPf_PARENS))) 2162 { 2163 880493 return newLISTOP(type, 0, first, last); 2164 } 2165 2166 1705471 if (first->op_flags & OPf_KIDS) 2167 1705471 ((LISTOP*)first)->op_last->op_sibling = last; 2168 else { 2169 ###### first->op_flags |= OPf_KIDS; 2170 ###### ((LISTOP*)first)->op_first = last; 2171 } 2172 1705471 ((LISTOP*)first)->op_last = last; 2173 1705471 return first; 2174 } 2175 2176 OP * 2177 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last) 2178 2904907 { 2179 2904907 if (!first) 2180 818470 return (OP*)last; 2181 2182 2086437 if (!last) 2183 611994 return (OP*)first; 2184 2185 1474443 if (first->op_type != (unsigned)type) 2186 13157 return prepend_elem(type, (OP*)first, (OP*)last); 2187 2188 1461286 if (last->op_type != (unsigned)type) 2189 56514 return append_elem(type, (OP*)first, (OP*)last); 2190 2191 1404772 first->op_last->op_sibling = last->op_first; 2192 1404772 first->op_last = last->op_last; 2193 1404772 first->op_flags |= (last->op_flags & OPf_KIDS); 2194 2195 1404772 FreeOp(last); 2196 2197 1404772 return (OP*)first; 2198 } 2199 2200 OP * 2201 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last) 2202 3128853 { 2203 3128853 if (!first) 2204 ###### return last; 2205 2206 3128853 if (!last) 2207 111202 return first; 2208 2209 3017651 if (last->op_type == (unsigned)type) { 2210 544483 if (type == OP_LIST) { /* already a PUSHMARK there */ 2211 54405 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling; 2212 54405 ((LISTOP*)last)->op_first->op_sibling = first; 2213 54405 if (!(first->op_flags & OPf_PARENS)) 2214 54350 last->op_flags &= ~OPf_PARENS; 2215 } 2216 else { 2217 490078 if (!(last->op_flags & OPf_KIDS)) { 2218 129368 ((LISTOP*)last)->op_last = first; 2219 129368 last->op_flags |= OPf_KIDS; 2220 } 2221 490078 first->op_sibling = ((LISTOP*)last)->op_first; 2222 490078 ((LISTOP*)last)->op_first = first; 2223 } 2224 544483 last->op_flags |= OPf_KIDS; 2225 544483 return last; 2226 } 2227 2228 2473168 return newLISTOP(type, 0, first, last); 2229 } 2230 2231 /* Constructors */ 2232 2233 OP * 2234 Perl_newNULLLIST(pTHX) 2235 18716 { 2236 18716 return newOP(OP_STUB, 0); 2237 } 2238 2239 OP * 2240 Perl_force_list(pTHX_ OP *o) 2241 979900 { 2242 979900 if (!o || o->op_type != OP_LIST) 2243 602972 o = newLISTOP(OP_LIST, 0, o, Nullop); 2244 979900 op_null(o); 2245 979900 return o; 2246 } 2247 2248 OP * 2249 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) 2250 4660905 { 2251 dVAR; 2252 4660905 LISTOP *listop; 2253 2254 4660905 NewOp(1101, listop, 1, LISTOP); 2255 2256 4660905 listop->op_type = (OPCODE)type; 2257 4660905 listop->op_ppaddr = PL_ppaddr[type]; 2258 4660905 if (first || last) 2259 4632378 flags |= OPf_KIDS; 2260 4660905 listop->op_flags = (U8)flags; 2261 2262 4660905 if (!last && first) 2263 1264768 last = first; 2264 3396137 else if (!first && last) 2265 ###### first = last; 2266 3396137 else if (first) 2267 3367610 first->op_sibling = last; 2268 4660905 listop->op_first = first; 2269 4660905 listop->op_last = last; 2270 4660905 if (type == OP_LIST) { 2271 2301385 OP* pushop; 2272 2301385 pushop = newOP(OP_PUSHMARK, 0); 2273 2301384 pushop->op_sibling = first; 2274 2301384 listop->op_first = pushop; 2275 2301384 listop->op_flags |= OPf_KIDS; 2276 2301384 if (!last) 2277 28527 listop->op_last = pushop; 2278 } 2279 2280 4660904 return CHECKOP(type, listop); 2281 } 2282 2283 OP * 2284 Perl_newOP(pTHX_ I32 type, I32 flags) 2285 5790078 { 2286 dVAR; 2287 5790078 OP *o; 2288 5790078 NewOp(1101, o, 1, OP); 2289 5790078 o->op_type = (OPCODE)type; 2290 5790078 o->op_ppaddr = PL_ppaddr[type]; 2291 5790078 o->op_flags = (U8)flags; 2292 2293 5790078 o->op_next = o; 2294 5790078 o->op_private = (U8)(0 | (flags >> 8)); 2295 5790078 if (PL_opargs[type] & OA_RETSCALAR) 2296 2535977 scalar(o); 2297 5790078 if (PL_opargs[type] & OA_TARGET) 2298 12429 o->op_targ = pad_alloc(type, SVs_PADTMP); 2299 5790078 return CHECKOP(type, o); 2300 } 2301 2302 OP * 2303 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) 2304 4502603 { 2305 dVAR; 2306 4502603 UNOP *unop; 2307 2308 4502603 if (!first) 2309 ###### first = newOP(OP_STUB, 0); 2310 4502603 if (PL_opargs[type] & OA_MARK) 2311 495208 first = force_list(first); 2312 2313 4502603 NewOp(1101, unop, 1, UNOP); 2314 4502603 unop->op_type = (OPCODE)type; 2315 4502603 unop->op_ppaddr = PL_ppaddr[type]; 2316 4502603 unop->op_first = first; 2317 4502603 unop->op_flags = flags | OPf_KIDS; 2318 4502603 unop->op_private = (U8)(1 | (flags >> 8)); 2319 4502603 unop = (UNOP*) CHECKOP(type, unop); 2320 4502532 if (unop->op_next) 2321 215164 return (OP*)unop; 2322 2323 4287368 return fold_constants((OP *) unop); 2324 } 2325 2326 OP * 2327 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) 2328 2394951 { 2329 dVAR; 2330 2394951 BINOP *binop; 2331 2394951 NewOp(1101, binop, 1, BINOP); 2332 2333 2394951 if (!first) 2334 ###### first = newOP(OP_NULL, 0); 2335 2336 2394951 binop->op_type = (OPCODE)type; 2337 2394951 binop->op_ppaddr = PL_ppaddr[type]; 2338 2394951 binop->op_first = first; 2339 2394951 binop->op_flags = flags | OPf_KIDS; 2340 2394951 if (!last) { 2341 ###### last = first; 2342 ###### binop->op_private = (U8)(1 | (flags >> 8)); 2343 } 2344 else { 2345 2394951 binop->op_private = (U8)(2 | (flags >> 8)); 2346 2394951 first->op_sibling = last; 2347 } 2348 2349 2394951 binop = (BINOP*)CHECKOP(type, binop); 2350 2394916 if (binop->op_next || binop->op_type != (OPCODE)type) 2351 24828 return (OP*)binop; 2352 2353 2370088 binop->op_last = binop->op_first->op_sibling; 2354 2355 2370088 return fold_constants((OP *)binop); 2356 } 2357 2358 static int uvcompare(const void *a, const void *b) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__pure__; 2359 static int uvcompare(const void *a, const void *b) 2360 2050 { 2361 2050 if (*((const UV *)a) < (*(const UV *)b)) 2362 2050 return -1; 2363 ###### if (*((const UV *)a) > (*(const UV *)b)) 2364 ###### return 1; 2365 ###### if (*((const UV *)a+1) < (*(const UV *)b+1)) 2366 ###### return -1; 2367 ###### if (*((const UV *)a+1) > (*(const UV *)b+1)) 2368 ###### return 1; 2369 ###### return 0; 2370 } 2371 2372 OP * 2373 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) 2374 5123 { 2375 5123 SV *tstr = ((SVOP*)expr)->op_sv; 2376 5123 SV *rstr = ((SVOP*)repl)->op_sv; 2377 5123 STRLEN tlen; 2378 5123 STRLEN rlen; 2379 5123 const U8 *t = (U8*)SvPV_const(tstr, tlen); 2380 5123 const U8 *r = (U8*)SvPV_const(rstr, rlen); 2381 5123 register I32 i; 2382 5123 register I32 j; 2383 5123 I32 del; 2384 5123 I32 complement; 2385 5123 I32 squash; 2386 5123 I32 grows = 0; 2387 5123 register short *tbl; 2388 2389 5123 PL_hints |= HINT_BLOCK_SCOPE; 2390 5123 complement = o->op_private & OPpTRANS_COMPLEMENT; 2391 5123 del = o->op_private & OPpTRANS_DELETE; 2392 5123 squash = o->op_private & OPpTRANS_SQUASH; 2393 2394 5123 if (SvUTF8(tstr)) 2395 42 o->op_private |= OPpTRANS_FROM_UTF; 2396 2397 5123 if (SvUTF8(rstr)) 2398 43 o->op_private |= OPpTRANS_TO_UTF; 2399 2400 5123 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) { 2401 47 SV* listsv = newSVpvn("# comment\n",10); 2402 47 SV* transv = 0; 2403 47 const U8* tend = t + tlen; 2404 47 const U8* rend = r + rlen; 2405 47 STRLEN ulen; 2406 47 UV tfirst = 1; 2407 47 UV tlast = 0; 2408 47 IV tdiff; 2409 47 UV rfirst = 1; 2410 47 UV rlast = 0; 2411 47 IV rdiff; 2412 47 IV diff; 2413 47 I32 none = 0; 2414 47 U32 max = 0; 2415 47 I32 bits; 2416 47 I32 havefinal = 0; 2417 47 U32 final = 0; 2418 47 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF; 2419 47 I32 to_utf = o->op_private & OPpTRANS_TO_UTF; 2420 47 U8* tsave = NULL; 2421 47 U8* rsave = NULL; 2422 2423 47 if (!from_utf) { 2424 5 STRLEN len = tlen; 2425 5 t = tsave = bytes_to_utf8(t, &len); 2426 5 tend = t + len; 2427 } 2428 47 if (!to_utf && rlen) { 2429 ###### STRLEN len = rlen; 2430 ###### r = rsave = bytes_to_utf8(r, &len); 2431 ###### rend = r + len; 2432 } 2433 2434 /* There are several snags with this code on EBCDIC: 2435 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes). 2436 2. scan_const() in toke.c has encoded chars in native encoding which makes 2437 ranges at least in EBCDIC 0..255 range the bottom odd. 2438 */ 2439 2440 47 if (complement) { 2441 8 U8 tmpbuf[UTF8_MAXBYTES+1]; 2442 8 UV *cp; 2443 8 UV nextmin = 0; 2444 8 New(1109, cp, 2*tlen, UV); 2445 8 i = 0; 2446 8 transv = newSVpvn("",0); 2447 528 while (t < tend) { 2448 520 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0); 2449 520 t += ulen; 2450 520 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { 2451 4 t++; 2452 4 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0); 2453 4 t += ulen; 2454 } 2455 else { 2456 516 cp[2*i+1] = cp[2*i]; 2457 } 2458 520 i++; 2459 } 2460 8 qsort(cp, i, 2*sizeof(UV), uvcompare); 2461 528 for (j = 0; j < i; j++) { 2462 520 UV val = cp[2*j]; 2463 520 diff = val - nextmin; 2464 520 if (diff > 0) { 2465 6 t = uvuni_to_utf8(tmpbuf,nextmin); 2466 6 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); 2467 6 if (diff > 1) { 2468 4 U8 range_mark = UTF_TO_NATIVE(0xff); 2469 4 t = uvuni_to_utf8(tmpbuf, val - 1); 2470 4 sv_catpvn(transv, (char *)&range_mark, 1); 2471 4 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); 2472 } 2473 } 2474 520 val = cp[2*j+1]; 2475 520 if (val >= nextmin) 2476 520 nextmin = val + 1; 2477 } 2478 8 t = uvuni_to_utf8(tmpbuf,nextmin); 2479 8 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); 2480 { 2481 8 U8 range_mark = UTF_TO_NATIVE(0xff); 2482 8 sv_catpvn(transv, (char *)&range_mark, 1); 2483 } 2484 8 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff, 2485 UNICODE_ALLOW_SUPER); 2486 8 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); 2487 8 t = (const U8*)SvPVX_const(transv); 2488 8 tlen = SvCUR(transv); 2489 8 tend = t + tlen; 2490 8 Safefree(cp); 2491 } 2492 39 else if (!rlen && !del) { 2493 ###### r = t; rlen = tlen; rend = tend; 2494 } 2495 47 if (!squash) { 2496 44 if ((!rlen && !del) || t == r || 2497 (tlen == rlen && memEQ((char *)t, (char *)r, tlen))) 2498 { 2499 4 o->op_private |= OPpTRANS_IDENTICAL; 2500 } 2501 } 2502 2503 141 while (t < tend || tfirst <= tlast) { 2504 /* see if we need more "t" chars */ 2505 94 if (tfirst > tlast) { 2506 89 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0); 2507 89 t += ulen; 2508 89 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */ 2509 32 t++; 2510 32 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0); 2511 32 t += ulen; 2512 } 2513 else 2514 57 tlast = tfirst; 2515 } 2516 2517 /* now see if we need more "r" chars */ 2518 94 if (rfirst > rlast) { 2519 86 if (r < rend) { 2520 75 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0); 2521 75 r += ulen; 2522 75 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */ 2523 20 r++; 2524 20 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0); 2525 20 r += ulen; 2526 } 2527 else 2528 55 rlast = rfirst; 2529 } 2530 else { 2531 11 if (!havefinal++) 2532 11 final = rlast; 2533 11 rfirst = rlast = 0xffffffff; 2534 } 2535 } 2536 2537 /* now see which range will peter our first, if either. */ 2538 94 tdiff = tlast - tfirst; 2539 94 rdiff = rlast - rfirst; 2540 2541 94 if (tdiff <= rdiff) 2542 76 diff = tdiff; 2543 else 2544 18 diff = rdiff; 2545 2546 94 if (rfirst == 0xffffffff) { 2547 15 diff = tdiff; /* oops, pretend rdiff is infinite */ 2548 15 if (diff > 0) 2549 13 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n", 2550 (long)tfirst, (long)tlast); 2551 else 2552 2 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst); 2553 } 2554 else { 2555 79 if (diff > 0) 2556 19 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n", 2557 (long)tfirst, (long)(tfirst + diff), 2558 (long)rfirst); 2559 else 2560 60 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n", 2561 (long)tfirst, (long)rfirst); 2562 2563 79 if (rfirst + diff > max) 2564 51 max = rfirst + diff; 2565 79 if (!grows) 2566 53 grows = (tfirst < rfirst && 2567 UNISKIP(tfirst) < UNISKIP(rfirst + diff)); 2568 79 rfirst += diff + 1; 2569 } 2570 94 tfirst += diff + 1; 2571 } 2572 2573 47 none = ++max; 2574 47 if (del) 2575 2 del = ++max; 2576 2577 47 if (max > 0xffff) 2578 ###### bits = 32; 2579 47 else if (max > 0xff) 2580 33 bits = 16; 2581 else 2582 14 bits = 8; 2583 2584 47 Safefree(cPVOPo->op_pv); 2585 47 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none); 2586 47 SvREFCNT_dec(listsv); 2587 47 if (transv) 2588 8 SvREFCNT_dec(transv); 2589 2590 47 if (!del && havefinal && rlen) 2591 7 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5, 2592 newSVuv((UV)final), 0); 2593 2594 47 if (grows) 2595 5 o->op_private |= OPpTRANS_GROWS; 2596 2597 47 if (tsave) 2598 5 Safefree(tsave); 2599 47 if (rsave) 2600 ###### Safefree(rsave); 2601 2602 47 op_free(expr); 2603 47 op_free(repl); 2604 47 return o; 2605 } 2606 2607 5076 tbl = (short*)cPVOPo->op_pv; 2608 5076 if (complement) { 2609 183 Zero(tbl, 256, short); 2610 12555 for (i = 0; i < (I32)tlen; i++) 2611 12372 tbl[t[i]] = -1; 2612 47031 for (i = 0, j = 0; i < 256; i++) { 2613 46848 if (!tbl[i]) { 2614 34476 if (j >= (I32)rlen) { 2615 34476 if (del) 2616 29765 tbl[i] = -2; 2617 4711 else if (rlen) 2618 ###### tbl[i] = r[j-1]; 2619 else 2620 4711 tbl[i] = (short)i; 2621 } 2622 else { 2623 ###### if (i < 128 && r[j] >= 128) 2624 ###### grows = 1; 2625 ###### tbl[i] = r[j++]; 2626 } 2627 } 2628 } 2629 183 if (!del) { 2630 33 if (!rlen) { 2631 29 j = rlen; 2632 29 if (!squash) 2633 26 o->op_private |= OPpTRANS_IDENTICAL; 2634 } 2635 4 else if (j >= (I32)rlen) 2636 ###### j = rlen - 1; 2637 else 2638 4 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short); 2639 33 tbl[0x100] = rlen - j; 2640 39 for (i=0; i < (I32)rlen - j; i++) 2641 6 tbl[0x101+i] = r[j+i]; 2642 } 2643 } 2644 else { 2645 4893 if (!rlen && !del) { 2646 1923 r = t; rlen = tlen; 2647 1923 if (!squash) 2648 1923 o->op_private |= OPpTRANS_IDENTICAL; 2649 } 2650 2970 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) { 2651 47 o->op_private |= OPpTRANS_IDENTICAL; 2652 } 2653 1257501 for (i = 0; i < 256; i++) 2654 1252608 tbl[i] = -1; 2655 111596 for (i = 0, j = 0; i < (I32)tlen; i++,j++) { 2656 106703 if (j >= (I32)rlen) { 2657 20276 if (del) { 2658 13577 if (tbl[t[i]] == -1) 2659 12865 tbl[t[i]] = -2; 2660 12865 continue; 2661 } 2662 6699 --j; 2663 } 2664 93126 if (tbl[t[i]] == -1) { 2665 93122 if (t[i] < 128 && r[j] >= 128) 2666 2826 grows = 1; 2667 93122 tbl[t[i]] = r[j]; 2668 } 2669 } 2670 } 2671 5076 if (grows) 2672 32 o->op_private |= OPpTRANS_GROWS; 2673 5076 op_free(expr); 2674 5076 op_free(repl); 2675 2676 5076 return o; 2677 } 2678 2679 OP * 2680 Perl_newPMOP(pTHX_ I32 type, I32 flags) 2681 160257 { 2682 dVAR; 2683 160257 PMOP *pmop; 2684 2685 160257 NewOp(1101, pmop, 1, PMOP); 2686 160257 pmop->op_type = (OPCODE)type; 2687 160257 pmop->op_ppaddr = PL_ppaddr[type]; 2688 160257 pmop->op_flags = (U8)flags; 2689 160257 pmop->op_private = (U8)(0 | (flags >> 8)); 2690 2691 160257 if (PL_hints & HINT_RE_TAINT) 2692 9748 pmop->op_pmpermflags |= PMf_RETAINT; 2693 160257 if (PL_hints & HINT_LOCALE) 2694 504 pmop->op_pmpermflags |= PMf_LOCALE; 2695 160257 pmop->op_pmflags = pmop->op_pmpermflags; 2696 2697 #ifdef USE_ITHREADS 2698 { 2699 SV* repointer; 2700 if(av_len((AV*) PL_regex_pad[0]) > -1) { 2701 repointer = av_pop((AV*)PL_regex_pad[0]); 2702 pmop->op_pmoffset = SvIV(repointer); 2703 SvREPADTMP_off(repointer); 2704 sv_setiv(repointer,0); 2705 } else { 2706 repointer = newSViv(0); 2707 av_push(PL_regex_padav,SvREFCNT_inc(repointer)); 2708 pmop->op_pmoffset = av_len(PL_regex_padav); 2709 PL_regex_pad = AvARRAY(PL_regex_padav); 2710 } 2711 } 2712 #endif 2713 2714 /* link into pm list */ 2715 160257 if (type != OP_TRANS && PL_curstash) { 2716 160257 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab); 2717 2718 160257 if (!mg) { 2719 15488 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0); 2720 } 2721 160257 pmop->op_pmnext = (PMOP*)mg->mg_obj; 2722 160257 mg->mg_obj = (SV*)pmop; 2723 160257 PmopSTASH_set(pmop,PL_curstash); 2724 } 2725 2726 160257 return CHECKOP(type, pmop); 2727 } 2728 2729 /* Given some sort of match op o, and an expression expr containing a 2730 * pattern, either compile expr into a regex and attach it to o (if it's 2731 * constant), or convert expr into a runtime regcomp op sequence (if it's 2732 * not) 2733 * 2734 * isreg indicates that the pattern is part of a regex construct, eg 2735 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or 2736 * split "pattern", which aren't. In the former case, expr will be a list 2737 * if the pattern contains more than one term (eg /a$b/) or if it contains 2738 * a replacement, ie s/// or tr///. 2739 */ 2740 2741 OP * 2742 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) 2743 165375 { 2744 dVAR; 2745 165375 PMOP *pm; 2746 165375 LOGOP *rcop; 2747 165375 I32 repl_has_vars = 0; 2748 165375 OP* repl = Nullop; 2749 165375 bool reglist; 2750 2751 165375 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) { 2752 /* last element in list is the replacement; pop it */ 2753 58242 OP* kid; 2754 58242 repl = cLISTOPx(expr)->op_last; 2755 58242 kid = cLISTOPx(expr)->op_first; 2756 122881 while (kid->op_sibling != repl) 2757 64639 kid = kid->op_sibling; 2758 58242 kid->op_sibling = Nullop; 2759 58242 cLISTOPx(expr)->op_last = kid; 2760 } 2761 2762 165375 if (isreg && expr->op_type == OP_LIST && 2763 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last) 2764 { 2765 /* convert single element list to element */ 2766 55366 OP* oe = expr; 2767 55366 expr = cLISTOPx(oe)->op_first->op_sibling; 2768 55366 cLISTOPx(oe)->op_first->op_sibling = Nullop; 2769 55366 cLISTOPx(oe)->op_last = Nullop; 2770 55366 op_free(oe); 2771 } 2772 2773 165375 if (o->op_type == OP_TRANS) { 2774 5123 return pmtrans(o, expr, repl); 2775 } 2776 2777 160252 reglist = isreg && expr->op_type == OP_LIST; 2778 160252 if (reglist) 2779 9158 op_null(expr); 2780 2781 160252 PL_hints |= HINT_BLOCK_SCOPE; 2782 160252 pm = (PMOP*)o; 2783 2784 160252 if (expr->op_type == OP_CONST) { 2785 140591 STRLEN plen; 2786 140591 SV *pat = ((SVOP*)expr)->op_sv; 2787 140591 const char *p = SvPV_const(pat, plen); 2788 140591 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) { 2789 918 U32 was_readonly = SvREADONLY(pat); 2790 2791 918 if (was_readonly) { 2792 918 if (SvFAKE(pat)) { 2793 ###### sv_force_normal_flags(pat, 0); 2794 ###### assert(!SvREADONLY(pat)); 2795 ###### was_readonly = 0; 2796 } else { 2797 918 SvREADONLY_off(pat); 2798 } 2799 } 2800 2801 918 sv_setpvn(pat, "\\s+", 3); 2802 2803 918 SvFLAGS(pat) |= was_readonly; 2804 2805 918 p = SvPV_const(pat, plen); 2806 918 pm->op_pmflags |= PMf_SKIPWHITE; 2807 } 2808 140591 if (DO_UTF8(pat)) 2809 45 pm->op_pmdynflags |= PMdf_UTF8; 2810 /* FIXME - can we make this function take const char * args? */ 2811 140591 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm)); 2812 140360 if (strEQ("\\s+", PM_GETRE(pm)->precomp)) 2813 1790 pm->op_pmflags |= PMf_WHITE; 2814 140360 op_free(expr); 2815 } 2816 else { 2817 19661 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) 2818 19640 expr = newUNOP((!(PL_hints & HINT_RE_EVAL) 2819 ? OP_REGCRESET 2820 : OP_REGCMAYBE),0,expr); 2821 2822 19661 NewOp(1101, rcop, 1, LOGOP); 2823 19661 rcop->op_type = OP_REGCOMP; 2824 19661 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP]; 2825 19661 rcop->op_first = scalar(expr); 2826 19661 rcop->op_flags |= OPf_KIDS 2827 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0) 2828 | (reglist ? OPf_STACKED : 0); 2829 19661 rcop->op_private = 1; 2830 19661 rcop->op_other = o; 2831 19661 if (reglist) 2832 9158 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP); 2833 2834 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */ 2835 19661 PL_cv_has_eval = 1; 2836 2837 /* establish postfix order */ 2838 19661 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) { 2839 19640 LINKLIST(expr); 2840 19640 rcop->op_next = expr; 2841 19640 ((UNOP*)expr)->op_first->op_next = (OP*)rcop; 2842 } 2843 else { 2844 21 rcop->op_next = LINKLIST(expr); 2845 21 expr->op_next = (OP*)rcop; 2846 } 2847 2848 19661 prepend_elem(o->op_type, scalar((OP*)rcop), o); 2849 } 2850 2851 160021 if (repl) { 2852 53119 OP *curop; 2853 53119 if (pm->op_pmflags & PMf_EVAL) { 2854 3674 curop = 0; 2855 3674 if (CopLINE(PL_curcop) < (line_t)PL_multi_end) 2856 2 CopLINE_set(PL_curcop, (line_t)PL_multi_end); 2857 } 2858 49445 else if (repl->op_type == OP_CONST) 2859 40643 curop = repl; 2860 else { 2861 8802 OP *lastop = 0; 2862 14395 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) { 2863 13342 if (PL_opargs[curop->op_type] & OA_DANGEROUS) { 2864 9419 if (curop->op_type == OP_GV) { 2865 7677 GV *gv = cGVOPx_gv(curop); 2866 7677 repl_has_vars = 1; 2867 7677 if (strchr("&`'123456789+-\016\022", *GvENAME(gv))) 2868 7453 break; 2869 } 2870 1742 else if (curop->op_type == OP_RV2CV) 2871 ###### break; 2872 1742 else if (curop->op_type == OP_RV2SV || 2873 curop->op_type == OP_RV2AV || 2874 curop->op_type == OP_RV2HV || 2875 curop->op_type == OP_RV2GV) { 2876 438 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/ 2877 296 break; 2878 } 2879 1304 else if (curop->op_type == OP_PADSV || 2880 curop->op_type == OP_PADAV || 2881 curop->op_type == OP_PADHV || 2882 curop->op_type == OP_PADANY) { 2883 1304 repl_has_vars = 1; 2884 } 2885 ###### else if (curop->op_type == OP_PUSHRE) 2886 ; /* Okay here, dangerous in newASSIGNOP */ 2887 else 2888 5593 break; 2889 } 2890 5593 lastop = curop; 2891 } 2892 } 2893 53119 if (curop == repl 2894 && !(repl_has_vars 2895 && (!PM_GETRE(pm) 2896 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) { 2897 41531 pm->op_pmflags |= PMf_CONST; /* const for long enough */ 2898 41531 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */ 2899 41531 prepend_elem(o->op_type, scalar(repl), o); 2900 } 2901 else { 2902 11588 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */ 2903 163 pm->op_pmflags |= PMf_MAYBE_CONST; 2904 163 pm->op_pmpermflags |= PMf_MAYBE_CONST; 2905 } 2906 11588 NewOp(1101, rcop, 1, LOGOP); 2907 11588 rcop->op_type = OP_SUBSTCONT; 2908 11588 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT]; 2909 11588 rcop->op_first = scalar(repl); 2910 11588 rcop->op_flags |= OPf_KIDS; 2911 11588 rcop->op_private = 1; 2912 11588 rcop->op_other = o; 2913 2914 /* establish postfix order */ 2915 11588 rcop->op_next = LINKLIST(repl); 2916 11588 repl->op_next = (OP*)rcop; 2917 2918 11588 pm->op_pmreplroot = scalar((OP*)rcop); 2919 11588 pm->op_pmreplstart = LINKLIST(rcop); 2920 11588 rcop->op_next = 0; 2921 } 2922 } 2923 2924 160021 return (OP*)pm; 2925 } 2926 2927 OP * 2928 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv) 2929 5792867 { 2930 dVAR; 2931 5792867 SVOP *svop; 2932 5792867 NewOp(1101, svop, 1, SVOP); 2933 5792867 svop->op_type = (OPCODE)type; 2934 5792867 svop->op_ppaddr = PL_ppaddr[type]; 2935 5792867 svop->op_sv = sv; 2936 5792867 svop->op_next = (OP*)svop; 2937 5792867 svop->op_flags = (U8)flags; 2938 5792867 if (PL_opargs[type] & OA_RETSCALAR) 2939 5522452 scalar((OP*)svop); 2940 5792867 if (PL_opargs[type] & OA_TARGET) 2941 514 svop->op_targ = pad_alloc(type, SVs_PADTMP); 2942 5792867 return CHECKOP(type, svop); 2943 } 2944 2945 OP * 2946 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) 2947 ###### { 2948 dVAR; 2949 ###### PADOP *padop; 2950 ###### NewOp(1101, padop, 1, PADOP); 2951 ###### padop->op_type = (OPCODE)type; 2952 ###### padop->op_ppaddr = PL_ppaddr[type]; 2953 ###### padop->op_padix = pad_alloc(type, SVs_PADTMP); 2954 ###### SvREFCNT_dec(PAD_SVl(padop->op_padix)); 2955 ###### PAD_SETSV(padop->op_padix, sv); 2956 ###### if (sv) 2957 ###### SvPADTMP_on(sv); 2958 ###### padop->op_next = (OP*)padop; 2959 ###### padop->op_flags = (U8)flags; 2960 ###### if (PL_opargs[type] & OA_RETSCALAR) 2961 ###### scalar((OP*)padop); 2962 ###### if (PL_opargs[type] & OA_TARGET) 2963 ###### padop->op_targ = pad_alloc(type, SVs_PADTMP); 2964 ###### return CHECKOP(type, padop); 2965 } 2966 2967 OP * 2968 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv) 2969 155387 { 2970 dVAR; 2971 #ifdef USE_ITHREADS 2972 if (gv) 2973 GvIN_PAD_on(gv); 2974 return newPADOP(type, flags, SvREFCNT_inc(gv)); 2975 #else 2976 155387 return newSVOP(type, flags, SvREFCNT_inc(gv)); 2977 #endif 2978 } 2979 2980 OP * 2981 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv) 2982 13330 { 2983 dVAR; 2984 13330 PVOP *pvop; 2985 13330 NewOp(1101, pvop, 1, PVOP); 2986 13330 pvop->op_type = (OPCODE)type; 2987 13330 pvop->op_ppaddr = PL_ppaddr[type]; 2988 13330 pvop->op_pv = pv; 2989 13330 pvop->op_next = (OP*)pvop; 2990 13330 pvop->op_flags = (U8)flags; 2991 13330 if (PL_opargs[type] & OA_RETSCALAR) 2992 13330 scalar((OP*)pvop); 2993 13330 if (PL_opargs[type] & OA_TARGET) 2994 ###### pvop->op_targ = pad_alloc(type, SVs_PADTMP); 2995 13330 return CHECKOP(type, pvop); 2996 } 2997 2998 void 2999 Perl_package(pTHX_ OP *o) 3000 28674 { 3001 28674 const char *name; 3002 28674 STRLEN len; 3003 3004 28674 save_hptr(&PL_curstash); 3005 28674 save_item(PL_curstname); 3006 3007 28674 name = SvPV_const(cSVOPo->op_sv, len); 3008 28674 PL_curstash = gv_stashpvn(name, len, TRUE); 3009 28674 sv_setpvn(PL_curstname, name, len); 3010 28674 op_free(o); 3011 3012 28674 PL_hints |= HINT_BLOCK_SCOPE; 3013 28674 PL_copline = NOLINE; 3014 28674 PL_expect = XSTATE; 3015 } 3016 3017 void 3018 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) 3019 49806 { 3020 49806 OP *pack; 3021 49806 OP *imop; 3022 49806 OP *veop; 3023 3024 49806 if (idop->op_type != OP_CONST) 3025 ###### Perl_croak(aTHX_ "Module name must be constant"); 3026 3027 49806 veop = Nullop; 3028 3029 49806 if (version != Nullop) { 3030 196 SV *vesv = ((SVOP*)version)->op_sv; 3031 3032 196 if (arg == Nullop && !SvNIOKp(vesv)) { 3033 ###### arg = version; 3034 } 3035 else { 3036 196 OP *pack; 3037 196 SV *meth; 3038 3039 196 if (version->op_type != OP_CONST || !SvNIOKp(vesv)) 3040 ###### Perl_croak(aTHX_ "Version number must be constant number"); 3041 3042 /* Make copy of idop so we don't free it twice */ 3043 196 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv)); 3044 3045 /* Fake up a method call to VERSION */ 3046 196 meth = newSVpvn_share("VERSION", 7, 0); 3047 196 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, 3048 append_elem(OP_LIST, 3049 prepend_elem(OP_LIST, pack, list(version)), 3050 newSVOP(OP_METHOD_NAMED, 0, meth))); 3051 } 3052 } 3053 3054 /* Fake up an import/unimport */ 3055 49806 if (arg && arg->op_type == OP_STUB) 3056 2407 imop = arg; /* no import on explicit () */ 3057 47399 else if (SvNIOKp(((SVOP*)idop)->op_sv)) { 3058 4137 imop = Nullop; /* use 5.0; */ 3059 } 3060 else { 3061 43262 SV *meth; 3062 3063 /* Make copy of idop so we don't free it twice */ 3064 43262 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv)); 3065 3066 /* Fake up a method call to import/unimport */ 3067 43262 meth = aver 3068 ? newSVpvn_share("import",6, 0) : newSVpvn_share("unimport", 8, 0); 3069 43262 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, 3070 append_elem(OP_LIST, 3071 prepend_elem(OP_LIST, pack, list(arg)), 3072 newSVOP(OP_METHOD_NAMED, 0, meth))); 3073 } 3074 3075 /* Fake up the BEGIN {}, which does its thing immediately. */ 3076 49806 newATTRSUB(floor, 3077 newSVOP(OP_CONST, 0, newSVpvn_share("BEGIN", 5, 0)), 3078 Nullop, 3079 Nullop, 3080 append_elem(OP_LINESEQ, 3081 append_elem(OP_LINESEQ, 3082 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)), 3083 newSTATEOP(0, Nullch, veop)), 3084 newSTATEOP(0, Nullch, imop) )); 3085 3086 /* The "did you use incorrect case?" warning used to be here. 3087 * The problem is that on case-insensitive filesystems one 3088 * might get false positives for "use" (and "require"): 3089 * "use Strict" or "require CARP" will work. This causes 3090 * portability problems for the script: in case-strict 3091 * filesystems the script will stop working. 3092 * 3093 * The "incorrect case" warning checked whether "use Foo" 3094 * imported "Foo" to your namespace, but that is wrong, too: 3095 * there is no requirement nor promise in the language that 3096 * a Foo.pm should or would contain anything in package "Foo". 3097 * 3098 * There is very little Configure-wise that can be done, either: 3099 * the case-sensitivity of the build filesystem of Perl does not 3100 * help in guessing the case-sensitivity of the runtime environment. 3101 */ 3102 3103 49671 PL_hints |= HINT_BLOCK_SCOPE; 3104 49671 PL_copline = NOLINE; 3105 49671 PL_expect = XSTATE; 3106 49671 PL_cop_seqmax++; /* Purely for B::*'s benefit */ 3107 } 3108 3109 /* 3110 =head1 Embedding Functions 3111 3112 =for apidoc load_module 3113 3114 Loads the module whose name is pointed to by the string part of name. 3115 Note that the actual module name, not its filename, should be given. 3116 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of 3117 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS 3118 (or 0 for no flags). ver, if specified, provides version semantics 3119 similar to C. The optional trailing SV* 3120 arguments can be used to specify arguments to the module's import() 3121 method, similar to C. 3122 3123 =cut */ 3124 3125 void 3126 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...) 3127 365 { 3128 365 va_list args; 3129 365 va_start(args, ver); 3130 365 vload_module(flags, name, ver, &args); 3131 va_end(args); 3132 } 3133 3134 #ifdef PERL_IMPLICIT_CONTEXT 3135 void 3136 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...) 3137 { 3138 dTHX; 3139 va_list args; 3140 va_start(args, ver); 3141 vload_module(flags, name, ver, &args); 3142 va_end(args); 3143 } 3144 #endif 3145 3146 void 3147 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args) 3148 365 { 3149 365 OP *modname, *veop, *imop; 3150 3151 365 modname = newSVOP(OP_CONST, 0, name); 3152 365 modname->op_private |= OPpCONST_BARE; 3153 365 if (ver) { 3154 66 veop = newSVOP(OP_CONST, 0, ver); 3155 } 3156 else 3157 299 veop = Nullop; 3158 365 if (flags & PERL_LOADMOD_NOIMPORT) { 3159 299 imop = sawparens(newNULLLIST()); 3160 } 3161 66 else if (flags & PERL_LOADMOD_IMPORT_OPS) { 3162 33 imop = va_arg(*args, OP*); 3163 } 3164 else { 3165 33 SV *sv; 3166 33 imop = Nullop; 3167 33 sv = va_arg(*args, SV*); 3168 66 while (sv) { 3169 33 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv)); 3170 33 sv = va_arg(*args, SV*); 3171 } 3172 } 3173 { 3174 365 const line_t ocopline = PL_copline; 3175 365 COP * const ocurcop = PL_curcop; 3176 365 const int oexpect = PL_expect; 3177 3178 365 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), 3179 veop, modname, imop); 3180 358 PL_expect = oexpect; 3181 358 PL_copline = ocopline; 3182 358 PL_curcop = ocurcop; 3183 } 3184 } 3185 3186 OP * 3187 Perl_dofile(pTHX_ OP *term) 3188 757 { 3189 757 OP *doop; 3190 757 GV *gv; 3191 3192 757 gv = gv_fetchpv("do", FALSE, SVt_PVCV); 3193 757 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) 3194 757 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV); 3195 3196 757 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) { 3197 ###### doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED, 3198 append_elem(OP_LIST, term, 3199 scalar(newUNOP(OP_RV2CV, 0, 3200 newGVOP(OP_GV, 0, 3201 gv)))))); 3202 } 3203 else { 3204 757 doop = newUNOP(OP_DOFILE, 0, scalar(term)); 3205 } 3206 756 return doop; 3207 } 3208 3209 OP * 3210 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval) 3211 17281 { 3212 17281 return newBINOP(OP_LSLICE, flags, 3213 list(force_list(subscript)), 3214 list(force_list(listval)) ); 3215 } 3216 3217 STATIC I32 3218 S_is_list_assignment(pTHX_ register const OP *o) 3219 879074 { 3220 879074 if (!o) 3221 ###### return TRUE; 3222 3223 879074 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS) 3224 231 o = cUNOPo->op_first; 3225 3226 879074 if (o->op_type == OP_COND_EXPR) { 3227 231 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibl