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