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