1 /* pp_ctl.c 2 * 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 4 * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others 5 * 6 * You may distribute under the terms of either the GNU General Public 7 * License or the Artistic License, as specified in the README file. 8 * 9 */ 10 11 /* 12 * Now far ahead the Road has gone, 13 * And I must follow, if I can, 14 * Pursuing it with eager feet, 15 * Until it joins some larger way 16 * Where many paths and errands meet. 17 * And whither then? I cannot say. 18 */ 19 20 /* This file contains control-oriented pp ("push/pop") functions that 21 * execute the opcodes that make up a perl program. A typical pp function 22 * expects to find its arguments on the stack, and usually pushes its 23 * results onto the stack, hence the 'pp' terminology. Each OP structure 24 * contains a pointer to the relevant pp_foo() function. 25 * 26 * Control-oriented means things like pp_enteriter() and pp_next(), which 27 * alter the flow of control of the program. 28 */ 29 30 31 #include "EXTERN.h" 32 #define PERL_IN_PP_CTL_C 33 #include "perl.h" 34 35 #ifndef WORD_ALIGN 36 #define WORD_ALIGN sizeof(U32) 37 #endif 38 39 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o)) 40 41 static I32 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen); 42 43 PP(pp_wantarray) 44 74262 { 45 74262 dSP; 46 74262 I32 cxix; 47 74262 EXTEND(SP, 1); 48 49 74262 cxix = dopoptosub(cxstack_ix); 50 74262 if (cxix < 0) 51 2 RETPUSHUNDEF; 52 53 74260 switch (cxstack[cxix].blk_gimme) { 54 case G_ARRAY: 55 33817 RETPUSHYES; 56 case G_SCALAR: 57 28067 RETPUSHNO; 58 default: 59 12376 RETPUSHUNDEF; 60 } 61 } 62 63 PP(pp_regcmaybe) 64 ###### { 65 ###### return NORMAL; 66 } 67 68 PP(pp_regcreset) 69 4085412 { 70 /* XXXX Should store the old value to allow for tie/overload - and 71 restore in regcomp, where marked with XXXX. */ 72 4085412 PL_reginterp_cnt = 0; 73 4085412 TAINT_NOT; 74 4085412 return NORMAL; 75 } 76 77 PP(pp_regcomp) 78 4059727 { 79 4059727 dSP; 80 4059727 register PMOP *pm = (PMOP*)cLOGOP->op_other; 81 4059727 SV *tmpstr; 82 4059727 MAGIC *mg = Null(MAGIC*); 83 84 /* prevent recompiling under /o and ithreads. */ 85 #if defined(USE_ITHREADS) 86 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) { 87 if (PL_op->op_flags & OPf_STACKED) { 88 dMARK; 89 SP = MARK; 90 } 91 else 92 (void)POPs; 93 RETURN; 94 } 95 #endif 96 4059727 if (PL_op->op_flags & OPf_STACKED) { 97 /* multiple args; concatentate them */ 98 453176 dMARK; dORIGMARK; 99 453176 tmpstr = PAD_SV(ARGTARG); 100 453176 sv_setpvn(tmpstr, "", 0); 101 2154721 while (++MARK <= SP) { 102 1701545 if (PL_amagic_generation) { 103 1701545 SV *sv; 104 1701545 if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) && 105 (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign))) 106 { 107 6 sv_setsv(tmpstr, sv); 108 6 continue; 109 } 110 } 111 1701539 sv_catsv(tmpstr, *MARK); 112 } 113 453176 SvSETMAGIC(tmpstr); 114 453176 SP = ORIGMARK; 115 } 116 else 117 3606551 tmpstr = POPs; 118 119 4059727 if (SvROK(tmpstr)) { 120 1892691 SV *sv = SvRV(tmpstr); 121 1892691 if(SvMAGICAL(sv)) 122 1892687 mg = mg_find(sv, PERL_MAGIC_qr); 123 } 124 4059727 if (mg) { 125 1892687 regexp *re = (regexp *)mg->mg_obj; 126 1892687 ReREFCNT_dec(PM_GETRE(pm)); 127 1892687 PM_SETRE(pm, ReREFCNT_inc(re)); 128 } 129 else { 130 2167040 STRLEN len; 131 2167040 const char *t = SvPV_const(tmpstr, len); 132 133 /* Check against the last compiled regexp. */ 134 2167040 if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp || 135 PM_GETRE(pm)->prelen != (I32)len || 136 memNE(PM_GETRE(pm)->precomp, t, len)) 137 { 138 1779079 if (PM_GETRE(pm)) { 139 1774460 ReREFCNT_dec(PM_GETRE(pm)); 140 1774460 PM_SETRE(pm, Null(REGEXP*)); /* crucial if regcomp aborts */ 141 } 142 1779079 if (PL_op->op_flags & OPf_SPECIAL) 143 64 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */ 144 145 1779079 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */ 146 1779079 if (DO_UTF8(tmpstr)) 147 7940 pm->op_pmdynflags |= PMdf_DYN_UTF8; 148 else { 149 1771139 pm->op_pmdynflags &= ~PMdf_DYN_UTF8; 150 1771139 if (pm->op_pmdynflags & PMdf_UTF8) 151 ###### t = (char*)bytes_to_utf8((U8*)t, &len); 152 } 153 1779079 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char *)t, (char *)t + len, pm)); 154 1778029 if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8)) 155 ###### Safefree(t); 156 1778029 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed 157 inside tie/overload accessors. */ 158 } 159 } 160 161 #ifndef INCOMPLETE_TAINTS 162 4058677 if (PL_tainting) { 163 3409607 if (PL_tainted) 164 848234 pm->op_pmdynflags |= PMdf_TAINTED; 165 else 166 2561373 pm->op_pmdynflags &= ~PMdf_TAINTED; 167 } 168 #endif 169 170 4058677 if (!PM_GETRE(pm)->prelen && PL_curpm) 171 17 pm = PL_curpm; 172 4058660 else if (strEQ("\\s+", PM_GETRE(pm)->precomp)) 173 1 pm->op_pmflags |= PMf_WHITE; 174 else 175 4058659 pm->op_pmflags &= ~PMf_WHITE; 176 177 /* XXX runtime compiled output needs to move to the pad */ 178 4058677 if (pm->op_pmflags & PMf_KEEP) { 179 643 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */ 180 #if !defined(USE_ITHREADS) 181 /* XXX can't change the optree at runtime either */ 182 643 cLOGOP->op_first->op_next = PL_op->op_next; 183 #endif 184 } 185 4058677 RETURN; 186 } 187 188 PP(pp_substcont) 189 646518 { 190 646518 dSP; 191 646518 register PERL_CONTEXT *cx = &cxstack[cxstack_ix]; 192 646518 register PMOP * const pm = (PMOP*) cLOGOP->op_other; 193 646518 register SV * const dstr = cx->sb_dstr; 194 646518 register char *s = cx->sb_s; 195 646518 register char *m = cx->sb_m; 196 646518 char *orig = cx->sb_orig; 197 646518 register REGEXP * const rx = cx->sb_rx; 198 646518 SV *nsv = Nullsv; 199 646518 REGEXP *old = PM_GETRE(pm); 200 646518 if(old != rx) { 201 4 if(old) 202 4 ReREFCNT_dec(old); 203 4 PM_SETRE(pm,rx); 204 } 205 206 646518 rxres_restore(&cx->sb_rxres, rx); 207 646518 RX_MATCH_UTF8_set(rx, SvUTF8(cx->sb_targ)); 208 209 646518 if (cx->sb_iters++) { 210 430470 const I32 saviters = cx->sb_iters; 211 430470 if (cx->sb_iters > cx->sb_maxiters) 212 ###### DIE(aTHX_ "Substitution loop"); 213 214 430470 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs)) 215 4 cx->sb_rxtainted |= 2; 216 430470 sv_catsv(dstr, POPs); 217 218 /* Are we done */ 219 430470 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig, 220 s == m, cx->sb_targ, NULL, 221 ((cx->sb_rflags & REXEC_COPY_STR) 222 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST) 223 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST)))) 224 { 225 216046 SV *targ = cx->sb_targ; 226 227 216046 assert(cx->sb_strend >= s); 228 216046 if(cx->sb_strend > s) { 229 174060 if (DO_UTF8(dstr) && !SvUTF8(targ)) 230 3 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv); 231 else 232 174057 sv_catpvn(dstr, s, cx->sb_strend - s); 233 } 234 216046 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx); 235 236 #ifdef PERL_OLD_COPY_ON_WRITE 237 if (SvIsCOW(targ)) { 238 sv_force_normal_flags(targ, SV_COW_DROP_PV); 239 } else 240 #endif 241 { 242 216046 SvPV_free(targ); 243 } 244 216046 SvPV_set(targ, SvPVX(dstr)); 245 216046 SvCUR_set(targ, SvCUR(dstr)); 246 216046 SvLEN_set(targ, SvLEN(dstr)); 247 216046 if (DO_UTF8(dstr)) 248 93 SvUTF8_on(targ); 249 216046 SvPV_set(dstr, (char*)0); 250 216046 sv_free(dstr); 251 252 216046 TAINT_IF(cx->sb_rxtainted & 1); 253 216046 PUSHs(sv_2mortal(newSViv(saviters - 1))); 254 255 216046 (void)SvPOK_only_UTF8(targ); 256 216046 TAINT_IF(cx->sb_rxtainted); 257 216046 SvSETMAGIC(targ); 258 216046 SvTAINT(targ); 259 260 216046 LEAVE_SCOPE(cx->sb_oldsave); 261 216046 ReREFCNT_dec(rx); 262 216046 POPSUBST(cx); 263 216046 RETURNOP(pm->op_next); 264 } 265 214424 cx->sb_iters = saviters; 266 } 267 430472 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) { 268 215063 m = s; 269 215063 s = orig; 270 215063 cx->sb_orig = orig = rx->subbeg; 271 215063 s = orig + (m - s); 272 215063 cx->sb_strend = s + (cx->sb_strend - m); 273 } 274 430472 cx->sb_m = m = rx->startp[0] + orig; 275 430472 if (m > s) { 276 173323 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ)) 277 3 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv); 278 else 279 173320 sv_catpvn(dstr, s, m-s); 280 } 281 430472 cx->sb_s = rx->endp[0] + orig; 282 { /* Update the pos() information. */ 283 430472 SV *sv = cx->sb_targ; 284 430472 MAGIC *mg; 285 430472 I32 i; 286 430472 if (SvTYPE(sv) < SVt_PVMG) 287 11650 SvUPGRADE(sv, SVt_PVMG); 288 430472 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) { 289 79285 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0); 290 79285 mg = mg_find(sv, PERL_MAGIC_regex_global); 291 } 292 430472 i = m - orig; 293 430472 if (DO_UTF8(sv)) 294 1043 sv_pos_b2u(sv, &i); 295 430472 mg->mg_len = i; 296 } 297 430472 if (old != rx) 298 4 (void)ReREFCNT_inc(rx); 299 430472 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx); 300 430472 rxres_save(&cx->sb_rxres, rx); 301 430472 RETURNOP(pm->op_pmreplstart); 302 } 303 304 void 305 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) 306 646520 { 307 646520 UV *p = (UV*)*rsp; 308 646520 U32 i; 309 310 646520 if (!p || p[1] < rx->nparens) { 311 #ifdef PERL_OLD_COPY_ON_WRITE 312 i = 7 + rx->nparens * 2; 313 #else 314 216048 i = 6 + rx->nparens * 2; 315 #endif 316 216048 if (!p) 317 216048 New(501, p, i, UV); 318 else 319 ###### Renew(p, i, UV); 320 216048 *rsp = (void*)p; 321 } 322 323 646520 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch); 324 646520 RX_MATCH_COPIED_off(rx); 325 326 #ifdef PERL_OLD_COPY_ON_WRITE 327 *p++ = PTR2UV(rx->saved_copy); 328 rx->saved_copy = Nullsv; 329 #endif 330 331 646520 *p++ = rx->nparens; 332 333 646520 *p++ = PTR2UV(rx->subbeg); 334 646520 *p++ = (UV)rx->sublen; 335 2335240 for (i = 0; i <= rx->nparens; ++i) { 336 1688720 *p++ = (UV)rx->startp[i]; 337 1688720 *p++ = (UV)rx->endp[i]; 338 } 339 } 340 341 void 342 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx) 343 646518 { 344 646518 UV *p = (UV*)*rsp; 345 646518 U32 i; 346 347 646518 RX_MATCH_COPY_FREE(rx); 348 646518 RX_MATCH_COPIED_set(rx, *p); 349 646518 *p++ = 0; 350 351 #ifdef PERL_OLD_COPY_ON_WRITE 352 if (rx->saved_copy) 353 SvREFCNT_dec (rx->saved_copy); 354 rx->saved_copy = INT2PTR(SV*,*p); 355 *p++ = 0; 356 #endif 357 358 646518 rx->nparens = *p++; 359 360 646518 rx->subbeg = INT2PTR(char*,*p++); 361 646518 rx->sublen = (I32)(*p++); 362 2335236 for (i = 0; i <= rx->nparens; ++i) { 363 1688718 rx->startp[i] = (I32)(*p++); 364 1688718 rx->endp[i] = (I32)(*p++); 365 } 366 } 367 368 void 369 Perl_rxres_free(pTHX_ void **rsp) 370 216048 { 371 216048 UV *p = (UV*)*rsp; 372 373 216048 if (p) { 374 #ifdef PERL_POISON 375 void *tmp = INT2PTR(char*,*p); 376 Safefree(tmp); 377 if (*p) 378 Poison(*p, 1, sizeof(*p)); 379 #else 380 216048 Safefree(INT2PTR(char*,*p)); 381 #endif 382 #ifdef PERL_OLD_COPY_ON_WRITE 383 if (p[1]) { 384 SvREFCNT_dec (INT2PTR(SV*,p[1])); 385 } 386 #endif 387 216048 Safefree(p); 388 216048 *rsp = Null(void*); 389 } 390 } 391 392 PP(pp_formline) 393 326 { 394 326 dSP; dMARK; dORIGMARK; 395 326 register SV *tmpForm = *++MARK; 396 326 register U32 *fpc; 397 326 register char *t; 398 326 const char *f; 399 326 register I32 arg; 400 326 register SV *sv = Nullsv; 401 326 const char *item = Nullch; 402 326 I32 itemsize = 0; 403 326 I32 fieldsize = 0; 404 326 I32 lines = 0; 405 326 bool chopspace = (strchr(PL_chopset, ' ') != Nullch); 406 326 const char *chophere = Nullch; 407 326 char *linemark = Nullch; 408 326 NV value; 409 326 bool gotsome = FALSE; 410 326 STRLEN len; 411 326 STRLEN fudge = SvPOK(tmpForm) 412 326 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0; 413 326 bool item_is_utf8 = FALSE; 414 326 bool targ_is_utf8 = FALSE; 415 326 SV * nsv = Nullsv; 416 326 OP * parseres = 0; 417 326 const char *fmt; 418 326 bool oneline; 419 420 326 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) { 421 121 if (SvREADONLY(tmpForm)) { 422 68 SvREADONLY_off(tmpForm); 423 68 parseres = doparseform(tmpForm); 424 67 SvREADONLY_on(tmpForm); 425 } 426 else 427 53 parseres = doparseform(tmpForm); 428 119 if (parseres) 429 ###### return parseres; 430 } 431 324 SvPV_force(PL_formtarget, len); 432 324 if (DO_UTF8(PL_formtarget)) 433 11 targ_is_utf8 = TRUE; 434 324 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */ 435 324 t += len; 436 324 f = SvPV_const(tmpForm, len); 437 /* need to jump to the next word */ 438 324 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN); 439 440 2735 for (;;) { 441 DEBUG_f( { 442 const char *name = "???"; 443 arg = -1; 444 switch (*fpc) { 445 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break; 446 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break; 447 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break; 448 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break; 449 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break; 450 451 case FF_CHECKNL: name = "CHECKNL"; break; 452 case FF_CHECKCHOP: name = "CHECKCHOP"; break; 453 case FF_SPACE: name = "SPACE"; break; 454 case FF_HALFSPACE: name = "HALFSPACE"; break; 455 case FF_ITEM: name = "ITEM"; break; 456 case FF_CHOP: name = "CHOP"; break; 457 case FF_LINEGLOB: name = "LINEGLOB"; break; 458 case FF_NEWLINE: name = "NEWLINE"; break; 459 case FF_MORE: name = "MORE"; break; 460 case FF_LINEMARK: name = "LINEMARK"; break; 461 case FF_END: name = "END"; break; 462 case FF_0DECIMAL: name = "0DECIMAL"; break; 463 case FF_LINESNGL: name = "LINESNGL"; break; 464 } 465 if (arg >= 0) 466 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg); 467 else 468 PerlIO_printf(Perl_debug_log, "%-16s\n", name); 469 2411 } ); 470 2411 switch (*fpc++) { 471 case FF_LINEMARK: 472 352 linemark = t; 473 352 lines++; 474 352 gotsome = FALSE; 475 352 break; 476 477 case FF_LITERAL: 478 236 arg = *fpc++; 479 236 if (targ_is_utf8 && !SvUTF8(tmpForm)) { 480 5 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); 481 5 *t = '\0'; 482 5 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv); 483 5 t = SvEND(PL_formtarget); 484 5 break; 485 } 486 231 if (!targ_is_utf8 && DO_UTF8(tmpForm)) { 487 ###### SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); 488 ###### *t = '\0'; 489 ###### sv_utf8_upgrade(PL_formtarget); 490 ###### SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1); 491 ###### t = SvEND(PL_formtarget); 492 ###### targ_is_utf8 = TRUE; 493 } 494 1521 while (arg--) 495 1290 *t++ = *f++; 496 98 break; 497 498 case FF_SKIP: 499 98 f += *fpc++; 500 98 break; 501 502 case FF_FETCH: 503 294 arg = *fpc++; 504 294 f += arg; 505 294 fieldsize = arg; 506 507 294 if (MARK < SP) 508 290 sv = *++MARK; 509 else { 510 4 sv = &PL_sv_no; 511 4 if (ckWARN(WARN_SYNTAX)) 512 1 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments"); 513 } 514 1 break; 515 516 case FF_CHECKNL: 517 { 518 107 const char *send; 519 107 const char *s = item = SvPV_const(sv, len); 520 107 itemsize = len; 521 107 if (DO_UTF8(sv)) { 522 2 itemsize = sv_len_utf8(sv); 523 2 if (itemsize != (I32)len) { 524 2 I32 itembytes; 525 2 if (itemsize > fieldsize) { 526 ###### itemsize = fieldsize; 527 ###### itembytes = itemsize; 528 ###### sv_pos_u2b(sv, &itembytes, 0); 529 } 530 else 531 2 itembytes = len; 532 2 send = chophere = s + itembytes; 533 6 while (s < send) { 534 4 if (*s & ~31) 535 4 gotsome = TRUE; 536 ###### else if (*s == '\n') 537 ###### break; 538 4 s++; 539 } 540 2 item_is_utf8 = TRUE; 541 2 itemsize = s - item; 542 2 sv_pos_b2u(sv, &itemsize); 543 2 break; 544 } 545 } 546 105 item_is_utf8 = FALSE; 547 105 if (itemsize > fieldsize) 548 9 itemsize = fieldsize; 549 105 send = chophere = s + itemsize; 550 378 while (s < send) { 551 276 if (*s & ~31) 552 273 gotsome = TRUE; 553 3 else if (*s == '\n') 554 3 break; 555 273 s++; 556 } 557 105 itemsize = s - item; 558 105 break; 559 } 560 561 case FF_CHECKCHOP: 562 { 563 137 const char *s = item = SvPV_const(sv, len); 564 137 itemsize = len; 565 137 if (DO_UTF8(sv)) { 566 ###### itemsize = sv_len_utf8(sv); 567 ###### if (itemsize != (I32)len) { 568 ###### I32 itembytes; 569 ###### if (itemsize <= fieldsize) { 570 ###### const char *send = chophere = s + itemsize; 571 ###### while (s < send) { 572 ###### if (*s == '\r') { 573 ###### itemsize = s - item; 574 ###### chophere = s; 575 ###### break; 576 } 577 ###### if (*s++ & ~31) 578 ###### gotsome = TRUE; 579 } 580 } 581 else { 582 ###### const char *send; 583 ###### itemsize = fieldsize; 584 ###### itembytes = itemsize; 585 ###### sv_pos_u2b(sv, &itembytes, 0); 586 ###### send = chophere = s + itembytes; 587 ###### while (s < send || (s == send && isSPACE(*s))) { 588 ###### if (isSPACE(*s)) { 589 ###### if (chopspace) 590 ###### chophere = s; 591 ###### if (*s == '\r') 592 ###### break; 593 } 594 else { 595 ###### if (*s & ~31) 596 ###### gotsome = TRUE; 597 ###### if (strchr(PL_chopset, *s)) 598 ###### chophere = s + 1; 599 } 600 ###### s++; 601 } 602 ###### itemsize = chophere - item; 603 ###### sv_pos_b2u(sv, &itemsize); 604 } 605 ###### item_is_utf8 = TRUE; 606 ###### break; 607 } 608 } 609 137 item_is_utf8 = FALSE; 610 137 if (itemsize <= fieldsize) { 611 93 const char *const send = chophere = s + itemsize; 612 1442 while (s < send) { 613 1350 if (*s == '\r') { 614 1 itemsize = s - item; 615 1 chophere = s; 616 1 break; 617 } 618 1349 if (*s++ & ~31) 619 1349 gotsome = TRUE; 620 } 621 } 622 else { 623 44 const char *send; 624 44 itemsize = fieldsize; 625 44 send = chophere = s + itemsize; 626 1693 while (s < send || (s == send && isSPACE(*s))) { 627 1649 if (isSPACE(*s)) { 628 205 if (chopspace) 629 205 chophere = s; 630 205 if (*s == '\r') 631 ###### break; 632 } 633 else { 634 1444 if (*s & ~31) 635 1444 gotsome = TRUE; 636 1444 if (strchr(PL_chopset, *s)) 637 6 chophere = s + 1; 638 } 639 1649 s++; 640 } 641 44 itemsize = chophere - item; 642 } 643 44 break; 644 } 645 646 case FF_SPACE: 647 68 arg = fieldsize - itemsize; 648 68 if (arg) { 649 47 fieldsize -= arg; 650 200 while (arg-- > 0) 651 153 *t++ = ' '; 652 } 653 5 break; 654 655 case FF_HALFSPACE: 656 5 arg = fieldsize - itemsize; 657 5 if (arg) { 658 5 arg /= 2; 659 5 fieldsize -= arg; 660 8 while (arg-- > 0) 661 3 *t++ = ' '; 662 } 663 244 break; 664 665 case FF_ITEM: 666 { 667 244 const char *s = item; 668 244 arg = itemsize; 669 244 if (item_is_utf8) { 670 2 if (!targ_is_utf8) { 671 1 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); 672 1 *t = '\0'; 673 1 sv_utf8_upgrade(PL_formtarget); 674 1 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1); 675 1 t = SvEND(PL_formtarget); 676 1 targ_is_utf8 = TRUE; 677 } 678 4 while (arg--) { 679 2 if (UTF8_IS_CONTINUED(*s)) { 680 2 STRLEN skip = UTF8SKIP(s); 681 2 switch (skip) { 682 default: 683 ###### Move(s,t,skip,char); 684 ###### s += skip; 685 ###### t += skip; 686 ###### break; 687 ###### case 7: *t++ = *s++; 688 ###### case 6: *t++ = *s++; 689 ###### case 5: *t++ = *s++; 690 ###### case 4: *t++ = *s++; 691 ###### case 3: *t++ = *s++; 692 2 case 2: *t++ = *s++; 693 2 case 1: *t++ = *s++; 694 } 695 } 696 else { 697 ###### if ( !((*t++ = *s++) & ~31) ) 698 ###### t[-1] = ' '; 699 } 700 } 701 242 break; 702 } 703 242 if (targ_is_utf8 && !item_is_utf8) { 704 6 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); 705 6 *t = '\0'; 706 6 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv); 707 30 for (; t < SvEND(PL_formtarget); t++) { 708 #ifdef EBCDIC 709 const int ch = *t; 710 if (iscntrl(ch)) 711 #else 712 12 if (!(*t & ~31)) 713 #endif 714 ###### *t = ' '; 715 } 716 236 break; 717 } 718 3367 while (arg--) { 719 #ifdef EBCDIC 720 const int ch = *t++ = *s++; 721 if (iscntrl(ch)) 722 #else 723 3131 if ( !((*t++ = *s++) & ~31) ) 724 #endif 725 ###### t[-1] = ' '; 726 } 727 137 break; 728 } 729 730 case FF_CHOP: 731 { 732 137 const char *s = chophere; 733 137 if (chopspace) { 734 183 while (*s && isSPACE(*s)) 735 46 s++; 736 } 737 137 sv_chop(sv,s); 738 137 SvSETMAGIC(sv); 739 2 break; 740 } 741 742 case FF_LINESNGL: 743 ###### chopspace = 0; 744 ###### oneline = TRUE; 745 ###### goto ff_line; 746 case FF_LINEGLOB: 747 16 oneline = FALSE; 748 ff_line: 749 { 750 16 const char *s = item = SvPV_const(sv, len); 751 16 itemsize = len; 752 16 if ((item_is_utf8 = DO_UTF8(sv))) 753 1 itemsize = sv_len_utf8(sv); 754 16 if (itemsize) { 755 11 bool chopped = FALSE; 756 11 const char *const send = s + len; 757 11 gotsome = TRUE; 758 11 chophere = s + itemsize; 759 166 while (s < send) { 760 155 if (*s++ == '\n') { 761 23 if (oneline) { 762 ###### chopped = TRUE; 763 ###### chophere = s; 764 ###### break; 765 } else { 766 23 if (s == send) { 767 11 itemsize--; 768 11 chopped = TRUE; 769 } else 770 12 lines++; 771 } 772 } 773 } 774 11 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); 775 11 if (targ_is_utf8) 776 2 SvUTF8_on(PL_formtarget); 777 11 if (oneline) { 778 ###### SvCUR_set(sv, chophere - item); 779 ###### sv_catsv(PL_formtarget, sv); 780 ###### SvCUR_set(sv, itemsize); 781 } else 782 11 sv_catsv(PL_formtarget, sv); 783 11 if (chopped) 784 11 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1); 785 11 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1); 786 11 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget); 787 11 if (item_is_utf8) 788 1 targ_is_utf8 = TRUE; 789 } 790 1 break; 791 } 792 793 case FF_0DECIMAL: 794 14 arg = *fpc++; 795 #if defined(USE_LONG_DOUBLE) 796 fmt = (arg & 256) ? "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl; 797 #else 798 14 fmt = (arg & 256) ? "%#0*.*f" : "%0*.*f"; 799 #endif 800 14 goto ff_dec; 801 case FF_DECIMAL: 802 20 arg = *fpc++; 803 #if defined(USE_LONG_DOUBLE) 804 fmt = (arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl; 805 #else 806 20 fmt = (arg & 256) ? "%#*.*f" : "%*.*f"; 807 #endif 808 ff_dec: 809 /* If the field is marked with ^ and the value is undefined, 810 blank it out. */ 811 34 if ((arg & 512) && !SvOK(sv)) { 812 2 arg = fieldsize; 813 10 while (arg--) 814 8 *t++ = ' '; 815 32 break; 816 } 817 32 gotsome = TRUE; 818 32 value = SvNV(sv); 819 /* overflow evidence */ 820 32 if (num_overflow(value, fieldsize, arg)) { 821 10 arg = fieldsize; 822 56 while (arg--) 823 46 *t++ = '#'; 824 22 break; 825 } 826 /* Formats aren't yet marked for locales, so assume "yes". */ 827 { 828 22 STORE_NUMERIC_STANDARD_SET_LOCAL(); 829 22 sprintf(t, fmt, (int) fieldsize, (int) arg & 255, value); 830 22 RESTORE_NUMERIC_STANDARD(); 831 } 832 22 t += fieldsize; 833 22 break; 834 835 case FF_NEWLINE: 836 299 f++; 837 545 while (t-- > linemark && *t == ' ') ; 838 299 t++; 839 299 *t++ = '\n'; 840 299 break; 841 842 case FF_BLANK: 843 133 arg = *fpc++; 844 133 if (gotsome) { 845 80 if (arg) { /* repeat until fields exhausted? */ 846 75 *t = '\0'; 847 75 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); 848 75 lines += FmLINES(PL_formtarget); 849 75 if (lines == 200) { 850 ###### arg = t - linemark; 851 ###### if (strnEQ(linemark, linemark - arg, arg)) 852 ###### DIE(aTHX_ "Runaway format"); 853 } 854 75 if (targ_is_utf8) 855 ###### SvUTF8_on(PL_formtarget); 856 75 FmLINES(PL_formtarget) = lines; 857 75 SP = ORIGMARK; 858 75 RETURNOP(cLISTOP->op_first); 859 } 860 } 861 else { 862 53 t = linemark; 863 53 lines--; 864 } 865 53 break; 866 867 case FF_MORE: 868 { 869 2 const char *s = chophere; 870 2 const char *send = item + len; 871 2 if (chopspace) { 872 6 while (*s && isSPACE(*s) && s < send) 873 4 s++; 874 } 875 2 if (s < send) { 876 1 char *s1; 877 1 arg = fieldsize - itemsize; 878 1 if (arg) { 879 1 fieldsize -= arg; 880 3 while (arg-- > 0) 881 2 *t++ = ' '; 882 } 883 1 s1 = t - 3; 884 1 if (strnEQ(s1," ",3)) { 885 ###### while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1])) 886 ###### s1--; 887 } 888 1 *s1++ = '.'; 889 1 *s1++ = '.'; 890 1 *s1++ = '.'; 891 } 892 1 break; 893 } 894 case FF_END: 895 249 *t = '\0'; 896 249 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); 897 249 if (targ_is_utf8) 898 12 SvUTF8_on(PL_formtarget); 899 249 FmLINES(PL_formtarget) += lines; 900 249 SP = ORIGMARK; 901 249 RETPUSHYES; 902 } 903 } 904 } 905 906 PP(pp_grepstart) 907 971296 { 908 971296 dVAR; dSP; 909 971296 SV *src; 910 911 971296 if (PL_stack_base + *PL_markstack_ptr == SP) { 912 12364 (void)POPMARK; 913 12364 if (GIMME_V == G_SCALAR) 914 379 XPUSHs(sv_2mortal(newSViv(0))); 915 12364 RETURNOP(PL_op->op_next->op_next); 916 } 917 958932 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1; 918 958932 pp_pushmark(); /* push dst */ 919 958932 pp_pushmark(); /* push src */ 920 958932 ENTER; /* enter outer scope */ 921 922 958932 SAVETMPS; 923 958932 if (PL_op->op_private & OPpGREP_LEX) 924 6 SAVESPTR(PAD_SVl(PL_op->op_targ)); 925 else 926 958926 SAVE_DEFSV; 927 958932 ENTER; /* enter inner scope */ 928 958932 SAVEVPTR(PL_curpm); 929 930 958932 src = PL_stack_base[*PL_markstack_ptr]; 931 958932 SvTEMP_off(src); 932 958932 if (PL_op->op_private & OPpGREP_LEX) 933 6 PAD_SVl(PL_op->op_targ) = src; 934 else 935 958926 DEFSV = src; 936 937 958932 PUTBACK; 938 958932 if (PL_op->op_type == OP_MAPSTART) 939 912577 pp_pushmark(); /* push top */ 940 958932 return ((LOGOP*)PL_op->op_next)->op_other; 941 } 942 943 PP(pp_mapstart) 944 ###### { 945 ###### DIE(aTHX_ "panic: mapstart"); /* uses grepstart */ 946 } 947 948 PP(pp_mapwhile) 949 2545081 { 950 2545081 dVAR; dSP; 951 2545081 const I32 gimme = GIMME_V; 952 2545081 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */ 953 2545081 I32 count; 954 2545081 I32 shift; 955 2545081 SV** src; 956 2545081 SV** dst; 957 958 /* first, move source pointer to the next item in the source list */ 959 2545081 ++PL_markstack_ptr[-1]; 960 961 /* if there are new items, push them into the destination list */ 962 2545081 if (items && gimme != G_VOID) { 963 /* might need to make room back there first */ 964 2541407 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) { 965 /* XXX this implementation is very pessimal because the stack 966 * is repeatedly extended for every set of items. Is possible 967 * to do this without any stack extension or copying at all 968 * by maintaining a separate list over which the map iterates 969 * (like foreach does). --gsar */ 970 971 /* everything in the stack after the destination list moves 972 * towards the end the stack by the amount of room needed */ 973 8327 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]); 974 975 /* items to shift up (accounting for the moved source pointer) */ 976 8327 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1); 977 978 /* This optimization is by Ben Tilly and it does 979 * things differently from what Sarathy (gsar) 980 * is describing. The downside of this optimization is 981 * that leaves "holes" (uninitialized and hopefully unused areas) 982 * to the Perl stack, but on the other hand this 983 * shouldn't be a problem. If Sarathy's idea gets 984 * implemented, this optimization should become 985 * irrelevant. --jhi */ 986 8327 if (shift < count) 987 8327 shift = count; /* Avoid shifting too often --Ben Tilly */ 988 989 8327 EXTEND(SP,shift); 990 8327 src = SP; 991 8327 dst = (SP += shift); 992 8327 PL_markstack_ptr[-1] += shift; 993 8327 *PL_markstack_ptr += shift; 994 87478 while (count--) 995 79151 *dst-- = *src--; 996 } 997 /* copy the new items down to the destination list */ 998 2541407 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1; 999 2541407 if (gimme == G_ARRAY) { 1000 5152121 while (items-- > 0) 1001 2611126 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs); 1002 } 1003 else { 1004 /* scalar context: we don't care about which values map returns 1005 * (we use undef here). And so we certainly don't want to do mortal 1006 * copies of meaningless values. */ 1007 834 while (items-- > 0) { 1008 422 (void)POPs; 1009 422 *dst-- = &PL_sv_undef; 1010 } 1011 } 1012 } 1013 2545081 LEAVE; /* exit inner scope */ 1014 1015 /* All done yet? */ 1016 2545081 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) { 1017 1018 912560 (void)POPMARK; /* pop top */ 1019 912560 LEAVE; /* exit outer scope */ 1020 912560 (void)POPMARK; /* pop src */ 1021 912560 items = --*PL_markstack_ptr - PL_markstack_ptr[-1]; 1022 912560 (void)POPMARK; /* pop dst */ 1023 912560 SP = PL_stack_base + POPMARK; /* pop original mark */ 1024 912560 if (gimme == G_SCALAR) { 1025 53 if (PL_op->op_private & OPpGREP_LEX) { 1026 1 SV* sv = sv_newmortal(); 1027 1 sv_setiv(sv, items); 1028 1 PUSHs(sv); 1029 } 1030 else { 1031 52 dTARGET; 1032 52 XPUSHi(items); 1033 } 1034 } 1035 912507 else if (gimme == G_ARRAY) 1036 912378 SP += items; 1037 912560 RETURN; 1038 } 1039 else { 1040 1632521 SV *src; 1041 1042 1632521 ENTER; /* enter inner scope */ 1043 1632521 SAVEVPTR(PL_curpm); 1044 1045 /* set $_ to the new source item */ 1046 1632521 src = PL_stack_base[PL_markstack_ptr[-1]]; 1047 1632521 SvTEMP_off(src); 1048 1632521 if (PL_op->op_private & OPpGREP_LEX) 1049 3 PAD_SVl(PL_op->op_targ) = src; 1050 else 1051 1632518 DEFSV = src; 1052 1053 1632521 RETURNOP(cLOGOP->op_other); 1054 } 1055 } 1056 1057 /* Range stuff. */ 1058 1059 PP(pp_range) 1060 8510 { 1061 8510 if (GIMME == G_ARRAY) 1062 8053 return NORMAL; 1063 457 if (SvTRUEx(PAD_SV(PL_op->op_targ))) 1064 102 return cLOGOP->op_other; 1065 else 1066 355 return NORMAL; 1067 } 1068 1069 PP(pp_flip) 1070 8408 { 1071 8408 dSP; 1072 1073 8408 if (GIMME == G_ARRAY) { 1074 8053 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other); 1075 } 1076 else { 1077 355 dTOPss; 1078 355 SV *targ = PAD_SV(PL_op->op_targ); 1079 355 int flip = 0; 1080 1081 355 if (PL_op->op_private & OPpFLIP_LINENUM) { 1082 283 if (GvIO(PL_last_in_gv)) { 1083 277 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)); 1084 } 1085 else { 1086 6 GV *gv = gv_fetchpv(".", TRUE, SVt_PV); 1087 6 if (gv && GvSV(gv)) flip = SvIV(sv) == SvIV(GvSV(gv)); 1088 } 1089 } else { 1090 72 flip = SvTRUE(sv); 1091 } 1092 355 if (flip) { 1093 36 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1); 1094 36 if (PL_op->op_flags & OPf_SPECIAL) { 1095 11 sv_setiv(targ, 1); 1096 11 SETs(targ); 1097 11 RETURN; 1098 } 1099 else { 1100 25 sv_setiv(targ, 0); 1101 25 SP--; 1102 25 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other); 1103 } 1104 } 1105 319 sv_setpvn(TARG, "", 0); 1106 319 SETs(targ); 1107 319 RETURN; 1108 } 1109 } 1110 1111 /* This code tries to decide if "$left .. $right" should use the 1112 magical string increment, or if the range is numeric (we make 1113 an exception for .."0" [#18165]). AMS 20021031. */ 1114 1115 #define RANGE_IS_NUMERIC(left,right) ( \ 1116 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \ 1117 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \ 1118 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \ 1119 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \ 1120 && (!SvOK(right) || looks_like_number(right)))) 1121 1122 PP(pp_flop) 1123 8180 { 1124 8180 dSP; 1125 1126 8180 if (GIMME == G_ARRAY) { 1127 8053 dPOPPOPssrl; 1128 1129 8053 if (SvGMAGICAL(left)) 1130 1 mg_get(left); 1131 8053 if (SvGMAGICAL(right)) 1132 294 mg_get(right); 1133 1134 8053 if (RANGE_IS_NUMERIC(left,right)) { 1135 8004 register IV i, j; 1136 8004 IV max; 1137 8004 if ((SvOK(left) && SvNV(left) < IV_MIN) || 1138 (SvOK(right) && SvNV(right) > IV_MAX)) 1139 ###### DIE(aTHX_ "Range iterator outside integer range"); 1140 8004 i = SvIV(left); 1141 8004 max = SvIV(right); 1142 8004 if (max >= i) { 1143 7904 j = max - i + 1; 1144 7904 EXTEND_MORTAL(j); 1145 7904 EXTEND(SP, j); 1146 } 1147 else 1148 100 j = 0; 1149 768868 while (j--) { 1150 760864 SV * const sv = sv_2mortal(newSViv(i++)); 1151 760864 PUSHs(sv); 1152 } 1153 } 1154 else { 1155 49 SV *final = sv_mortalcopy(right); 1156 49 STRLEN len; 1157 49 const char *tmps = SvPV_const(final, len); 1158 1159 49 SV *sv = sv_mortalcopy(left); 1160 49 SvPV_force_nolen(sv); 1161 19571 while (!SvNIOKp(sv) && SvCUR(sv) <= len) { 1162 19566 XPUSHs(sv); 1163 19566 if (strEQ(SvPVX_const(sv),tmps)) 1164 44 break; 1165 19522 sv = sv_2mortal(newSVsv(sv)); 1166 19522 sv_inc(sv); 1167 } 1168 } 1169 } 1170 else { 1171 127 dTOPss; 1172 127 SV * const targ = PAD_SV(cUNOP->op_first->op_targ); 1173 127 int flop = 0; 1174 127 sv_inc(targ); 1175 1176 127 if (PL_op->op_private & OPpFLIP_LINENUM) { 1177 47 if (GvIO(PL_last_in_gv)) { 1178 43 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)); 1179 } 1180 else { 1181 4 GV * const gv = gv_fetchpv(".", TRUE, SVt_PV); 1182 4 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv)); 1183 } 1184 } 1185 else { 1186 80 flop = SvTRUE(sv); 1187 } 1188 1189 127 if (flop) { 1190 30 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0); 1191 30 sv_catpvn(targ, "E0", 2); 1192 } 1193 127 SETs(targ); 1194 } 1195 1196 8180 RETURN; 1197 } 1198 1199 /* Control. */ 1200 1201 static const char * const context_name[] = { 1202 "pseudo-block", 1203 "subroutine", 1204 "eval", 1205 "loop", 1206 "substitution", 1207 "block", 1208 "format" 1209 }; 1210 1211 STATIC I32 1212 S_dopoptolabel(pTHX_ const char *label) 1213 32951 { 1214 32951 register I32 i; 1215 1216 97165 for (i = cxstack_ix; i >= 0; i--) { 1217 97165 register const PERL_CONTEXT * const cx = &cxstack[i]; 1218 97165 switch (CxTYPE(cx)) { 1219 case CXt_SUBST: 1220 case CXt_SUB: 1221 case CXt_FORMAT: 1222 case CXt_EVAL: 1223 case CXt_NULL: 1224 232 if (ckWARN(WARN_EXITING)) 1225 4 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s", 1226 context_name[CxTYPE(cx)], OP_NAME(PL_op)); 1227 232 if (CxTYPE(cx) == CXt_NULL) 1228 2 return -1; 1229 58514 break; 1230 case CXt_LOOP: 1231 58514 if ( !cx->blk_loop.label || strNE(label, cx->blk_loop.label) ) { 1232 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n", 1233 25565 (long)i, cx->blk_loop.label)); 1234 ###### continue; 1235 } 1236 32949 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label)); 1237 32949 return i; 1238 } 1239 } 1240 ###### return i; 1241 } 1242 1243 I32 1244 Perl_dowantarray(pTHX) 1245 68917 { 1246 68917 const I32 gimme = block_gimme(); 1247 68917 return (gimme == G_VOID) ? G_SCALAR : gimme; 1248 } 1249 1250 I32 1251 Perl_block_gimme(pTHX) 1252 1810414 { 1253 1810414 const I32 cxix = dopoptosub(cxstack_ix); 1254 1810414 if (cxix < 0) 1255 562 return G_VOID; 1256 1257 1809852 switch (cxstack[cxix].blk_gimme) { 1258 case G_VOID: 1259 1074740 return G_VOID; 1260 case G_SCALAR: 1261 434043 return G_SCALAR; 1262 case G_ARRAY: 1263 301069 return G_ARRAY; 1264 default: 1265 ###### Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme); 1266 /* NOTREACHED */ 1267 1810414 return 0; 1268 } 1269 } 1270 1271 I32 1272 Perl_is_lvalue_sub(pTHX) 1273 34 { 1274 34 const I32 cxix = dopoptosub(cxstack_ix); 1275 34 assert(cxix >= 0); /* We should only be called from inside subs */ 1276 1277 34 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv)) 1278 30 return cxstack[cxix].blk_sub.lval; 1279 else 1280 4 return 0; 1281 } 1282 1283 STATIC I32 1284 S_dopoptosub(pTHX_ I32 startingblock) 1285 11039132 { 1286 11039132 return dopoptosub_at(cxstack, startingblock); 1287 } 1288 1289 STATIC I32 1290 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock) 1291 11312131 { 1292 11312131 I32 i; 1293 12994953 for (i = startingblock; i >= 0; i--) { 1294 12943586 register const PERL_CONTEXT * const cx = &cxstk[i]; 1295 12943586 switch (CxTYPE(cx)) { 1296 default: 1297 1682822 continue; 1298 case CXt_EVAL: 1299 case CXt_SUB: 1300 case CXt_FORMAT: 1301 11260764 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i)); 1302 11260764 return i; 1303 } 1304 } 1305 51367 return i; 1306 } 1307 1308 STATIC I32 1309 S_dopoptoeval(pTHX_ I32 startingblock) 1310 4424 { 1311 4424 I32 i; 1312 7890 for (i = startingblock; i >= 0; i--) { 1313 7811 register const PERL_CONTEXT *cx = &cxstack[i]; 1314 7811 switch (CxTYPE(cx)) { 1315 default: 1316 3466 continue; 1317 case CXt_EVAL: 1318 4345 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i)); 1319 4345 return i; 1320 } 1321 } 1322 79 return i; 1323 } 1324 1325 STATIC I32 1326 S_dopoptoloop(pTHX_ I32 startingblock) 1327 520330 { 1328 520330 I32 i; 1329 689638 for (i = startingblock; i >= 0; i--) { 1330 689635 register const PERL_CONTEXT * const cx = &cxstack[i]; 1331 689635 switch (CxTYPE(cx)) { 1332 case CXt_SUBST: 1333 case CXt_SUB: 1334 case CXt_FORMAT: 1335 case CXt_EVAL: 1336 case CXt_NULL: 1337 13 if (ckWARN(WARN_EXITING)) 1338 4 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s", 1339 context_name[CxTYPE(cx)], OP_NAME(PL_op)); 1340 13 if ((CxTYPE(cx)) == CXt_NULL) 1341 2 return -1; 1342 520325 break; 1343 case CXt_LOOP: 1344 520325 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i)); 1345 520325 return i; 1346 } 1347 } 1348 3 return i; 1349 } 1350 1351 void 1352 Perl_dounwind(pTHX_ I32 cxix) 1353 913660 { 1354 913660 I32 optype; 1355 1356 2422168 while (cxstack_ix > cxix) { 1357 1508508 SV *sv; 1358 1508508 register PERL_CONTEXT *cx = &cxstack[cxstack_ix]; 1359 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n", 1360 1508508 (long) cxstack_ix, PL_block_type[CxTYPE(cx)])); 1361 /* Note: we don't need to restore the base context info till the end. */ 1362 1508508 switch (CxTYPE(cx)) { 1363 case CXt_SUBST: 1364 2 POPSUBST(cx); 1365 2 continue; /* not break */ 1366 case CXt_SUB: 1367 3314 POPSUB(cx,sv); 1368 3314 LEAVESUB(sv); 1369 ###### break; 1370 case CXt_EVAL: 1371 10 POPEVAL(cx); 1372 ###### break; 1373 case CXt_LOOP: 1374 561215 POPLOOP(cx); 1375 ###### break; 1376 case CXt_NULL: 1377 1 break; 1378 case CXt_FORMAT: 1379 1 POPFORMAT(cx); 1380 break; 1381 } 1382 1508506 cxstack_ix--; 1383 } 1384 913660 PERL_UNUSED_VAR(optype); 1385 } 1386 1387 void 1388 Perl_qerror(pTHX_ SV *err) 1389 285 { 1390 285 if (PL_in_eval) 1391 232 sv_catsv(ERRSV, err); 1392 53 else if (PL_errors) 1393 53 sv_catsv(PL_errors, err); 1394 else 1395 ###### Perl_warn(aTHX_ "%"SVf, err); 1396 285 ++PL_error_count; 1397 } 1398 1399 OP * 1400 Perl_die_where(pTHX_ const char *message, STRLEN msglen) 1401 4411 { 1402 dVAR; 1403 1404 4411 if (PL_in_eval) { 1405 4345 I32 cxix; 1406 4345 I32 gimme; 1407 1408 4345 if (message) { 1409 4336 if (PL_in_eval & EVAL_KEEPERR) { 1410 73 static const char prefix[] = "\t(in cleanup) "; 1411 73 SV *err = ERRSV; 1412 73 const char *e = Nullch; 1413 73 if (!SvPOK(err)) 1414 ###### sv_setpvn(err,"",0); 1415 73 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) { 1416 39 STRLEN len; 1417 39 e = SvPV_const(err, len); 1418 39 e += len - msglen; 1419 39 if (*e != *message || strNE(e,message)) 1420 3 e = Nullch; 1421 } 1422 73 if (!e) { 1423 37 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen); 1424 37 sv_catpvn(err, prefix, sizeof(prefix)-1); 1425 37 sv_catpvn(err, message, msglen); 1426 37 if (ckWARN(WARN_MISC)) { 1427 2 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1; 1428 2 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start); 1429 } 1430 } 1431 } 1432 else { 1433 4263 sv_setpvn(ERRSV, message, msglen); 1434 } 1435 } 1436 1437 4424 while ((cxix = dopoptoeval(cxstack_ix)) < 0 1438 && PL_curstackinfo->si_prev) 1439 { 1440 79 dounwind(-1); 1441 79 POPSTACK; 1442 } 1443 1444 4345 if (cxix >= 0) { 1445 4345 I32 optype; 1446 4345 register PERL_CONTEXT *cx; 1447 4345 SV **newsp; 1448 1449 4345 if (cxix < cxstack_ix) 1450 1189 dounwind(cxix); 1451 1452 4345 POPBLOCK(cx,PL_curpm); 1453 4345 if (CxTYPE(cx) != CXt_EVAL) { 1454 ###### if (!message) 1455 ###### message = SvPVx_const(ERRSV, msglen); 1456 ###### PerlIO_write(Perl_error_log, "panic: die ", 11); 1457 ###### PerlIO_write(Perl_error_log, message, msglen); 1458 ###### my_exit(1); 1459 } 1460 4345 POPEVAL(cx); 1461 1462 4345 if (gimme == G_SCALAR) 1463 2559 *++newsp = &PL_sv_undef; 1464 4345 PL_stack_sp = newsp; 1465 1466 4345 LEAVE; 1467 1468 /* LEAVE could clobber PL_curcop (see save_re_context()) 1469 * XXX it might be better to find a way to avoid messing with 1470 * PL_curcop in save_re_context() instead, but this is a more 1471 * minimal fix --GSAR */ 1472 4345 PL_curcop = cx->blk_oldcop; 1473 1474 4345 if (optype == OP_REQUIRE) { 1475 25 const char* msg = SvPVx_nolen_const(ERRSV); 1476 25 SV * const nsv = cx->blk_eval.old_namesv; 1477 25 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), 1478 &PL_sv_undef, 0); 1479 25 DIE(aTHX_ "%sCompilation failed in require", 1480 *msg ? msg : "Unknown error\n"); 1481 } 1482 4320 assert(CxTYPE(cx) == CXt_EVAL); 1483 4320 return cx->blk_eval.retop; 1484 } 1485 } 1486 66 if (!message) 1487 1 message = SvPVx_const(ERRSV, msglen); 1488 1489 66 write_to_stderr(message, msglen); 1490 66 my_failure_exit(); 1491 /* NOTREACHED */ 1492 4320 return 0; 1493 } 1494 1495 PP(pp_xor) 1496 55167 { 1497 55167 dSP; dPOPTOPssrl; 1498 55167 if (SvTRUE(left) != SvTRUE(right)) 1499 47418 RETSETYES; 1500 else 1501 7749 RETSETNO; 1502 } 1503 1504 PP(pp_andassign) 1505 99 { 1506 99 dSP; 1507 99 if (!SvTRUE(TOPs)) 1508 5 RETURN; 1509 else 1510 94 RETURNOP(cLOGOP->op_other); 1511 } 1512 1513 PP(pp_orassign) 1514 2534049 { 1515 2534049 dSP; 1516 2534049 if (SvTRUE(TOPs)) 1517 1377882 RETURN; 1518 else 1519 1156167 RETURNOP(cLOGOP->op_other); 1520 } 1521 1522 PP(pp_dorassign) 1523 9 { 1524 9 dSP; 1525 9 register SV* sv; 1526 1527 9 sv = TOPs; 1528 9 if (!sv || !SvANY(sv)) { 1529 1 RETURNOP(cLOGOP->op_other); 1530 } 1531 1532 8 switch (SvTYPE(sv)) { 1533 case SVt_PVAV: 1534 ###### if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied))) 1535 ###### RETURN; 1536 ###### break; 1537 case SVt_PVHV: 1538 ###### if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied))) 1539 ###### RETURN; 1540 ###### break; 1541 case SVt_PVCV: 1542 ###### if (CvROOT(sv) || CvXSUB(sv)) 1543 ###### RETURN; 1544 8 break; 1545 default: 1546 8 if (SvGMAGICAL(sv)) 1547 ###### mg_get(sv); 1548 8 if (SvOK(sv)) 1549 4 RETURN; 1550 } 1551 1552 4 RETURNOP(cLOGOP->op_other); 1553 } 1554 1555 PP(pp_caller) 1556 127723 { 1557 127723 dSP; 1558 127723 register I32 cxix = dopoptosub(cxstack_ix); 1559 127723 register const PERL_CONTEXT *cx; 1560 127723 register const PERL_CONTEXT *ccstack = cxstack; 1561 127723 const PERL_SI *top_si = PL_curstackinfo; 1562 127723 I32 gimme; 1563 127723 const char *stashname; 1564 127723 I32 count = 0; 1565 1566 127723 if (MAXARG) 1567 112458 count = POPi; 1568 1569 420104 for (;;) { 1570 /* we may be in a higher stacklevel, so dig down deeper */ 1571 276856 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) { 1572 5885 top_si = top_si->si_prev; 1573 5885 ccstack = top_si->si_cxstack; 1574 5885 cxix = dopoptosub_at(ccstack, top_si->si_cxix); 1575 } 1576 270971 if (cxix < 0) { 1577 1298 if (GIMME != G_ARRAY) { 1578 57 EXTEND(SP, 1); 1579 57 RETPUSHUNDEF; 1580 } 1581 1241 RETURN; 1582 } 1583 /* caller() should not report the automatic calls to &DB::sub */ 1584 269673 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 && 1585 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub)) 1586 ###### count++; 1587 269673 if (!count--) 1588 126425 break; 1589 143248 cxix = dopoptosub_at(ccstack, cxix - 1); 1590 } 1591 1592 126425 cx = &ccstack[cxix]; 1593 126425 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { 1594 123866 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1); 1595 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the 1596 field below is defined for any cx. */ 1597 /* caller() should not report the automatic calls to &DB::sub */ 1598 123866 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) 1599 ###### cx = &ccstack[dbcxix]; 1600 } 1601 1602 126425 stashname = CopSTASHPV(cx->blk_oldcop); 1603 126425 if (GIMME != G_ARRAY) { 1604 39300 EXTEND(SP, 1); 1605 39300 if (!stashname) 1606 ###### PUSHs(&PL_sv_undef); 1607 else { 1608 39300 dTARGET; 1609 39300 sv_setpv(TARG, stashname); 1610 39300 PUSHs(TARG); 1611 } 1612 39300 RETURN; 1613 } 1614 1615 87125 EXTEND(SP, 10); 1616 1617 87125 if (!stashname) 1618 ###### PUSHs(&PL_sv_undef); 1619 else 1620 87125 PUSHs(sv_2mortal(newSVpv(stashname, 0))); 1621 87125 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0))); 1622 87125 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop)))); 1623 87125 if (!MAXARG) 1624 2534 RETURN; 1625 84591 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { 1626 82697 GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv); 1627 /* So is ccstack[dbcxix]. */ 1628 82697 if (isGV(cvgv)) { 1629 82695 SV * const sv = NEWSV(49, 0); 1630 82695 gv_efullname3(sv, cvgv, Nullch); 1631 82695 PUSHs(sv_2mortal(sv)); 1632 82695 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs))); 1633 } 1634 else { 1635 2 PUSHs(sv_2mortal(newSVpvn("(unknown)",9))); 1636 2 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs))); 1637 } 1638 } 1639 else { 1640 1894 PUSHs(sv_2mortal(newSVpvn("(eval)",6))); 1641 1894 PUSHs(sv_2mortal(newSViv(0))); 1642 } 1643 84591 gimme = (I32)cx->blk_gimme; 1644 84591 if (gimme == G_VOID) 1645 54477 PUSHs(&PL_sv_undef); 1646 else 1647 30114 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY))); 1648 84591 if (CxTYPE(cx) == CXt_EVAL) { 1649 /* eval STRING */ 1650 1894 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) { 1651 431 PUSHs(cx->blk_eval.cur_text); 1652 431 PUSHs(&PL_sv_no); 1653 } 1654 /* require */ 1655 1463 else if (cx->blk_eval.old_namesv) { 1656 294 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv))); 1657 294 PUSHs(&PL_sv_yes); 1658 } 1659 /* eval BLOCK (try blocks have old_namesv == 0) */ 1660 else { 1661 1169 PUSHs(&PL_sv_undef); 1662 1169 PUSHs(&PL_sv_undef); 1663 } 1664 } 1665 else { 1666 82697 PUSHs(&PL_sv_undef); 1667 82697 PUSHs(&PL_sv_undef); 1668 } 1669 84591 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs 1670 && CopSTASH_eq(PL_curcop, PL_debstash)) 1671 { 1672 844 AV * const ary = cx->blk_sub.argarray; 1673 844 const int off = AvARRAY(ary) - AvALLOC(ary); 1674 1675 844 if (!PL_dbargs) { 1676 190 GV* tmpgv; 1677 190 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE, 1678 SVt_PVAV))); 1679 190 GvMULTI_on(tmpgv); 1680 190 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */ 1681 } 1682 1683 844 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off) 1684 226 av_extend(PL_dbargs, AvFILLp(ary) + off); 1685 844 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*); 1686 844 AvFILLp(PL_dbargs) = AvFILLp(ary) + off; 1687 } 1688 /* XXX only hints propagated via op_private are currently 1689 * visible (others are not easily accessible, since they 1690 * use the global PL_hints) */ 1691 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private & 1692 84591 HINT_PRIVATE_MASK))); 1693 { 1694 84591 SV * mask ; 1695 84591 SV * old_warnings = cx->blk_oldcop->cop_warnings ; 1696 1697 84591 if (old_warnings == pWARN_NONE || 1698 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)) 1699 27546 mask = newSVpvn(WARN_NONEstring, WARNsize) ; 1700 57045 else if (old_warnings == pWARN_ALL || 1701 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) { 1702 /* Get the bit mask for $warnings::Bits{all}, because 1703 * it could have been extended by warnings::register */ 1704 43252 SV **bits_all; 1705 43252 HV *bits = get_hv("warnings::Bits", FALSE); 1706 43252 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) { 1707 42323 mask = newSVsv(*bits_all); 1708 } 1709 else { 1710 929 mask = newSVpvn(WARN_ALLstring, WARNsize) ; 1711 } 1712 } 1713 else 1714 13793 mask = newSVsv(old_warnings); 1715 84591 PUSHs(sv_2mortal(mask)); 1716 } 1717 84591 RETURN; 1718 } 1719 1720 PP(pp_reset) 1721 13 { 1722 13 dSP; 1723 13 const char *tmps; 1724 1725 13 if (MAXARG < 1) 1726 8 tmps = ""; 1727 else 1728 5 tmps = POPpconstx; 1729 13 sv_reset(tmps, CopSTASH(PL_curcop)); 1730 13 PUSHs(&PL_sv_yes); 1731 13 RETURN; 1732 } 1733 1734 PP(pp_lineseq) 1735 ###### { 1736 ###### return NORMAL; 1737 } 1738 1739 /* like pp_nextstate, but used instead when the debugger is active */ 1740 1741 PP(pp_dbstate) 1742 160316 { 1743 dVAR; 1744 160316 PL_curcop = (COP*)PL_op; 1745 160316 TAINT_NOT; /* Each statement is presumed innocent */ 1746 160316 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp; 1747 160316 FREETMPS; 1748 1749 160316 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */ 1750 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace)) 1751 { 1752 7 dSP; 1753 7 register CV *cv; 1754 7 register PERL_CONTEXT *cx; 1755 7 const I32 gimme = G_ARRAY; 1756 7 U8 hasargs; 1757 7 GV *gv; 1758 1759 7 gv = PL_DBgv; 1760 7 cv = GvCV(gv); 1761 7 if (!cv) 1762 ###### DIE(aTHX_ "No DB::DB routine defined"); 1763 1764 7 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG)) 1765 /* don't do recursive DB::DB call */ 1766 ###### return NORMAL; 1767 1768 7 ENTER; 1769 7 SAVETMPS; 1770 1771 7 SAVEI32(PL_debug); 1772 7 SAVESTACK_POS(); 1773 7 PL_debug = 0; 1774 7 hasargs = 0; 1775 7 SPAGAIN; 1776 1777 7 PUSHBLOCK(cx, CXt_SUB, SP); 1778 7 PUSHSUB_DB(cx); 1779 7 cx->blk_sub.retop = PL_op->op_next; 1780 7 CvDEPTH(cv)++; 1781 7 SAVECOMPPAD(); 1782 7 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1); 1783 7 RETURNOP(CvSTART(cv)); 1784 } 1785 else 1786 160309 return NORMAL; 1787 } 1788 1789 PP(pp_scope) 1790 3245349 { 1791 3245349 return NORMAL; 1792 } 1793 1794 PP(pp_enteriter) 1795 821621 { 1796 821621 dVAR; dSP; dMARK; 1797 821621 register PERL_CONTEXT *cx; 1798 821621 const I32 gimme = GIMME_V; 1799 821621 SV **svp; 1800 821621 U32 cxtype = CXt_LOOP; 1801 #ifdef USE_ITHREADS 1802 void *iterdata; 1803 #endif 1804 1805 821621 ENTER; 1806 821621 SAVETMPS; 1807 1808 821621 if (PL_op->op_targ) { 1809 539341 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */ 1810 418925 SvPADSTALE_off(PAD_SVl(PL_op->op_targ)); 1811 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ), 1812 418925 SVs_PADSTALE, SVs_PADSTALE); 1813 } 1814 #ifndef USE_ITHREADS 1815 539341 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */ 1816 539341 SAVESPTR(*svp); 1817 #else 1818 SAVEPADSV(PL_op->op_targ); 1819 iterdata = INT2PTR(void*, PL_op->op_targ); 1820 cxtype |= CXp_PADVAR; 1821 #endif 1822 } 1823 else { 1824 282280 GV *gv = (GV*)POPs; 1825 282280 svp = &GvSV(gv); /* symbol table variable */ 1826 282280 SAVEGENERICSV(*svp); 1827 282280 *svp = NEWSV(0,0); 1828 #ifdef USE_ITHREADS 1829 iterdata = (void*)gv; 1830 #endif 1831 } 1832 1833 821621 ENTER; 1834 1835 821621 PUSHBLOCK(cx, cxtype, SP); 1836 #ifdef USE_ITHREADS 1837 PUSHLOOP(cx, iterdata, MARK); 1838 #else 1839 821621 PUSHLOOP(cx, svp, MARK); 1840 #endif 1841 821621 if (PL_op->op_flags & OPf_STACKED) { 1842 465540 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs); 1843 465540 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) { 1844 18870 dPOPss; 1845 18870 SV *right = (SV*)cx->blk_loop.iterary; 1846 18870 if (RANGE_IS_NUMERIC(sv,right)) { 1847 18863 if ((SvOK(sv) && SvNV(sv) < IV_MIN) || 1848 (SvOK(right) && SvNV(right) >= IV_MAX)) 1849 ###### DIE(aTHX_ "Range iterator outside integer range"); 1850 18863 cx->blk_loop.iterix = SvIV(sv); 1851 18863 cx->blk_loop.itermax = SvIV(right); 1852 } 1853 else { 1854 7 cx->blk_loop.iterlval = newSVsv(sv); 1855 7 (void) SvPV_force_nolen(cx->blk_loop.iterlval); 1856 7 (void) SvPV_nolen_const(right); 1857 } 1858 } 1859 446670 else if (PL_op->op_private & OPpITER_REVERSED) { 1860 2705 cx->blk_loop.itermax = -1; 1861 2705 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary); 1862 1863 } 1864 } 1865 else { 1866 356081 cx->blk_loop.iterary = PL_curstack; 1867 356081 AvFILLp(PL_curstack) = SP - PL_stack_base; 1868 356081 if (PL_op->op_private & OPpITER_REVERSED) { 1869 33 cx->blk_loop.itermax = MARK - PL_stack_base; 1870 33 cx->blk_loop.iterix = cx->blk_oldsp; 1871 } 1872 else { 1873 356048 cx->blk_loop.iterix = MARK - PL_stack_base; 1874 } 1875 } 1876 1877 821621 RETURN; 1878 } 1879 1880 PP(pp_enterloop) 1881 1679914 { 1882 1679914 dVAR; dSP; 1883 1679914 register PERL_CONTEXT *cx; 1884 1679914 const I32 gimme = GIMME_V; 1885 1886 1679914 ENTER; 1887 1679914 SAVETMPS; 1888 1679914 ENTER; 1889 1890 1679914 PUSHBLOCK(cx, CXt_LOOP, SP); 1891 1679914 PUSHLOOP(cx, 0, SP); 1892 1893 1679914 RETURN; 1894 } 1895 1896 PP(pp_leaveloop) 1897 1853593 { 1898 1853593 dVAR; dSP; 1899 1853593 register PERL_CONTEXT *cx; 1900 1853593 I32 gimme; 1901 1853593 SV **newsp; 1902 1853593 PMOP *newpm; 1903 1853593 SV **mark; 1904 1905 1853593 POPBLOCK(cx,newpm); 1906 1853593 assert(CxTYPE(cx) == CXt_LOOP); 1907 1853593 mark = newsp; 1908 1853593 newsp = PL_stack_base + cx->blk_loop.resetsp; 1909 1910 1853593 TAINT_NOT; 1911 1853593 if (gimme == G_VOID) 1912 ; /* do nothing */ 1913 798420 else if (gimme == G_SCALAR) { 1914 2988 if (mark < SP) 1915 2988 *++newsp = sv_mortalcopy(*SP); 1916 else 1917 ###### *++newsp = &PL_sv_undef; 1918 } 1919 else { 1920 1501117 while (mark < SP) { 1921 705685 *++newsp = sv_mortalcopy(*++mark); 1922 705685 TAINT_NOT; /* Each item is independent */ 1923 } 1924 } 1925 1853593 SP = newsp; 1926 1853593 PUTBACK; 1927 1928 1853593 POPLOOP(cx); /* Stack values are safe: release loop vars ... */ 1929 1853593 PL_curpm = newpm; /* ... and pop $1 et al */ 1930 1931 1853593 LEAVE; 1932 1853593 LEAVE; 1933 1934 1853593 return NORMAL; 1935 } 1936 1937 PP(pp_return) 1938 9020105 { 1939 9020105 dVAR; dSP; dMARK; 1940 9020105 I32 cxix; 1941 9020105 register PERL_CONTEXT *cx; 1942 9020105 bool popsub2 = FALSE; 1943 9020105 bool clear_errsv = FALSE; 1944 9020105 I32 gimme; 1945 9020105 SV **newsp; 1946 9020105 PMOP *newpm; 1947 9020105 I32 optype = 0; 1948 9020105 SV *sv; 1949 9020105 OP *retop; 1950 1951 9020105 if (PL_curstackinfo->si_type == PERLSI_SORT) { 1952 1558 if (cxstack_ix == PL_sortcxix 1953 || dopoptosub(cxstack_ix) <= PL_sortcxix) 1954 { 1955 1556 if (cxstack_ix > PL_sortcxix) 1956 192 dounwind(PL_sortcxix); 1957 1556 AvARRAY(PL_curstack)[1] = *SP; 1958 1556 PL_stack_sp = PL_stack_base + 1; 1959 1556 return 0; 1960 } 1961 } 1962 1963 9018549 cxix = dopoptosub(cxstack_ix); 1964 9018549 if (cxix < 0) 1965 ###### DIE(aTHX_ "Can't return outside a subroutine"); 1966 9018549 if (cxix < cxstack_ix) 1967 721148 dounwind(cxix); 1968 1969 9018549 POPBLOCK(cx,newpm); 1970 9018549 switch (CxTYPE(cx)) { 1971 case CXt_SUB: 1972 9013670 popsub2 = TRUE; 1973 9013670 retop = cx->blk_sub.retop; 1974 9013670 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */ 1975 9013670 break; 1976 case CXt_EVAL: 1977 4879 if (!(PL_in_eval & EVAL_KEEPERR)) 1978 4879 clear_errsv = TRUE; 1979 4879 POPEVAL(cx); 1980 4879 retop = cx->blk_eval.retop; 1981 4879 if (CxTRYBLOCK(cx)) 1982 3 break; 1983 4876 lex_end(); 1984 4876 if (optype == OP_REQUIRE && 1985 1 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) ) 1986 { 1987 /* Unassume the success we assumed earlier. */ 1988 ###### SV * const nsv = cx->blk_eval.old_namesv; 1989 ###### (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD); 1990 ###### DIE(aTHX_ "%"SVf" did not return a true value", nsv); 1991 } 1992 ###### break; 1993 case CXt_FORMAT: 1994 ###### POPFORMAT(cx); 1995 ###### retop = cx->blk_sub.retop; 1996 ###### break; 1997 default: 1998 ###### DIE(aTHX_ "panic: return"); 1999 } 2000 2001 9018549 TAINT_NOT; 2002 9018549 if (gimme == G_SCALAR) { 2003 7369407 if (MARK < SP) { 2004 7331492 if (popsub2) { 2005 7326618 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) { 2006 5321352 if (SvTEMP(TOPs)) { 2007 3063 *++newsp = SvREFCNT_inc(*SP); 2008 3063 FREETMPS; 2009 3063 sv_2mortal(*newsp); 2010 } 2011 else { 2012 5318289 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */ 2013 5318289 FREETMPS; 2014 5318289 *++newsp = sv_mortalcopy(sv); 2015 5318289 SvREFCNT_dec(sv); 2016 } 2017 } 2018 else 2019 2005266 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP); 2020 } 2021 else 2022 4874 *++newsp = sv_mortalcopy(*SP); 2023 } 2024 else 2025 37915 *++newsp = &PL_sv_undef; 2026 } 2027 1649142 else if (gimme == G_ARRAY) { 2028 2307984 while (++MARK <= SP) { 2029 1317349 *++newsp = (popsub2 && SvTEMP(*MARK)) 2030 ? *MARK : sv_mortalcopy(*MARK); 2031 1317349 TAINT_NOT; /* Each item is independent */ 2032 } 2033 } 2034 9018549 PL_stack_sp = newsp; 2035 2036 9018549 LEAVE; 2037 /* Stack values are safe: */ 2038 9018549 if (popsub2) { 2039 9013670 cxstack_ix--; 2040 9013670 POPSUB(cx,sv); /* release CV and @_ ... */ 2041 } 2042 else 2043 4879 sv = Nullsv; 2044 9018549 PL_curpm = newpm; /* ... and pop $1 et al */ 2045 2046 9018549 LEAVESUB(sv); 2047 9018549 if (clear_errsv) 2048 4879 sv_setpvn(ERRSV,"",0); 2049 9018549 return retop; 2050 } 2051 2052 PP(pp_last) 2053 86734 { 2054 86734 dVAR; dSP; 2055 86734 I32 cxix; 2056 86734 register PERL_CONTEXT *cx; 2057 86734 I32 pop2 = 0; 2058 86734 I32 gimme; 2059 86734 I32 optype; 2060 86734 OP *nextop; 2061 86734 SV **newsp; 2062 86734 PMOP *newpm; 2063 86734 SV **mark; 2064 86734 SV *sv = Nullsv; 2065 2066 2067 86734 if (PL_op->op_flags & OPf_SPECIAL) { 2068 56665 cxix = dopoptoloop(cxstack_ix); 2069 56665 if (cxix < 0) 2070 2 DIE(aTHX_ "Can't \"last\" outside a loop block"); 2071 } 2072 else { 2073 30069 cxix = dopoptolabel(cPVOP->op_pv); 2074 30069 if (cxix < 0) 2075 2 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv); 2076 } 2077 86730 if (cxix < cxstack_ix) 2078 59830 dounwind(cxix); 2079 2080 86730 POPBLOCK(cx,newpm); 2081 86730 cxstack_ix++; /* temporarily protect top context */ 2082 86730 mark = newsp; 2083 86730 switch (CxTYPE(cx)) { 2084 case CXt_LOOP: 2085 86730 pop2 = CXt_LOOP; 2086 86730 newsp = PL_stack_base + cx->blk_loop.resetsp; 2087 86730 nextop = cx->blk_loop.last_op->op_next; 2088 86730 break; 2089 case CXt_SUB: 2090 ###### pop2 = CXt_SUB; 2091 ###### nextop = cx->blk_sub.retop; 2092 ###### break; 2093 case CXt_EVAL: 2094 ###### POPEVAL(cx); 2095 ###### nextop = cx->blk_eval.retop; 2096 ###### break; 2097 case CXt_FORMAT: 2098 ###### POPFORMAT(cx); 2099 ###### nextop = cx->blk_sub.retop; 2100 ###### break; 2101 default: 2102 ###### DIE(aTHX_ "panic: last"); 2103 } 2104 2105 86730 TAINT_NOT; 2106 86730 if (gimme == G_SCALAR) { 2107 17 if (MARK < SP) 2108 ###### *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP)) 2109 ? *SP : sv_mortalcopy(*SP); 2110 else 2111 17 *++newsp = &PL_sv_undef; 2112 } 2113 86713 else if (gimme == G_ARRAY) { 2114 21852 while (++MARK <= SP) { 2115 ###### *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK)) 2116 ? *MARK : sv_mortalcopy(*MARK); 2117 ###### TAINT_NOT; /* Each item is independent */ 2118 } 2119 } 2120 86730 SP = newsp; 2121 86730 PUTBACK; 2122 2123 86730 LEAVE; 2124 86730 cxstack_ix--; 2125 /* Stack values are safe: */ 2126 86730 switch (pop2) { 2127 case CXt_LOOP: 2128 86730 POPLOOP(cx); /* release loop vars ... */ 2129 86730 LEAVE; 2130 86730 break; 2131 case CXt_SUB: 2132 ###### POPSUB(cx,sv); /* release CV and @_ ... */ 2133 break; 2134 } 2135 86730 PL_curpm = newpm; /* ... and pop $1 et al */ 2136 2137 86730 LEAVESUB(sv); 2138 86730 PERL_UNUSED_VAR(optype); 2139 86730 PERL_UNUSED_VAR(gimme); 2140 86730 return nextop; 2141 } 2142 2143 PP(pp_next) 2144 463334 { 2145 dVAR; 2146 463334 I32 cxix; 2147 463334 register PERL_CONTEXT *cx; 2148 463334 I32 inner; 2149 2150 463334 if (PL_op->op_flags & OPf_SPECIAL) { 2151 460469 cxix = dopoptoloop(cxstack_ix); 2152 460469 if (cxix < 0) 2153 3 DIE(aTHX_ "Can't \"next\" outside a loop block"); 2154 } 2155 else { 2156 2865 cxix = dopoptolabel(cPVOP->op_pv); 2157 2865 if (cxix < 0) 2158 ###### DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv); 2159 } 2160 463331 if (cxix < cxstack_ix) 2161 130256 dounwind(cxix); 2162 2163 /* clear off anything above the scope we're re-entering, but 2164 * save the rest until after a possible continue block */ 2165 463331 inner = PL_scopestack_ix; 2166 463331 TOPBLOCK(cx); 2167 463331 if (PL_scopestack_ix < inner) 2168 130256 leave_scope(PL_scopestack[PL_scopestack_ix]); 2169 463331 PL_curcop = cx->blk_oldcop; 2170 463331 return cx->blk_loop.next_op; 2171 } 2172 2173 PP(pp_redo) 2174 3213 { 2175 dVAR; 2176 3213 I32 cxix; 2177 3213 register PERL_CONTEXT *cx; 2178 3213 I32 oldsave; 2179 3213 OP* redo_op; 2180 2181 3213 if (PL_op->op_flags & OPf_SPECIAL) { 2182 3196 cxix = dopoptoloop(cxstack_ix); 2183 3196 if (cxix < 0) 2184 ###### DIE(aTHX_ "Can't \"redo\" outside a loop block"); 2185 } 2186 else { 2187 17 cxix = dopoptolabel(cPVOP->op_pv); 2188 17 if (cxix < 0) 2189 ###### DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv); 2190 } 2191 3213 if (cxix < cxstack_ix) 2192 45 dounwind(cxix); 2193 2194 3213 redo_op = cxstack[cxix].blk_loop.redo_op; 2195 3213 if (redo_op->op_type == OP_ENTER) { 2196 /* pop one less context to avoid $x being freed in while (my $x..) */ 2197 24 cxstack_ix++; 2198 24 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK); 2199 24 redo_op = redo_op->op_next; 2200 } 2201 2202 3213 TOPBLOCK(cx); 2203 3213 oldsave = PL_scopestack[PL_scopestack_ix - 1]; 2204 3213 LEAVE_SCOPE(oldsave); 2205 3213 FREETMPS; 2206 3213 PL_curcop = cx->blk_oldcop; 2207 3213 return redo_op; 2208 } 2209 2210 STATIC OP * 2211 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit) 2212 47107 { 2213 47107 OP *kid = Nullop; 2214 47107 OP **ops = opstack; 2215 47107 static const char too_deep[] = "Target of goto is too deeply nested"; 2216 2217 47107 if (ops >= oplimit) 2218 ###### Perl_croak(aTHX_ too_deep); 2219 47107 if (o->op_type == OP_LEAVE || 2220 o->op_type == OP_SCOPE || 2221 o->op_type == OP_LEAVELOOP || 2222 o->op_type == OP_LEAVESUB || 2223 o->op_type == OP_LEAVETRY) 2224 { 2225 3589 *ops++ = cUNOPo->op_first; 2226 3589 if (ops >= oplimit) 2227 ###### Perl_croak(aTHX_ too_deep); 2228 } 2229 47107 *ops = 0; 2230 47107 if (o->op_flags & OPf_KIDS) { 2231 /* First try all the kids at this level, since that's likeliest. */ 2232 94262 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { 2233 69723 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) && 2234 kCOP->cop_label && strEQ(kCOP->cop_label, label)) 2235 822 return kid; 2236 } 2237 68648 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { 2238 45495 if (kid == PL_lastgotoprobe) 2239 115 continue; 2240 45380 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) { 2241 3350 if (ops == opstack) 2242 256 *ops++ = kid; 2243 3094 else if (ops[-1]->op_type == OP_NEXTSTATE || 2244 ops[-1]->op_type == OP_DBSTATE) 2245 1634 ops[-1] = kid; 2246 else 2247 1460 *ops++ = kid; 2248 } 2249 45380 if ((o = dofindlabel(kid, label, ops, oplimit))) 2250 1386 return o; 2251 } 2252 } 2253 44899 *ops = 0; 2254 44899 return 0; 2255 } 2256 2257 PP(pp_dump) 2258 ###### { 2259 ###### return pp_goto(); 2260 /*NOTREACHED*/ 2261 } 2262 2263 PP(pp_goto) 2264 8782 { 2265 8782 dVAR; dSP; 2266 8782 OP *retop = 0; 2267 8782 I32 ix; 2268 8782 register PERL_CONTEXT *cx; 2269 #define GOTO_DEPTH 64 2270 8782 OP *enterops[GOTO_DEPTH]; 2271 8782 const char *label = 0; 2272 8782 const bool do_dump = (PL_op->op_type == OP_DUMP); 2273 8782 static const char must_have_label[] = "goto must have label"; 2274 2275 8782 if (PL_op->op_flags & OPf_STACKED) { 2276 7959 SV * const sv = POPs; 2277 2278 /* This egregious kludge implements goto &subroutine */ 2279 7959 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) { 2280 7956 I32 cxix; 2281 7956 register PERL_CONTEXT *cx; 2282 7956 CV* cv = (CV*)SvRV(sv); 2283 7956 SV** mark; 2284 7956 I32 items = 0; 2285 7956 I32 oldsave; 2286 7956 bool reified = 0; 2287 2288 retry: 2289 7957 if (!CvROOT(cv) && !CvXSUB(cv)) { 2290 1 const GV * const gv = CvGV(cv); 2291 1 if (gv) { 2292 1 GV *autogv; 2293 1 SV *tmpstr; 2294 /* autoloaded stub? */ 2295 1 if (cv != GvCV(gv) && (cv = GvCV(gv))) 2296 ###### goto retry; 2297 1 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), 2298 GvNAMELEN(gv), FALSE); 2299 1 if (autogv && (cv = GvCV(autogv))) 2300 1 goto retry; 2301 ###### tmpstr = sv_newmortal(); 2302 ###### gv_efullname3(tmpstr, gv, Nullch); 2303 ###### DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr); 2304 } 2305 ###### DIE(aTHX_ "Goto undefined subroutine"); 2306 } 2307 2308 /* First do some returnish stuff. */ 2309 7956 (void)SvREFCNT_inc(cv); /* avoid premature free during unwind */ 2310 7956 FREETMPS; 2311 7956 cxix = dopoptosub(cxstack_ix); 2312 7956 if (cxix < 0) 2313 ###### DIE(aTHX_ "Can't goto subroutine outside a subroutine"); 2314 7956 if (cxix < cxstack_ix) 2315 65 dounwind(cxix); 2316 7956 TOPBLOCK(cx); 2317 7956 SPAGAIN; 2318 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */ 2319 7956 if (CxTYPE(cx) == CXt_EVAL) { 2320 2 if (CxREALEVAL(cx)) 2321 1 DIE(aTHX_ "Can't goto subroutine from an eval-string"); 2322 else 2323 1 DIE(aTHX_ "Can't goto subroutine from an eval-block"); 2324 } 2325 7954 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) { 2326 /* put @_ back onto stack */ 2327 7895 AV* av = cx->blk_sub.argarray; 2328 2329 7895 items = AvFILLp(av) + 1; 2330 7895 EXTEND(SP, items+1); /* @_ could have been extended. */ 2331 7895 Copy(AvARRAY(av), SP + 1, items, SV*); 2332 7895 SvREFCNT_dec(GvAV(PL_defgv)); 2333 7895 GvAV(PL_defgv) = cx->blk_sub.savearray; 2334 7895 CLEAR_ARGARRAY(av); 2335 /* abandon @_ if it got reified */ 2336 7895 if (AvREAL(av)) { 2337 875 reified = 1; 2338 875 SvREFCNT_dec(av); 2339 875 av = newAV(); 2340 875 av_extend(av, items-1); 2341 875 AvREIFY_only(av); 2342 875 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av); 2343 } 2344 } 2345 59 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */ 2346 4 AV* av; 2347 4 av = GvAV(PL_defgv); 2348 4 items = AvFILLp(av) + 1; 2349 4 EXTEND(SP, items+1); /* @_ could have been extended. */ 2350 4 Copy(AvARRAY(av), SP + 1, items, SV*); 2351 } 2352 7954 mark = SP; 2353 7954 SP += items; 2354 7954 if (CxTYPE(cx) == CXt_SUB && 2355 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth)) 2356 7953 SvREFCNT_dec(cx->blk_sub.cv); 2357 7954 oldsave = PL_scopestack[PL_scopestack_ix - 1]; 2358 7954 LEAVE_SCOPE(oldsave); 2359 2360 /* Now do some callish stuff. */ 2361 7954 SAVETMPS; 2362 7954 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */ 2363 7954 if (CvXSUB(cv)) { 2364 184 OP* retop = cx->blk_sub.retop; 2365 184 if (reified) { 2366 ###### I32 index; 2367 ###### for (index=0; index mark) { 2374 SP[1] = SP[0]; 2375 SP--; 2376 } 2377 fp3 = (I32(*)(int,int,int))CvXSUB(cv); 2378 items = (*fp3)(CvXSUBANY(cv).any_i32, 2379 mark - PL_stack_base + 1, 2380 items); 2381 SP = PL_stack_base + items; 2382 } 2383 else 2384 #endif /* PERL_XSUB_OLDSTYLE */ 2385 { 2386 184 SV **newsp; 2387 184 I32 gimme; 2388 2389 /* XS subs don't have a CxSUB, so pop it */ 2390 184 POPBLOCK(cx, PL_curpm); 2391 /* Push a mark for the start of arglist */ 2392 184 PUSHMARK(mark); 2393 184 PUTBACK; 2394 184 (void)(*CvXSUB(cv))(aTHX_ cv); 2395 /* Put these at the bottom since the vars are set but not used */ 2396 180 PERL_UNUSED_VAR(newsp); 2397 180 PERL_UNUSED_VAR(gimme); 2398 } 2399 180 LEAVE; 2400 180 return retop; 2401 } 2402 else { 2403 7770 AV* padlist = CvPADLIST(cv); 2404 7770 if (CxTYPE(cx) == CXt_EVAL) { 2405 ###### PL_in_eval = cx->blk_eval.old_in_eval; 2406 ###### PL_eval_root = cx->blk_eval.old_eval_root; 2407 ###### cx->cx_type = CXt_SUB; 2408 ###### cx->blk_sub.hasargs = 0; 2409 } 2410 7770 cx->blk_sub.cv = cv; 2411 7770 cx->blk_sub.olddepth = (U16)CvDEPTH(cv); 2412 2413 7770 CvDEPTH(cv)++; 2414 7770 if (CvDEPTH(cv) < 2) 2415 7104 (void)SvREFCNT_inc(cv); 2416 else { 2417 666 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)) 2418 ###### sub_crush_depth(cv); 2419 666 pad_push(padlist, CvDEPTH(cv)); 2420 } 2421 7770 SAVECOMPPAD(); 2422 7770 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); 2423 7770 if (cx->blk_sub.hasargs) 2424 { 2425 7715 AV* av = (AV*)PAD_SVl(0); 2426 7715 SV** ary; 2427 2428 7715 cx->blk_sub.savearray = GvAV(PL_defgv); 2429 7715 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av); 2430 7715 CX_CURPAD_SAVE(cx->blk_sub); 2431 7715 cx->blk_sub.argarray = av; 2432 2433 7715 if (items >= AvMAX(av) + 1) { 2434 575 ary = AvALLOC(av); 2435 575 if (AvARRAY(av) != ary) { 2436 ###### AvMAX(av) += AvARRAY(av) - AvALLOC(av); 2437 ###### SvPV_set(av, (char*)ary); 2438 } 2439 575 if (items >= AvMAX(av) + 1) { 2440 575 AvMAX(av) = items - 1; 2441 575 Renew(ary,items+1,SV*); 2442 575 AvALLOC(av) = ary; 2443 575 SvPV_set(av, (char*)ary); 2444 } 2445 } 2446 7715 ++mark; 2447 7715 Copy(mark,AvARRAY(av),items,SV*); 2448 7715 AvFILLp(av) = items - 1; 2449 7715 assert(!AvREAL(av)); 2450 7715 if (reified) { 2451 /* transfer 'ownership' of refcnts to new @_ */ 2452 875 AvREAL_on(av); 2453 875 AvREIFY_off(av); 2454 } 2455 19753 while (items--) { 2456 12038 if (*mark) 2457 12038 SvTEMP_off(*mark); 2458 12038 mark++; 2459 } 2460 } 2461 7770 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */ 2462 /* 2463 * We do not care about using sv to call CV; 2464 * it's for informational purposes only. 2465 */ 2466 ###### SV *sv = GvSV(PL_DBsub); 2467 ###### CV *gotocv; 2468 2469 ###### save_item(sv); 2470 ###### if (PERLDB_SUB_NN) { 2471 ###### int type = SvTYPE(sv); 2472 ###### if (type < SVt_PVIV && type != SVt_IV) 2473 ###### sv_upgrade(sv, SVt_PVIV); 2474 ###### (void)SvIOK_on(sv); 2475 ###### SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */ 2476 } else { 2477 ###### gv_efullname3(sv, CvGV(cv), Nullch); 2478 } 2479 ###### if ( PERLDB_GOTO 2480 && (gotocv = get_cv("DB::goto", FALSE)) ) { 2481 ###### PUSHMARK( PL_stack_sp ); 2482 ###### call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG); 2483 ###### PL_stack_sp--; 2484 } 2485 } 2486 7770 RETURNOP(CvSTART(cv)); 2487 } 2488 } 2489 else { 2490 3 label = SvPV_nolen_const(sv); 2491 3 if (!(do_dump || *label)) 2492 ###### DIE(aTHX_ must_have_label); 2493 } 2494 } 2495 823 else if (PL_op->op_flags & OPf_SPECIAL) { 2496 ###### if (! do_dump) 2497 ###### DIE(aTHX_ must_have_label); 2498 } 2499 else 2500 823 label = cPVOP->op_pv; 2501 2502 826 if (label && *label) { 2503 826 OP *gotoprobe = 0; 2504 826 bool leaving_eval = FALSE; 2505 826 bool in_block = FALSE; 2506 826 PERL_CONTEXT *last_eval_cx = 0; 2507 2508 /* find label */ 2509 2510 826 PL_lastgotoprobe = 0; 2511 826 *enterops = 0; 2512 1731 for (ix = cxstack_ix; ix >= 0; ix--) { 2513 1728 cx = &cxstack[ix]; 2514 1728 switch (CxTYPE(cx)) { 2515 case CXt_EVAL: 2516 11 leaving_eval = TRUE; 2517 11 if (!CxTRYBLOCK(cx)) { 2518 5 gotoprobe = (last_eval_cx ? 2519 last_eval_cx->blk_eval.old_eval_root : 2520 PL_eval_root); 2521 5 last_eval_cx = cx; 2522 5 break; 2523 } 2524 /* else fall through */ 2525 case CXt_LOOP: 2526 551 gotoprobe = cx->blk_oldcop->op_sibling; 2527 551 break; 2528 case CXt_SUBST: 2529 732 continue; 2530 case CXt_BLOCK: 2531 732 if (ix) { 2532 719 gotoprobe = cx->blk_oldcop->op_sibling; 2533 719 in_block = TRUE; 2534 } else 2535 13 gotoprobe = PL_main_root; 2536 13 break; 2537 case CXt_SUB: 2538 440 if (CvDEPTH(cx->blk_sub.cv)) { 2539 439 gotoprobe = CvROOT(cx->blk_sub.cv); 2540 439 break; 2541 } 2542 /* FALL THROUGH */ 2543 case CXt_FORMAT: 2544 case CXt_NULL: 2545 1 DIE(aTHX_ "Can't \"goto\" out of a pseudo block"); 2546 default: 2547 ###### if (ix) 2548 ###### DIE(aTHX_ "panic: goto"); 2549 ###### gotoprobe = PL_main_root; 2550 1727 break; 2551 } 2552 1727 if (gotoprobe) { 2553 1727 retop = dofindlabel(gotoprobe, label, 2554 enterops, enterops + GOTO_DEPTH); 2555 1727 if (retop) 2556 822 break; 2557 } 2558 905 PL_lastgotoprobe = gotoprobe; 2559 } 2560 825 if (!retop) 2561 3 DIE(aTHX_ "Can't find label %s", label); 2562 2563 /* if we're leaving an eval, check before we pop any frames 2564 that we're not going to punt, otherwise the error 2565 won't be caught */ 2566 2567 822 if (leaving_eval && *enterops && enterops[1]) { 2568 2 I32 i; 2569 4 for (i = 1; enterops[i]; i++) 2570 4 if (enterops[i]->op_type == OP_ENTERITER) 2571 2 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop"); 2572 } 2573 2574 /* pop unwanted frames */ 2575 2576 820 if (ix < cxstack_ix) { 2577 600 I32 oldsave; 2578 2579 600 if (ix < 0) 2580 ###### ix = 0; 2581 600 dounwind(ix); 2582 600 TOPBLOCK(cx); 2583 600 oldsave = PL_scopestack[PL_scopestack_ix]; 2584 600 LEAVE_SCOPE(oldsave); 2585 } 2586 2587 /* push wanted frames */ 2588 2589 820 if (*enterops && enterops[1]) { 2590 11 OP *oldop = PL_op; 2591 11 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1; 2592 33 for (; enterops[ix]; ix++) { 2593 11 PL_op = enterops[ix]; 2594 /* Eventually we may want to stack the needed arguments 2595 * for each op. For now, we punt on the hard ones. */ 2596 11 if (PL_op->op_type == OP_ENTERITER) 2597 ###### DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop"); 2598 11 CALL_FPTR(PL_op->op_ppaddr)(aTHX); 2599 } 2600 11 PL_op = oldop; 2601 } 2602 } 2603 2604 820 if (do_dump) { 2605 #ifdef VMS 2606 if (!retop) retop = PL_main_start; 2607 #endif 2608 ###### PL_restartop = retop; 2609 ###### PL_do_undump = TRUE; 2610 2611 ###### my_unexec(); 2612 2613 ###### PL_restartop = 0; /* hmm, must be GNU unexec().. */ 2614 ###### PL_do_undump = FALSE; 2615 } 2616 2617 820 RETURNOP(retop); 2618 } 2619 2620 PP(pp_exit) 2621 344 { 2622 344 dSP; 2623 344 I32 anum; 2624 2625 344 if (MAXARG < 1) 2626 47 anum = 0; 2627 else { 2628 297 anum = SvIVx(POPs); 2629 #ifdef VMS 2630 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH)) 2631 anum = 0; 2632 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH); 2633 #endif 2634 } 2635 344 PL_exit_flags |= PERL_EXIT_EXPECTED; 2636 344 my_exit(anum); 2637 PUSHs(&PL_sv_undef); 2638 RETURN; 2639 } 2640 2641 #ifdef NOTYET 2642 PP(pp_nswitch) 2643 { 2644 dSP; 2645 const NV value = SvNVx(GvSV(cCOP->cop_gv)); 2646 register I32 match = I_32(value); 2647 2648 if (value < 0.0) { 2649 if (((NV)match) > value) 2650 --match; /* was fractional--truncate other way */ 2651 } 2652 match -= cCOP->uop.scop.scop_offset; 2653 if (match < 0) 2654 match = 0; 2655 else if (match > cCOP->uop.scop.scop_max) 2656 match = cCOP->uop.scop.scop_max; 2657 PL_op = cCOP->uop.scop.scop_next[match]; 2658 RETURNOP(PL_op); 2659 } 2660 2661 PP(pp_cswitch) 2662 { 2663 dSP; 2664 register I32 match; 2665 2666 if (PL_multiline) 2667 PL_op = PL_op->op_next; /* can't assume anything */ 2668 else { 2669 match = *(SvPVx_nolen_const(GvSV(cCOP->cop_gv))) & 255; 2670 match -= cCOP->uop.scop.scop_offset; 2671 if (match < 0) 2672 match = 0; 2673 else if (match > cCOP->uop.scop.scop_max) 2674 match = cCOP->uop.scop.scop_max; 2675 PL_op = cCOP->uop.scop.scop_next[match]; 2676 } 2677 RETURNOP(PL_op); 2678 } 2679 #endif 2680 2681 /* Eval. */ 2682 2683 STATIC void 2684 S_save_lines(pTHX_ AV *array, SV *sv) 2685 ###### { 2686 ###### const char *s = SvPVX_const(sv); 2687 ###### const char *send = SvPVX_const(sv) + SvCUR(sv); 2688 ###### I32 line = 1; 2689 2690 ###### while (s && s < send) { 2691 ###### const char *t; 2692 ###### SV *tmpstr = NEWSV(85,0); 2693 2694 ###### sv_upgrade(tmpstr, SVt_PVMG); 2695 ###### t = strchr(s, '\n'); 2696 ###### if (t) 2697 ###### t++; 2698 else 2699 ###### t = send; 2700 2701 ###### sv_setpvn(tmpstr, s, t - s); 2702 ###### av_store(array, line++, tmpstr); 2703 ###### s = t; 2704 } 2705 } 2706 2707 STATIC void 2708 S_docatch_body(pTHX) 2709 8091 { 2710 8091 CALLRUNOPS(aTHX); 2711 return; 2712 } 2713 2714 STATIC OP * 2715 S_docatch(pTHX_ OP *o) 2716 8035 { 2717 8035 int ret; 2718 8035 OP * const oldop = PL_op; 2719 8035 dJMPENV; 2720 2721 #ifdef DEBUGGING 2722 8035 assert(CATCH_GET == TRUE); 2723 #endif 2724 8035 PL_op = o; 2725 2726 8035 JMPENV_PUSH(ret); 2727 8107 switch (ret) { 2728 case 0: 2729 8035 assert(cxstack_ix >= 0); 2730 8035 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL); 2731 8035 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env; 2732 redo_body: 2733 8091 docatch_body(); 2734 8019 break; 2735 case 3: 2736 /* die caught by an inner eval - continue inner loop */ 2737 2738 /* NB XXX we rely on the old popped CxEVAL still being at the top 2739 * of the stack; the way die_where() currently works, this 2740 * assumption is valid. In theory The cur_top_env value should be 2741 * returned in another global, the way retop (aka PL_restartop) 2742 * is. */ 2743 70 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL); 2744 2745 70 if (PL_restartop 2746 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env) 2747 { 2748 56 PL_op = PL_restartop; 2749 56 PL_restartop = 0; 2750 56 goto redo_body; 2751 } 2752 /* FALL THROUGH */ 2753 default: 2754 16 JMPENV_POP; 2755 16 PL_op = oldop; 2756 16 JMPENV_JUMP(ret); 2757 /* NOTREACHED */ 2758 } 2759 8019 JMPENV_POP; 2760 8019 PL_op = oldop; 2761 8019 return Nullop; 2762 } 2763 2764 OP * 2765 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp) 2766 /* sv Text to convert to OP tree. */ 2767 /* startop op_free() this to undo. */ 2768 /* code Short string id of the caller. */ 2769 1077 { 2770 1077 dVAR; dSP; /* Make POPBLOCK work. */ 2771 1077 PERL_CONTEXT *cx; 2772 1077 SV **newsp; 2773 1077 I32 gimme = G_VOID; 2774 1077 I32 optype; 2775 1077 OP dummy; 2776 1077 OP *rop; 2777 1077 char tbuf[TYPE_DIGITS(long) + 12 + 10]; 2778 1077 char *tmpbuf = tbuf; 2779 1077 char *safestr; 2780 1077 int runtime; 2781 1077 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */ 2782 2783 1077 ENTER; 2784 1077 lex_start(sv); 2785 1077 SAVETMPS; 2786 /* switch to eval mode */ 2787 2788 1077 if (IN_PERL_COMPILETIME) { 2789 736 SAVECOPSTASH_FREE(&PL_compiling); 2790 736 CopSTASH_set(&PL_compiling, PL_curstash); 2791 } 2792 1077 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) { 2793 ###### SV * const sv = sv_newmortal(); 2794 ###### Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]", 2795 code, (unsigned long)++PL_evalseq, 2796 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); 2797 ###### tmpbuf = SvPVX(sv); 2798 } 2799 else 2800 1077 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq); 2801 1077 SAVECOPFILE_FREE(&PL_compiling); 2802 1077 CopFILE_set(&PL_compiling, tmpbuf+2); 2803 1077 SAVECOPLINE(&PL_compiling); 2804 1077 CopLINE_set(&PL_compiling, 1); 2805 /* XXX For Cs within BEGIN {} blocks, this ends up 2806 deleting the eval's FILEGV from the stash before gv_check() runs 2807 (i.e. before run-time proper). To work around the coredump that 2808 ensues, we always turn GvMULTI_on for any globals that were 2809 introduced within evals. See force_ident(). GSAR 96-10-12 */ 2810 1077 safestr = savepv(tmpbuf); 2811 1077 SAVEDELETE(PL_defstash, safestr, strlen(safestr)); 2812 1077 SAVEHINTS(); 2813 #ifdef OP_IN_REGISTER 2814 PL_opsave = op; 2815 #else 2816 1077 SAVEVPTR(PL_op); 2817 #endif 2818 2819 /* we get here either during compilation, or via pp_regcomp at runtime */ 2820 1077 runtime = IN_PERL_RUNTIME; 2821 1077 if (runtime) 2822 341 runcv = find_runcv(NULL); 2823 2824 1077 PL_op = &dummy; 2825 1077 PL_op->op_type = OP_ENTEREVAL; 2826 1077 PL_op->op_flags = 0; /* Avoid uninit warning. */ 2827 1077 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP); 2828 1077 PUSHEVAL(cx, 0, Nullgv); 2829 2830 1077 if (runtime) 2831 341 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq); 2832 else 2833 736 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax); 2834 1069 POPBLOCK(cx,PL_curpm); 2835 1069 POPEVAL(cx); 2836 2837 1069 (*startop)->op_type = OP_NULL; 2838 1069 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL]; 2839 1069 lex_end(); 2840 /* XXX DAPM do this properly one year */ 2841 1069 *padp = (AV*)SvREFCNT_inc(PL_comppad); 2842 1069 LEAVE; 2843 1069 if (IN_PERL_COMPILETIME) 2844 728 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); 2845 #ifdef OP_IN_REGISTER 2846 op = PL_opsave; 2847 #endif 2848 1069 PERL_UNUSED_VAR(newsp); 2849 1069 PERL_UNUSED_VAR(optype); 2850 2851 1069 return rop; 2852 } 2853 2854 2855 /* 2856 =for apidoc find_runcv 2857 2858 Locate the CV corresponding to the currently executing sub or eval. 2859 If db_seqp is non_null, skip CVs that are in the DB package and populate 2860 *db_seqp with the cop sequence number at the point that the DB:: code was 2861 entered. (allows debuggers to eval in the scope of the breakpoint rather 2862 than in in the scope of the debugger itself). 2863 2864 =cut 2865 */ 2866 2867 CV* 2868 Perl_find_runcv(pTHX_ U32 *db_seqp) 2869 68194 { 2870 68194 PERL_SI *si; 2871 2872 68194 if (db_seqp) 2873 67801 *db_seqp = PL_curcop->cop_seq; 2874 93206 for (si = PL_curstackinfo; si; si = si->si_prev) { 2875 68197 I32 ix; 2876 252677 for (ix = si->si_cxix; ix >= 0; ix--) { 2877 227665 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]); 2878 227665 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { 2879 19894 CV * const cv = cx->blk_sub.cv; 2880 /* skip DB:: code */ 2881 19894 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) { 2882 3 *db_seqp = cx->blk_oldcop->cop_seq; 2883 3 continue; 2884 } 2885 19891 return cv; 2886 } 2887 207771 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx)) 2888 23294 return PL_compcv; 2889 } 2890 } 2891 25009 return PL_main_cv; 2892 } 2893 2894 2895 /* Compile a require/do, an eval '', or a /(?{...})/. 2896 * In the last case, startop is non-null, and contains the address of 2897 * a pointer that should be set to the just-compiled code. 2898 * outside is the lexically enclosing CV (if any) that invoked us. 2899 */ 2900 2901 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */ 2902 STATIC OP * 2903 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) 2904 101767 { 2905 101767 dVAR; dSP; 2906 101767 OP *saveop = PL_op; 2907 2908 101767 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE) 2909 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL)) 2910 : EVAL_INEVAL); 2911 2912 101767 PUSHMARK(SP); 2913 2914 101767 SAVESPTR(PL_compcv); 2915 101767 PL_compcv = (CV*)NEWSV(1104,0); 2916 101767 sv_upgrade((SV *)PL_compcv, SVt_PVCV); 2917 101767 CvEVAL_on(PL_compcv); 2918 101767 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL); 2919 101767 cxstack[cxstack_ix].blk_eval.cv = PL_compcv; 2920 2921 101767 CvOUTSIDE_SEQ(PL_compcv) = seq; 2922 101767 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside); 2923 2924 /* set up a scratch pad */ 2925 2926 101767 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE); 2927 2928 2929 101767 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */ 2930 2931 /* make sure we compile in the right package */ 2932 2933 101767 if (CopSTASH_ne(PL_curcop, PL_curstash)) { 2934 30144 SAVESPTR(PL_curstash); 2935 30144 PL_curstash = CopSTASH(PL_curcop); 2936 } 2937 101767 SAVESPTR(PL_beginav); 2938 101767 PL_beginav = newAV(); 2939 101767 SAVEFREESV(PL_beginav); 2940 101767 SAVEI32(PL_error_count); 2941 2942 /* try to compile it */ 2943 2944 101767 PL_eval_root = Nullop; 2945 101767 PL_error_count = 0; 2946 101767 PL_curcop = &PL_compiling; 2947 101767 PL_curcop->cop_arybase = 0; 2948 101767 if (saveop && saveop->op_flags & OPf_SPECIAL) 2949 8 PL_in_eval |= EVAL_KEEPERR; 2950 else 2951 101759 sv_setpvn(ERRSV,"",0); 2952 101767 if (yyparse() || PL_error_count || !PL_eval_root) { 2953 194 SV **newsp; /* Used by POPBLOCK. */ 2954 194 PERL_CONTEXT *cx = &cxstack[cxstack_ix]; 2955 194 I32 optype = 0; /* Might be reset by POPEVAL. */ 2956 194 const char *msg; 2957 2958 194 PL_op = saveop; 2959 194 if (PL_eval_root) { 2960 186 op_free(PL_eval_root); 2961 186 PL_eval_root = Nullop; 2962 } 2963 194 SP = PL_stack_base + POPMARK; /* pop original mark */ 2964 194 if (!startop) { 2965 186 POPBLOCK(cx,PL_curpm); 2966 186 POPEVAL(cx); 2967 } 2968 194 lex_end(); 2969 194 LEAVE; 2970 2971 194 msg = SvPVx_nolen_const(ERRSV); 2972 194 if (optype == OP_REQUIRE) { 2973 7 const SV * const nsv = cx->blk_eval.old_namesv; 2974 7 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), 2975 &PL_sv_undef, 0); 2976 7 DIE(aTHX_ "%sCompilation failed in require", 2977 *msg ? msg : "Unknown error\n"); 2978 } 2979 187 else if (startop) { 2980 8 POPBLOCK(cx,PL_curpm); 2981 8 POPEVAL(cx); 2982 8 Perl_croak(aTHX_ "%sCompilation failed in regexp", 2983 (*msg ? msg : "Unknown error\n")); 2984 } 2985 else { 2986 179 if (!*msg) { 2987 ###### sv_setpv(ERRSV, "Compilation error"); 2988 } 2989 } 2990 179 PERL_UNUSED_VAR(newsp); 2991 179 RETPUSHUNDEF; 2992 } 2993 100861 CopLINE_set(&PL_compiling, 0); 2994 100861 if (startop) { 2995 1069 *startop = PL_eval_root; 2996 } else 2997 99792 SAVEFREEOP(PL_eval_root); 2998 2999 /* Set the context for this new optree. 3000 * If the last op is an OP_REQUIRE, force scalar context. 3001 * Otherwise, propagate the context from the eval(). */ 3002 100861 if (PL_eval_root->op_type == OP_LEAVEEVAL 3003 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ 3004 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type 3005 == OP_REQUIRE) 3006 361 scalar(PL_eval_root); 3007 100500 else if (gimme & G_VOID) 3008 13514 scalarvoid(PL_eval_root); 3009 86986 else if (gimme & G_ARRAY) 3010 576 list(PL_eval_root); 3011 else 3012 86410 scalar(PL_eval_root); 3013 3014 100861 DEBUG_x(dump_eval()); 3015 3016 /* Register with debugger: */ 3017 100861 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) { 3018 18 CV *cv = get_cv("DB::postponed", FALSE); 3019 18 if (cv) { 3020 ###### dSP; 3021 ###### PUSHMARK(SP); 3022 ###### XPUSHs((SV*)CopFILEGV(&PL_compiling)); 3023 ###### PUTBACK; 3024 ###### call_sv((SV*)cv, G_DISCARD); 3025 } 3026 } 3027 3028 /* compiled okay, so do it */ 3029 3030 100861 CvDEPTH(PL_compcv) = 1; 3031 100861 SP = PL_stack_base + POPMARK; /* pop original mark */ 3032 100861 PL_op = saveop; /* The caller may need it. */ 3033 100861 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */ 3034 3035 100861 RETURNOP(PL_eval_start); 3036 } 3037 3038 STATIC PerlIO * 3039 S_doopen_pm(pTHX_ const char *name, const char *mode) 3040 41605 { 3041 #ifndef PERL_DISABLE_PMC 3042 41605 const STRLEN namelen = strlen(name); 3043 41605 PerlIO *fp; 3044 3045 41605 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) { 3046 34911 SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c'); 3047 34911 const char * const pmc = SvPV_nolen_const(pmcsv); 3048 34911 Stat_t pmcstat; 3049 34911 if (PerlLIO_stat(pmc, &pmcstat) < 0) { 3050 34911 fp = PerlIO_open(name, mode); 3051 } 3052 else { 3053 ###### Stat_t pmstat; 3054 ###### if (PerlLIO_stat(name, &pmstat) < 0 || 3055 pmstat.st_mtime < pmcstat.st_mtime) 3056 { 3057 ###### fp = PerlIO_open(pmc, mode); 3058 } 3059 else { 3060 ###### fp = PerlIO_open(name, mode); 3061 } 3062 } 3063 34911 SvREFCNT_dec(pmcsv); 3064 } 3065 else { 3066 6694 fp = PerlIO_open(name, mode); 3067 } 3068 41605 return fp; 3069 #else 3070 return PerlIO_open(name, mode); 3071 #endif /* !PERL_DISABLE_PMC */ 3072 } 3073 3074 PP(pp_require) 3075 146496 { 3076 146496 dVAR; dSP; 3077 146496 register PERL_CONTEXT *cx; 3078 146496 SV *sv; 3079 146496 const char *name; 3080 146496 STRLEN len; 3081 146496 const char *tryname = Nullch; 3082 146496 SV *namesv = Nullsv; 3083 146496 SV** svp; 3084 146496 const I32 gimme = GIMME_V; 3085 146496 PerlIO *tryrsfp = 0; 3086 146496 int filter_has_file = 0; 3087 146496 GV *filter_child_proc = 0; 3088 146496 SV *filter_state = 0; 3089 146496 SV *filter_sub = 0; 3090 146496 SV *hook_sv = 0; 3091 146496 SV *encoding; 3092 146496 OP *op; 3093 3094 146496 sv = POPs; 3095 146496 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) { 3096 10640 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */ 3097 2 Perl_warner(aTHX_ packWARN(WARN_PORTABLE), 3098 "v-string in use/require non-portable"); 3099 3100 10640 sv = new_version(sv); 3101 10640 if (!sv_derived_from(PL_patchlevel, "version")) 3102 1515 (void *)upg_version(PL_patchlevel); 3103 10640 if ( vcmp(sv,PL_patchlevel) > 0 ) 3104 6 DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped", 3105 vnormal(sv), vnormal(PL_patchlevel)); 3106 3107 10634 RETPUSHYES; 3108 } 3109 135856 name = SvPV_const(sv, len); 3110 135856 if (!(name && len > 0 && *name)) 3111 ###### DIE(aTHX_ "Null filename used"); 3112 135856 TAINT_PROPER("require"); 3113 135855 if (PL_op->op_type == OP_REQUIRE && 3114 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) { 3115 100205 if (*svp != &PL_sv_undef) 3116 100202 RETPUSHYES; 3117 else 3118 3 DIE(aTHX_ "Compilation failed in require"); 3119 } 3120 3121 /* prepare to compile file */ 3122 3123 35650 if (path_is_absolute(name)) { 3124 1032 tryname = name; 3125 1032 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE); 3126 } 3127 #ifdef MACOS_TRADITIONAL 3128 if (!tryrsfp) { 3129 char newname[256]; 3130 3131 MacPerl_CanonDir(name, newname, 1); 3132 if (path_is_absolute(newname)) { 3133 tryname = newname; 3134 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE); 3135 } 3136 } 3137 #endif 3138 35650 if (!tryrsfp) { 3139 34620 AV *ar = GvAVn(PL_incgv); 3140 34620 I32 i; 3141 #ifdef VMS 3142 char *unixname; 3143 if ((unixname = tounixspec(name, Nullch)) != Nullch) 3144 #endif 3145 { 3146 34620 namesv = NEWSV(806, 0); 3147 40863 for (i = 0; i <= AvFILL(ar); i++) { 3148 40588 SV *dirsv = *av_fetch(ar, i, TRUE); 3149 3150 40588 if (SvROK(dirsv)) { 3151 14 int count; 3152 14 SV *loader = dirsv; 3153 3154 14 if (SvTYPE(SvRV(loader)) == SVt_PVAV 3155 && !sv_isobject(loader)) 3156 { 3157 4 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE); 3158 } 3159 3160 14 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s", 3161 PTR2UV(SvRV(dirsv)), name); 3162 14 tryname = SvPVX_const(namesv); 3163 14 tryrsfp = 0; 3164 3165 14 ENTER; 3166 14 SAVETMPS; 3167 14 EXTEND(SP, 2); 3168 3169 14 PUSHMARK(SP); 3170 14 PUSHs(dirsv); 3171 14 PUSHs(sv); 3172 14 PUTBACK; 3173 14 if (sv_isobject(loader)) 3174 3 count = call_method("INC", G_ARRAY); 3175 else 3176 11 count = call_sv(loader, G_ARRAY); 3177 14 SPAGAIN; 3178 3179 14 if (count > 0) { 3180 14 int i = 0; 3181 14 SV *arg; 3182 3183 14 SP -= count - 1; 3184 14 arg = SP[i++]; 3185 3186 14 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) { 3187 11 arg = SvRV(arg); 3188 } 3189 3190 14 if (SvTYPE(arg) == SVt_PVGV) { 3191 11 IO *io = GvIO((GV *)arg); 3192 3193 11 ++filter_has_file; 3194 3195 11 if (io) { 3196 11 tryrsfp = IoIFP(io); 3197 11 if (IoTYPE(io) == IoTYPE_PIPE) { 3198 /* reading from a child process doesn't 3199 nest -- when returning from reading 3200 the inner module, the outer one is 3201 unreadable (closed?) I've tried to 3202 save the gv to manage the lifespan of 3203 the pipe, but this didn't help. XXX */ 3204 ###### filter_child_proc = (GV *)arg; 3205 ###### (void)SvREFCNT_inc(filter_child_proc); 3206 } 3207 else { 3208 11 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { 3209 ###### PerlIO_close(IoOFP(io)); 3210 } 3211 11 IoIFP(io) = Nullfp; 3212 11 IoOFP(io) = Nullfp; 3213 } 3214 } 3215 3216 11 if (i < count) { 3217 ###### arg = SP[i++]; 3218 } 3219 } 3220 3221 14 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) { 3222 ###### filter_sub = arg; 3223 ###### (void)SvREFCNT_inc(filter_sub); 3224 3225 ###### if (i < count) { 322