1 /* pp_ctl.c 2 * 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 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 * [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"] 20 */ 21 22 /* This file contains control-oriented pp ("push/pop") functions that 23 * execute the opcodes that make up a perl program. A typical pp function 24 * expects to find its arguments on the stack, and usually pushes its 25 * results onto the stack, hence the 'pp' terminology. Each OP structure 26 * contains a pointer to the relevant pp_foo() function. 27 * 28 * Control-oriented means things like pp_enteriter() and pp_next(), which 29 * alter the flow of control of the program. 30 */ 31 32 33 #include "EXTERN.h" 34 #define PERL_IN_PP_CTL_C 35 #include "perl.h" 36 37 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o)) 38 39 #define dopoptosub(plop) dopoptosub_at(cxstack, (plop)) 40 41 PP(pp_wantarray) 42 { 43 dVAR; 44 dSP; 45 I32 cxix; 46 const PERL_CONTEXT *cx; 47 EXTEND(SP, 1); 48 49 if (PL_op->op_private & OPpOFFBYONE) { 50 if (!(cx = caller_cx(1,NULL))) RETPUSHUNDEF; 51 } 52 else { 53 cxix = dopoptosub(cxstack_ix); 54 if (cxix < 0) 55 RETPUSHUNDEF; 56 cx = &cxstack[cxix]; 57 } 58 59 switch (cx->blk_gimme) { 60 case G_ARRAY: 61 RETPUSHYES; 62 case G_SCALAR: 63 RETPUSHNO; 64 default: 65 RETPUSHUNDEF; 66 } 67 } 68 69 PP(pp_regcreset) 70 { 71 dVAR; 72 TAINT_NOT; 73 return NORMAL; 74 } 75 76 PP(pp_regcomp) 77 { 78 dVAR; 79 dSP; 80 PMOP *pm = (PMOP*)cLOGOP->op_other; 81 SV **args; 82 int nargs; 83 REGEXP *re = NULL; 84 REGEXP *new_re; 85 const regexp_engine *eng; 86 bool is_bare_re= FALSE; 87 88 if (PL_op->op_flags & OPf_STACKED) { 89 dMARK; 90 nargs = SP - MARK; 91 args = ++MARK; 92 } 93 else { 94 nargs = 1; 95 args = SP; 96 } 97 98 /* prevent recompiling under /o and ithreads. */ 99 #if defined(USE_ITHREADS) 100 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) { 101 SP = args-1; 102 RETURN; 103 } 104 #endif 105 106 re = PM_GETRE(pm); 107 assert (re != (REGEXP*) &PL_sv_undef); 108 eng = re ? RX_ENGINE(re) : current_re_engine(); 109 110 /* 111 In the below logic: these are basically the same - check if this regcomp is part of a split. 112 113 (PL_op->op_pmflags & PMf_split ) 114 (PL_op->op_next->op_type == OP_PUSHRE) 115 116 We could add a new mask for this and copy the PMf_split, if we did 117 some bit definition fiddling first. 118 119 For now we leave this 120 */ 121 122 new_re = (eng->op_comp 123 ? eng->op_comp 124 : &Perl_re_op_compile 125 )(aTHX_ args, nargs, pm->op_code_list, eng, re, 126 &is_bare_re, 127 (pm->op_pmflags & RXf_PMf_FLAGCOPYMASK), 128 pm->op_pmflags | 129 (PL_op->op_flags & OPf_SPECIAL ? PMf_USE_RE_EVAL : 0)); 130 131 if (pm->op_pmflags & PMf_HAS_CV) 132 ReANY(new_re)->qr_anoncv 133 = (CV*) SvREFCNT_inc(PAD_SV(PL_op->op_targ)); 134 135 if (is_bare_re) { 136 REGEXP *tmp; 137 /* The match's LHS's get-magic might need to access this op's regexp 138 (e.g. $' =~ /$re/ while foo; see bug 70764). So we must call 139 get-magic now before we replace the regexp. Hopefully this hack can 140 be replaced with the approach described at 141 http://www.nntp.perl.org/group/perl.perl5.porters/2007/03/msg122415.html 142 some day. */ 143 if (pm->op_type == OP_MATCH) { 144 SV *lhs; 145 const bool was_tainted = TAINT_get; 146 if (pm->op_flags & OPf_STACKED) 147 lhs = args[-1]; 148 else if (pm->op_private & OPpTARGET_MY) 149 lhs = PAD_SV(pm->op_targ); 150 else lhs = DEFSV; 151 SvGETMAGIC(lhs); 152 /* Restore the previous value of PL_tainted (which may have been 153 modified by get-magic), to avoid incorrectly setting the 154 RXf_TAINTED flag with RX_TAINT_on further down. */ 155 TAINT_set(was_tainted); 156 #if NO_TAINT_SUPPORT 157 PERL_UNUSED_VAR(was_tainted); 158 #endif 159 } 160 tmp = reg_temp_copy(NULL, new_re); 161 ReREFCNT_dec(new_re); 162 new_re = tmp; 163 } 164 165 if (re != new_re) { 166 ReREFCNT_dec(re); 167 PM_SETRE(pm, new_re); 168 } 169 170 171 #ifndef INCOMPLETE_TAINTS 172 if (TAINTING_get && TAINT_get) { 173 SvTAINTED_on((SV*)new_re); 174 RX_TAINT_on(new_re); 175 } 176 #endif 177 178 #if !defined(USE_ITHREADS) 179 /* can't change the optree at runtime either */ 180 /* PMf_KEEP is handled differently under threads to avoid these problems */ 181 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm) 182 pm = PL_curpm; 183 if (pm->op_pmflags & PMf_KEEP) { 184 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */ 185 cLOGOP->op_first->op_next = PL_op->op_next; 186 } 187 #endif 188 189 SP = args-1; 190 RETURN; 191 } 192 193 194 PP(pp_substcont) 195 { 196 dVAR; 197 dSP; 198 PERL_CONTEXT *cx = &cxstack[cxstack_ix]; 199 PMOP * const pm = (PMOP*) cLOGOP->op_other; 200 SV * const dstr = cx->sb_dstr; 201 char *s = cx->sb_s; 202 char *m = cx->sb_m; 203 char *orig = cx->sb_orig; 204 REGEXP * const rx = cx->sb_rx; 205 SV *nsv = NULL; 206 REGEXP *old = PM_GETRE(pm); 207 208 PERL_ASYNC_CHECK(); 209 210 if(old != rx) { 211 if(old) 212 ReREFCNT_dec(old); 213 PM_SETRE(pm,ReREFCNT_inc(rx)); 214 } 215 216 rxres_restore(&cx->sb_rxres, rx); 217 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ)); 218 219 if (cx->sb_iters++) { 220 const I32 saviters = cx->sb_iters; 221 if (cx->sb_iters > cx->sb_maxiters) 222 DIE(aTHX_ "Substitution loop"); 223 224 SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */ 225 226 /* See "how taint works" above pp_subst() */ 227 if (SvTAINTED(TOPs)) 228 cx->sb_rxtainted |= SUBST_TAINT_REPL; 229 sv_catsv_nomg(dstr, POPs); 230 /* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */ 231 s -= RX_GOFS(rx); 232 233 /* Are we done */ 234 if (CxONCE(cx) || s < orig || 235 !CALLREGEXEC(rx, s, cx->sb_strend, orig, 236 (s == m) + RX_GOFS(rx), cx->sb_targ, NULL, 237 (REXEC_IGNOREPOS|REXEC_NOT_FIRST))) 238 { 239 SV *targ = cx->sb_targ; 240 241 assert(cx->sb_strend >= s); 242 if(cx->sb_strend > s) { 243 if (DO_UTF8(dstr) && !SvUTF8(targ)) 244 sv_catpvn_nomg_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv); 245 else 246 sv_catpvn_nomg(dstr, s, cx->sb_strend - s); 247 } 248 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */ 249 cx->sb_rxtainted |= SUBST_TAINT_PAT; 250 251 if (pm->op_pmflags & PMf_NONDESTRUCT) { 252 PUSHs(dstr); 253 /* From here on down we're using the copy, and leaving the 254 original untouched. */ 255 targ = dstr; 256 } 257 else { 258 if (SvIsCOW(targ)) { 259 sv_force_normal_flags(targ, SV_COW_DROP_PV); 260 } else 261 { 262 SvPV_free(targ); 263 } 264 SvPV_set(targ, SvPVX(dstr)); 265 SvCUR_set(targ, SvCUR(dstr)); 266 SvLEN_set(targ, SvLEN(dstr)); 267 if (DO_UTF8(dstr)) 268 SvUTF8_on(targ); 269 SvPV_set(dstr, NULL); 270 271 PL_tainted = 0; 272 mPUSHi(saviters - 1); 273 274 (void)SvPOK_only_UTF8(targ); 275 } 276 277 /* update the taint state of various various variables in 278 * preparation for final exit. 279 * See "how taint works" above pp_subst() */ 280 if (TAINTING_get) { 281 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) || 282 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) 283 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) 284 ) 285 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */ 286 287 if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET) 288 && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT)) 289 ) 290 SvTAINTED_on(TOPs); /* taint return value */ 291 /* needed for mg_set below */ 292 TAINT_set( 293 cBOOL(cx->sb_rxtainted & 294 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)) 295 ); 296 SvTAINT(TARG); 297 } 298 /* PL_tainted must be correctly set for this mg_set */ 299 SvSETMAGIC(TARG); 300 TAINT_NOT; 301 LEAVE_SCOPE(cx->sb_oldsave); 302 POPSUBST(cx); 303 PERL_ASYNC_CHECK(); 304 RETURNOP(pm->op_next); 305 assert(0); /* NOTREACHED */ 306 } 307 cx->sb_iters = saviters; 308 } 309 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) { 310 m = s; 311 s = orig; 312 assert(!RX_SUBOFFSET(rx)); 313 cx->sb_orig = orig = RX_SUBBEG(rx); 314 s = orig + (m - s); 315 cx->sb_strend = s + (cx->sb_strend - m); 316 } 317 cx->sb_m = m = RX_OFFS(rx)[0].start + orig; 318 if (m > s) { 319 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ)) 320 sv_catpvn_nomg_utf8_upgrade(dstr, s, m - s, nsv); 321 else 322 sv_catpvn_nomg(dstr, s, m-s); 323 } 324 cx->sb_s = RX_OFFS(rx)[0].end + orig; 325 { /* Update the pos() information. */ 326 SV * const sv 327 = (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ; 328 MAGIC *mg; 329 SvUPGRADE(sv, SVt_PVMG); 330 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) { 331 #ifdef PERL_OLD_COPY_ON_WRITE 332 if (SvIsCOW(sv)) 333 sv_force_normal_flags(sv, 0); 334 #endif 335 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob, 336 NULL, 0); 337 } 338 mg->mg_len = m - orig; 339 } 340 if (old != rx) 341 (void)ReREFCNT_inc(rx); 342 /* update the taint state of various various variables in preparation 343 * for calling the code block. 344 * See "how taint works" above pp_subst() */ 345 if (TAINTING_get) { 346 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */ 347 cx->sb_rxtainted |= SUBST_TAINT_PAT; 348 349 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) || 350 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) 351 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) 352 ) 353 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */ 354 355 if (cx->sb_iters > 1 && (cx->sb_rxtainted & 356 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))) 357 SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT) 358 ? cx->sb_dstr : cx->sb_targ); 359 TAINT_NOT; 360 } 361 rxres_save(&cx->sb_rxres, rx); 362 PL_curpm = pm; 363 RETURNOP(pm->op_pmstashstartu.op_pmreplstart); 364 } 365 366 void 367 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) 368 { 369 UV *p = (UV*)*rsp; 370 U32 i; 371 372 PERL_ARGS_ASSERT_RXRES_SAVE; 373 PERL_UNUSED_CONTEXT; 374 375 if (!p || p[1] < RX_NPARENS(rx)) { 376 #ifdef PERL_ANY_COW 377 i = 7 + (RX_NPARENS(rx)+1) * 2; 378 #else 379 i = 6 + (RX_NPARENS(rx)+1) * 2; 380 #endif 381 if (!p) 382 Newx(p, i, UV); 383 else 384 Renew(p, i, UV); 385 *rsp = (void*)p; 386 } 387 388 /* what (if anything) to free on croak */ 389 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL); 390 RX_MATCH_COPIED_off(rx); 391 *p++ = RX_NPARENS(rx); 392 393 #ifdef PERL_ANY_COW 394 *p++ = PTR2UV(RX_SAVED_COPY(rx)); 395 RX_SAVED_COPY(rx) = NULL; 396 #endif 397 398 *p++ = PTR2UV(RX_SUBBEG(rx)); 399 *p++ = (UV)RX_SUBLEN(rx); 400 *p++ = (UV)RX_SUBOFFSET(rx); 401 *p++ = (UV)RX_SUBCOFFSET(rx); 402 for (i = 0; i <= RX_NPARENS(rx); ++i) { 403 *p++ = (UV)RX_OFFS(rx)[i].start; 404 *p++ = (UV)RX_OFFS(rx)[i].end; 405 } 406 } 407 408 static void 409 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx) 410 { 411 UV *p = (UV*)*rsp; 412 U32 i; 413 414 PERL_ARGS_ASSERT_RXRES_RESTORE; 415 PERL_UNUSED_CONTEXT; 416 417 RX_MATCH_COPY_FREE(rx); 418 RX_MATCH_COPIED_set(rx, *p); 419 *p++ = 0; 420 RX_NPARENS(rx) = *p++; 421 422 #ifdef PERL_ANY_COW 423 if (RX_SAVED_COPY(rx)) 424 SvREFCNT_dec (RX_SAVED_COPY(rx)); 425 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p); 426 *p++ = 0; 427 #endif 428 429 RX_SUBBEG(rx) = INT2PTR(char*,*p++); 430 RX_SUBLEN(rx) = (I32)(*p++); 431 RX_SUBOFFSET(rx) = (I32)*p++; 432 RX_SUBCOFFSET(rx) = (I32)*p++; 433 for (i = 0; i <= RX_NPARENS(rx); ++i) { 434 RX_OFFS(rx)[i].start = (I32)(*p++); 435 RX_OFFS(rx)[i].end = (I32)(*p++); 436 } 437 } 438 439 static void 440 S_rxres_free(pTHX_ void **rsp) 441 { 442 UV * const p = (UV*)*rsp; 443 444 PERL_ARGS_ASSERT_RXRES_FREE; 445 PERL_UNUSED_CONTEXT; 446 447 if (p) { 448 void *tmp = INT2PTR(char*,*p); 449 #ifdef PERL_POISON 450 #ifdef PERL_ANY_COW 451 U32 i = 9 + p[1] * 2; 452 #else 453 U32 i = 8 + p[1] * 2; 454 #endif 455 #endif 456 457 #ifdef PERL_ANY_COW 458 SvREFCNT_dec (INT2PTR(SV*,p[2])); 459 #endif 460 #ifdef PERL_POISON 461 PoisonFree(p, i, sizeof(UV)); 462 #endif 463 464 Safefree(tmp); 465 Safefree(p); 466 *rsp = NULL; 467 } 468 } 469 470 #define FORM_NUM_BLANK (1<<30) 471 #define FORM_NUM_POINT (1<<29) 472 473 PP(pp_formline) 474 { 475 dVAR; dSP; dMARK; dORIGMARK; 476 SV * const tmpForm = *++MARK; 477 SV *formsv; /* contains text of original format */ 478 U32 *fpc; /* format ops program counter */ 479 char *t; /* current append position in target string */ 480 const char *f; /* current position in format string */ 481 I32 arg; 482 SV *sv = NULL; /* current item */ 483 const char *item = NULL;/* string value of current item */ 484 I32 itemsize = 0; /* length of current item, possibly truncated */ 485 I32 fieldsize = 0; /* width of current field */ 486 I32 lines = 0; /* number of lines that have been output */ 487 bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */ 488 const char *chophere = NULL; /* where to chop current item */ 489 STRLEN linemark = 0; /* pos of start of line in output */ 490 NV value; 491 bool gotsome = FALSE; /* seen at least one non-blank item on this line */ 492 STRLEN len; 493 STRLEN linemax; /* estimate of output size in bytes */ 494 bool item_is_utf8 = FALSE; 495 bool targ_is_utf8 = FALSE; 496 const char *fmt; 497 MAGIC *mg = NULL; 498 U8 *source; /* source of bytes to append */ 499 STRLEN to_copy; /* how may bytes to append */ 500 char trans; /* what chars to translate */ 501 502 mg = doparseform(tmpForm); 503 504 fpc = (U32*)mg->mg_ptr; 505 /* the actual string the format was compiled from. 506 * with overload etc, this may not match tmpForm */ 507 formsv = mg->mg_obj; 508 509 510 SvPV_force(PL_formtarget, len); 511 if (SvTAINTED(tmpForm) || SvTAINTED(formsv)) 512 SvTAINTED_on(PL_formtarget); 513 if (DO_UTF8(PL_formtarget)) 514 targ_is_utf8 = TRUE; 515 linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1); 516 t = SvGROW(PL_formtarget, len + linemax + 1); 517 /* XXX from now onwards, SvCUR(PL_formtarget) is invalid */ 518 t += len; 519 f = SvPV_const(formsv, len); 520 521 for (;;) { 522 DEBUG_f( { 523 const char *name = "???"; 524 arg = -1; 525 switch (*fpc) { 526 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break; 527 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break; 528 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break; 529 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break; 530 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break; 531 532 case FF_CHECKNL: name = "CHECKNL"; break; 533 case FF_CHECKCHOP: name = "CHECKCHOP"; break; 534 case FF_SPACE: name = "SPACE"; break; 535 case FF_HALFSPACE: name = "HALFSPACE"; break; 536 case FF_ITEM: name = "ITEM"; break; 537 case FF_CHOP: name = "CHOP"; break; 538 case FF_LINEGLOB: name = "LINEGLOB"; break; 539 case FF_NEWLINE: name = "NEWLINE"; break; 540 case FF_MORE: name = "MORE"; break; 541 case FF_LINEMARK: name = "LINEMARK"; break; 542 case FF_END: name = "END"; break; 543 case FF_0DECIMAL: name = "0DECIMAL"; break; 544 case FF_LINESNGL: name = "LINESNGL"; break; 545 } 546 if (arg >= 0) 547 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg); 548 else 549 PerlIO_printf(Perl_debug_log, "%-16s\n", name); 550 } ); 551 switch (*fpc++) { 552 case FF_LINEMARK: 553 linemark = t - SvPVX(PL_formtarget); 554 lines++; 555 gotsome = FALSE; 556 break; 557 558 case FF_LITERAL: 559 to_copy = *fpc++; 560 source = (U8 *)f; 561 f += to_copy; 562 trans = '~'; 563 item_is_utf8 = targ_is_utf8 ? !!DO_UTF8(formsv) : !!SvUTF8(formsv); 564 goto append; 565 566 case FF_SKIP: 567 f += *fpc++; 568 break; 569 570 case FF_FETCH: 571 arg = *fpc++; 572 f += arg; 573 fieldsize = arg; 574 575 if (MARK < SP) 576 sv = *++MARK; 577 else { 578 sv = &PL_sv_no; 579 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments"); 580 } 581 if (SvTAINTED(sv)) 582 SvTAINTED_on(PL_formtarget); 583 break; 584 585 case FF_CHECKNL: 586 { 587 const char *send; 588 const char *s = item = SvPV_const(sv, len); 589 itemsize = len; 590 if (DO_UTF8(sv)) { 591 itemsize = sv_len_utf8(sv); 592 if (itemsize != (I32)len) { 593 I32 itembytes; 594 if (itemsize > fieldsize) { 595 itemsize = fieldsize; 596 itembytes = itemsize; 597 sv_pos_u2b(sv, &itembytes, 0); 598 } 599 else 600 itembytes = len; 601 send = chophere = s + itembytes; 602 while (s < send) { 603 if (*s & ~31) 604 gotsome = TRUE; 605 else if (*s == '\n') 606 break; 607 s++; 608 } 609 item_is_utf8 = TRUE; 610 itemsize = s - item; 611 sv_pos_b2u(sv, &itemsize); 612 break; 613 } 614 } 615 item_is_utf8 = FALSE; 616 if (itemsize > fieldsize) 617 itemsize = fieldsize; 618 send = chophere = s + itemsize; 619 while (s < send) { 620 if (*s & ~31) 621 gotsome = TRUE; 622 else if (*s == '\n') 623 break; 624 s++; 625 } 626 itemsize = s - item; 627 break; 628 } 629 630 case FF_CHECKCHOP: 631 { 632 const char *s = item = SvPV_const(sv, len); 633 itemsize = len; 634 if (DO_UTF8(sv)) { 635 itemsize = sv_len_utf8(sv); 636 if (itemsize != (I32)len) { 637 I32 itembytes; 638 if (itemsize <= fieldsize) { 639 const char *send = chophere = s + itemsize; 640 while (s < send) { 641 if (*s == '\r') { 642 itemsize = s - item; 643 chophere = s; 644 break; 645 } 646 if (*s++ & ~31) 647 gotsome = TRUE; 648 } 649 } 650 else { 651 const char *send; 652 itemsize = fieldsize; 653 itembytes = itemsize; 654 sv_pos_u2b(sv, &itembytes, 0); 655 send = chophere = s + itembytes; 656 while (s < send || (s == send && isSPACE(*s))) { 657 if (isSPACE(*s)) { 658 if (chopspace) 659 chophere = s; 660 if (*s == '\r') 661 break; 662 } 663 else { 664 if (*s & ~31) 665 gotsome = TRUE; 666 if (strchr(PL_chopset, *s)) 667 chophere = s + 1; 668 } 669 s++; 670 } 671 itemsize = chophere - item; 672 sv_pos_b2u(sv, &itemsize); 673 } 674 item_is_utf8 = TRUE; 675 break; 676 } 677 } 678 item_is_utf8 = FALSE; 679 if (itemsize <= fieldsize) { 680 const char *const send = chophere = s + itemsize; 681 while (s < send) { 682 if (*s == '\r') { 683 itemsize = s - item; 684 chophere = s; 685 break; 686 } 687 if (*s++ & ~31) 688 gotsome = TRUE; 689 } 690 } 691 else { 692 const char *send; 693 itemsize = fieldsize; 694 send = chophere = s + itemsize; 695 while (s < send || (s == send && isSPACE(*s))) { 696 if (isSPACE(*s)) { 697 if (chopspace) 698 chophere = s; 699 if (*s == '\r') 700 break; 701 } 702 else { 703 if (*s & ~31) 704 gotsome = TRUE; 705 if (strchr(PL_chopset, *s)) 706 chophere = s + 1; 707 } 708 s++; 709 } 710 itemsize = chophere - item; 711 } 712 break; 713 } 714 715 case FF_SPACE: 716 arg = fieldsize - itemsize; 717 if (arg) { 718 fieldsize -= arg; 719 while (arg-- > 0) 720 *t++ = ' '; 721 } 722 break; 723 724 case FF_HALFSPACE: 725 arg = fieldsize - itemsize; 726 if (arg) { 727 arg /= 2; 728 fieldsize -= arg; 729 while (arg-- > 0) 730 *t++ = ' '; 731 } 732 break; 733 734 case FF_ITEM: 735 to_copy = itemsize; 736 source = (U8 *)item; 737 trans = 1; 738 if (item_is_utf8) { 739 /* convert to_copy from chars to bytes */ 740 U8 *s = source; 741 while (to_copy--) 742 s += UTF8SKIP(s); 743 to_copy = s - source; 744 } 745 goto append; 746 747 case FF_CHOP: 748 { 749 const char *s = chophere; 750 if (chopspace) { 751 while (isSPACE(*s)) 752 s++; 753 } 754 sv_chop(sv,s); 755 SvSETMAGIC(sv); 756 break; 757 } 758 759 case FF_LINESNGL: 760 chopspace = 0; 761 case FF_LINEGLOB: 762 { 763 const bool oneline = fpc[-1] == FF_LINESNGL; 764 const char *s = item = SvPV_const(sv, len); 765 const char *const send = s + len; 766 767 item_is_utf8 = DO_UTF8(sv); 768 if (!len) 769 break; 770 trans = 0; 771 gotsome = TRUE; 772 chophere = s + len; 773 source = (U8 *) s; 774 to_copy = len; 775 while (s < send) { 776 if (*s++ == '\n') { 777 if (oneline) { 778 to_copy = s - SvPVX_const(sv) - 1; 779 chophere = s; 780 break; 781 } else { 782 if (s == send) { 783 to_copy--; 784 } else 785 lines++; 786 } 787 } 788 } 789 } 790 791 append: 792 /* append to_copy bytes from source to PL_formstring. 793 * item_is_utf8 implies source is utf8. 794 * if trans, translate certain characters during the copy */ 795 { 796 U8 *tmp = NULL; 797 STRLEN grow = 0; 798 799 SvCUR_set(PL_formtarget, 800 t - SvPVX_const(PL_formtarget)); 801 802 if (targ_is_utf8 && !item_is_utf8) { 803 source = tmp = bytes_to_utf8(source, &to_copy); 804 } else { 805 if (item_is_utf8 && !targ_is_utf8) { 806 U8 *s; 807 /* Upgrade targ to UTF8, and then we reduce it to 808 a problem we have a simple solution for. 809 Don't need get magic. */ 810 sv_utf8_upgrade_nomg(PL_formtarget); 811 targ_is_utf8 = TRUE; 812 /* re-calculate linemark */ 813 s = (U8*)SvPVX(PL_formtarget); 814 /* the bytes we initially allocated to append the 815 * whole line may have been gobbled up during the 816 * upgrade, so allocate a whole new line's worth 817 * for safety */ 818 grow = linemax; 819 while (linemark--) 820 s += UTF8SKIP(s); 821 linemark = s - (U8*)SvPVX(PL_formtarget); 822 } 823 /* Easy. They agree. */ 824 assert (item_is_utf8 == targ_is_utf8); 825 } 826 if (!trans) 827 /* @* and ^* are the only things that can exceed 828 * the linemax, so grow by the output size, plus 829 * a whole new form's worth in case of any further 830 * output */ 831 grow = linemax + to_copy; 832 if (grow) 833 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + grow + 1); 834 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget); 835 836 Copy(source, t, to_copy, char); 837 if (trans) { 838 /* blank out ~ or control chars, depending on trans. 839 * works on bytes not chars, so relies on not 840 * matching utf8 continuation bytes */ 841 U8 *s = (U8*)t; 842 U8 *send = s + to_copy; 843 while (s < send) { 844 const int ch = *s; 845 if (trans == '~' ? (ch == '~') : 846 #ifdef EBCDIC 847 iscntrl(ch) 848 #else 849 (!(ch & ~31)) 850 #endif 851 ) 852 *s = ' '; 853 s++; 854 } 855 } 856 857 t += to_copy; 858 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy); 859 if (tmp) 860 Safefree(tmp); 861 break; 862 } 863 864 case FF_0DECIMAL: 865 arg = *fpc++; 866 #if defined(USE_LONG_DOUBLE) 867 fmt = (const char *) 868 ((arg & FORM_NUM_POINT) ? 869 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl); 870 #else 871 fmt = (const char *) 872 ((arg & FORM_NUM_POINT) ? 873 "%#0*.*f" : "%0*.*f"); 874 #endif 875 goto ff_dec; 876 case FF_DECIMAL: 877 arg = *fpc++; 878 #if defined(USE_LONG_DOUBLE) 879 fmt = (const char *) 880 ((arg & FORM_NUM_POINT) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl); 881 #else 882 fmt = (const char *) 883 ((arg & FORM_NUM_POINT) ? "%#*.*f" : "%*.*f"); 884 #endif 885 ff_dec: 886 /* If the field is marked with ^ and the value is undefined, 887 blank it out. */ 888 if ((arg & FORM_NUM_BLANK) && !SvOK(sv)) { 889 arg = fieldsize; 890 while (arg--) 891 *t++ = ' '; 892 break; 893 } 894 gotsome = TRUE; 895 value = SvNV(sv); 896 /* overflow evidence */ 897 if (num_overflow(value, fieldsize, arg)) { 898 arg = fieldsize; 899 while (arg--) 900 *t++ = '#'; 901 break; 902 } 903 /* Formats aren't yet marked for locales, so assume "yes". */ 904 { 905 STORE_NUMERIC_STANDARD_SET_LOCAL(); 906 arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK); 907 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg, value); 908 RESTORE_NUMERIC_STANDARD(); 909 } 910 t += fieldsize; 911 break; 912 913 case FF_NEWLINE: 914 f++; 915 while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ; 916 t++; 917 *t++ = '\n'; 918 break; 919 920 case FF_BLANK: 921 arg = *fpc++; 922 if (gotsome) { 923 if (arg) { /* repeat until fields exhausted? */ 924 fpc--; 925 goto end; 926 } 927 } 928 else { 929 t = SvPVX(PL_formtarget) + linemark; 930 lines--; 931 } 932 break; 933 934 case FF_MORE: 935 { 936 const char *s = chophere; 937 const char *send = item + len; 938 if (chopspace) { 939 while (isSPACE(*s) && (s < send)) 940 s++; 941 } 942 if (s < send) { 943 char *s1; 944 arg = fieldsize - itemsize; 945 if (arg) { 946 fieldsize -= arg; 947 while (arg-- > 0) 948 *t++ = ' '; 949 } 950 s1 = t - 3; 951 if (strnEQ(s1," ",3)) { 952 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1])) 953 s1--; 954 } 955 *s1++ = '.'; 956 *s1++ = '.'; 957 *s1++ = '.'; 958 } 959 break; 960 } 961 case FF_END: 962 end: 963 assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget)); 964 *t = '\0'; 965 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); 966 if (targ_is_utf8) 967 SvUTF8_on(PL_formtarget); 968 FmLINES(PL_formtarget) += lines; 969 SP = ORIGMARK; 970 if (fpc[-1] == FF_BLANK) 971 RETURNOP(cLISTOP->op_first); 972 else 973 RETPUSHYES; 974 } 975 } 976 } 977 978 PP(pp_grepstart) 979 { 980 dVAR; dSP; 981 SV *src; 982 983 if (PL_stack_base + *PL_markstack_ptr == SP) { 984 (void)POPMARK; 985 if (GIMME_V == G_SCALAR) 986 mXPUSHi(0); 987 RETURNOP(PL_op->op_next->op_next); 988 } 989 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1; 990 Perl_pp_pushmark(aTHX); /* push dst */ 991 Perl_pp_pushmark(aTHX); /* push src */ 992 ENTER_with_name("grep"); /* enter outer scope */ 993 994 SAVETMPS; 995 if (PL_op->op_private & OPpGREP_LEX) 996 SAVESPTR(PAD_SVl(PL_op->op_targ)); 997 else 998 SAVE_DEFSV; 999 ENTER_with_name("grep_item"); /* enter inner scope */ 1000 SAVEVPTR(PL_curpm); 1001 1002 src = PL_stack_base[*PL_markstack_ptr]; 1003 SvTEMP_off(src); 1004 if (PL_op->op_private & OPpGREP_LEX) 1005 PAD_SVl(PL_op->op_targ) = src; 1006 else 1007 DEFSV_set(src); 1008 1009 PUTBACK; 1010 if (PL_op->op_type == OP_MAPSTART) 1011 Perl_pp_pushmark(aTHX); /* push top */ 1012 return ((LOGOP*)PL_op->op_next)->op_other; 1013 } 1014 1015 PP(pp_mapwhile) 1016 { 1017 dVAR; dSP; 1018 const I32 gimme = GIMME_V; 1019 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */ 1020 I32 count; 1021 I32 shift; 1022 SV** src; 1023 SV** dst; 1024 1025 /* first, move source pointer to the next item in the source list */ 1026 ++PL_markstack_ptr[-1]; 1027 1028 /* if there are new items, push them into the destination list */ 1029 if (items && gimme != G_VOID) { 1030 /* might need to make room back there first */ 1031 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) { 1032 /* XXX this implementation is very pessimal because the stack 1033 * is repeatedly extended for every set of items. Is possible 1034 * to do this without any stack extension or copying at all 1035 * by maintaining a separate list over which the map iterates 1036 * (like foreach does). --gsar */ 1037 1038 /* everything in the stack after the destination list moves 1039 * towards the end the stack by the amount of room needed */ 1040 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]); 1041 1042 /* items to shift up (accounting for the moved source pointer) */ 1043 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1); 1044 1045 /* This optimization is by Ben Tilly and it does 1046 * things differently from what Sarathy (gsar) 1047 * is describing. The downside of this optimization is 1048 * that leaves "holes" (uninitialized and hopefully unused areas) 1049 * to the Perl stack, but on the other hand this 1050 * shouldn't be a problem. If Sarathy's idea gets 1051 * implemented, this optimization should become 1052 * irrelevant. --jhi */ 1053 if (shift < count) 1054 shift = count; /* Avoid shifting too often --Ben Tilly */ 1055 1056 EXTEND(SP,shift); 1057 src = SP; 1058 dst = (SP += shift); 1059 PL_markstack_ptr[-1] += shift; 1060 *PL_markstack_ptr += shift; 1061 while (count--) 1062 *dst-- = *src--; 1063 } 1064 /* copy the new items down to the destination list */ 1065 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1; 1066 if (gimme == G_ARRAY) { 1067 /* add returned items to the collection (making mortal copies 1068 * if necessary), then clear the current temps stack frame 1069 * *except* for those items. We do this splicing the items 1070 * into the start of the tmps frame (so some items may be on 1071 * the tmps stack twice), then moving PL_tmps_floor above 1072 * them, then freeing the frame. That way, the only tmps that 1073 * accumulate over iterations are the return values for map. 1074 * We have to do to this way so that everything gets correctly 1075 * freed if we die during the map. 1076 */ 1077 I32 tmpsbase; 1078 I32 i = items; 1079 /* make space for the slice */ 1080 EXTEND_MORTAL(items); 1081 tmpsbase = PL_tmps_floor + 1; 1082 Move(PL_tmps_stack + tmpsbase, 1083 PL_tmps_stack + tmpsbase + items, 1084 PL_tmps_ix - PL_tmps_floor, 1085 SV*); 1086 PL_tmps_ix += items; 1087 1088 while (i-- > 0) { 1089 SV *sv = POPs; 1090 if (!SvTEMP(sv)) 1091 sv = sv_mortalcopy(sv); 1092 *dst-- = sv; 1093 PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv); 1094 } 1095 /* clear the stack frame except for the items */ 1096 PL_tmps_floor += items; 1097 FREETMPS; 1098 /* FREETMPS may have cleared the TEMP flag on some of the items */ 1099 i = items; 1100 while (i-- > 0) 1101 SvTEMP_on(PL_tmps_stack[--tmpsbase]); 1102 } 1103 else { 1104 /* scalar context: we don't care about which values map returns 1105 * (we use undef here). And so we certainly don't want to do mortal 1106 * copies of meaningless values. */ 1107 while (items-- > 0) { 1108 (void)POPs; 1109 *dst-- = &PL_sv_undef; 1110 } 1111 FREETMPS; 1112 } 1113 } 1114 else { 1115 FREETMPS; 1116 } 1117 LEAVE_with_name("grep_item"); /* exit inner scope */ 1118 1119 /* All done yet? */ 1120 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) { 1121 1122 (void)POPMARK; /* pop top */ 1123 LEAVE_with_name("grep"); /* exit outer scope */ 1124 (void)POPMARK; /* pop src */ 1125 items = --*PL_markstack_ptr - PL_markstack_ptr[-1]; 1126 (void)POPMARK; /* pop dst */ 1127 SP = PL_stack_base + POPMARK; /* pop original mark */ 1128 if (gimme == G_SCALAR) { 1129 if (PL_op->op_private & OPpGREP_LEX) { 1130 SV* sv = sv_newmortal(); 1131 sv_setiv(sv, items); 1132 PUSHs(sv); 1133 } 1134 else { 1135 dTARGET; 1136 XPUSHi(items); 1137 } 1138 } 1139 else if (gimme == G_ARRAY) 1140 SP += items; 1141 RETURN; 1142 } 1143 else { 1144 SV *src; 1145 1146 ENTER_with_name("grep_item"); /* enter inner scope */ 1147 SAVEVPTR(PL_curpm); 1148 1149 /* set $_ to the new source item */ 1150 src = PL_stack_base[PL_markstack_ptr[-1]]; 1151 SvTEMP_off(src); 1152 if (PL_op->op_private & OPpGREP_LEX) 1153 PAD_SVl(PL_op->op_targ) = src; 1154 else 1155 DEFSV_set(src); 1156 1157 RETURNOP(cLOGOP->op_other); 1158 } 1159 } 1160 1161 /* Range stuff. */ 1162 1163 PP(pp_range) 1164 { 1165 dVAR; 1166 if (GIMME == G_ARRAY) 1167 return NORMAL; 1168 if (SvTRUEx(PAD_SV(PL_op->op_targ))) 1169 return cLOGOP->op_other; 1170 else 1171 return NORMAL; 1172 } 1173 1174 PP(pp_flip) 1175 { 1176 dVAR; 1177 dSP; 1178 1179 if (GIMME == G_ARRAY) { 1180 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other); 1181 } 1182 else { 1183 dTOPss; 1184 SV * const targ = PAD_SV(PL_op->op_targ); 1185 int flip = 0; 1186 1187 if (PL_op->op_private & OPpFLIP_LINENUM) { 1188 if (GvIO(PL_last_in_gv)) { 1189 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)); 1190 } 1191 else { 1192 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV); 1193 if (gv && GvSV(gv)) 1194 flip = SvIV(sv) == SvIV(GvSV(gv)); 1195 } 1196 } else { 1197 flip = SvTRUE(sv); 1198 } 1199 if (flip) { 1200 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1); 1201 if (PL_op->op_flags & OPf_SPECIAL) { 1202 sv_setiv(targ, 1); 1203 SETs(targ); 1204 RETURN; 1205 } 1206 else { 1207 sv_setiv(targ, 0); 1208 SP--; 1209 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other); 1210 } 1211 } 1212 sv_setpvs(TARG, ""); 1213 SETs(targ); 1214 RETURN; 1215 } 1216 } 1217 1218 /* This code tries to decide if "$left .. $right" should use the 1219 magical string increment, or if the range is numeric (we make 1220 an exception for .."0" [#18165]). AMS 20021031. */ 1221 1222 #define RANGE_IS_NUMERIC(left,right) ( \ 1223 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \ 1224 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \ 1225 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \ 1226 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \ 1227 && (!SvOK(right) || looks_like_number(right)))) 1228 1229 PP(pp_flop) 1230 { 1231 dVAR; dSP; 1232 1233 if (GIMME == G_ARRAY) { 1234 dPOPPOPssrl; 1235 1236 SvGETMAGIC(left); 1237 SvGETMAGIC(right); 1238 1239 if (RANGE_IS_NUMERIC(left,right)) { 1240 IV i, j; 1241 IV max; 1242 if ((SvOK(left) && SvNV_nomg(left) < IV_MIN) || 1243 (SvOK(right) && SvNV_nomg(right) > IV_MAX)) 1244 DIE(aTHX_ "Range iterator outside integer range"); 1245 i = SvIV_nomg(left); 1246 max = SvIV_nomg(right); 1247 if (max >= i) { 1248 j = max - i + 1; 1249 EXTEND_MORTAL(j); 1250 EXTEND(SP, j); 1251 } 1252 else 1253 j = 0; 1254 while (j--) { 1255 SV * const sv = sv_2mortal(newSViv(i++)); 1256 PUSHs(sv); 1257 } 1258 } 1259 else { 1260 STRLEN len, llen; 1261 const char * const lpv = SvPV_nomg_const(left, llen); 1262 const char * const tmps = SvPV_nomg_const(right, len); 1263 1264 SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP); 1265 while (!SvNIOKp(sv) && SvCUR(sv) <= len) { 1266 XPUSHs(sv); 1267 if (strEQ(SvPVX_const(sv),tmps)) 1268 break; 1269 sv = sv_2mortal(newSVsv(sv)); 1270 sv_inc(sv); 1271 } 1272 } 1273 } 1274 else { 1275 dTOPss; 1276 SV * const targ = PAD_SV(cUNOP->op_first->op_targ); 1277 int flop = 0; 1278 sv_inc(targ); 1279 1280 if (PL_op->op_private & OPpFLIP_LINENUM) { 1281 if (GvIO(PL_last_in_gv)) { 1282 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)); 1283 } 1284 else { 1285 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV); 1286 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv)); 1287 } 1288 } 1289 else { 1290 flop = SvTRUE(sv); 1291 } 1292 1293 if (flop) { 1294 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0); 1295 sv_catpvs(targ, "E0"); 1296 } 1297 SETs(targ); 1298 } 1299 1300 RETURN; 1301 } 1302 1303 /* Control. */ 1304 1305 static const char * const context_name[] = { 1306 "pseudo-block", 1307 NULL, /* CXt_WHEN never actually needs "block" */ 1308 NULL, /* CXt_BLOCK never actually needs "block" */ 1309 NULL, /* CXt_GIVEN never actually needs "block" */ 1310 NULL, /* CXt_LOOP_FOR never actually needs "loop" */ 1311 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */ 1312 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */ 1313 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */ 1314 "subroutine", 1315 "format", 1316 "eval", 1317 "substitution", 1318 }; 1319 1320 STATIC I32 1321 S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags) 1322 { 1323 dVAR; 1324 I32 i; 1325 1326 PERL_ARGS_ASSERT_DOPOPTOLABEL; 1327 1328 for (i = cxstack_ix; i >= 0; i--) { 1329 const PERL_CONTEXT * const cx = &cxstack[i]; 1330 switch (CxTYPE(cx)) { 1331 case CXt_SUBST: 1332 case CXt_SUB: 1333 case CXt_FORMAT: 1334 case CXt_EVAL: 1335 case CXt_NULL: 1336 /* diag_listed_as: Exiting subroutine via %s */ 1337 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s", 1338 context_name[CxTYPE(cx)], OP_NAME(PL_op)); 1339 if (CxTYPE(cx) == CXt_NULL) 1340 return -1; 1341 break; 1342 case CXt_LOOP_LAZYIV: 1343 case CXt_LOOP_LAZYSV: 1344 case CXt_LOOP_FOR: 1345 case CXt_LOOP_PLAIN: 1346 { 1347 STRLEN cx_label_len = 0; 1348 U32 cx_label_flags = 0; 1349 const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags); 1350 if (!cx_label || !( 1351 ( (cx_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ? 1352 (flags & SVf_UTF8) 1353 ? (bytes_cmp_utf8( 1354 (const U8*)cx_label, cx_label_len, 1355 (const U8*)label, len) == 0) 1356 : (bytes_cmp_utf8( 1357 (const U8*)label, len, 1358 (const U8*)cx_label, cx_label_len) == 0) 1359 : (len == cx_label_len && ((cx_label == label) 1360 || memEQ(cx_label, label, len))) )) { 1361 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n", 1362 (long)i, cx_label)); 1363 continue; 1364 } 1365 DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label)); 1366 return i; 1367 } 1368 } 1369 } 1370 return i; 1371 } 1372 1373 1374 1375 I32 1376 Perl_dowantarray(pTHX) 1377 { 1378 dVAR; 1379 const I32 gimme = block_gimme(); 1380 return (gimme == G_VOID) ? G_SCALAR : gimme; 1381 } 1382 1383 I32 1384 Perl_block_gimme(pTHX) 1385 { 1386 dVAR; 1387 const I32 cxix = dopoptosub(cxstack_ix); 1388 if (cxix < 0) 1389 return G_VOID; 1390 1391 switch (cxstack[cxix].blk_gimme) { 1392 case G_VOID: 1393 return G_VOID; 1394 case G_SCALAR: 1395 return G_SCALAR; 1396 case G_ARRAY: 1397 return G_ARRAY; 1398 default: 1399 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme); 1400 assert(0); /* NOTREACHED */ 1401 return 0; 1402 } 1403 } 1404 1405 I32 1406 Perl_is_lvalue_sub(pTHX) 1407 { 1408 dVAR; 1409 const I32 cxix = dopoptosub(cxstack_ix); 1410 assert(cxix >= 0); /* We should only be called from inside subs */ 1411 1412 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv)) 1413 return CxLVAL(cxstack + cxix); 1414 else 1415 return 0; 1416 } 1417 1418 /* only used by PUSHSUB */ 1419 I32 1420 Perl_was_lvalue_sub(pTHX) 1421 { 1422 dVAR; 1423 const I32 cxix = dopoptosub(cxstack_ix-1); 1424 assert(cxix >= 0); /* We should only be called from inside subs */ 1425 1426 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv)) 1427 return CxLVAL(cxstack + cxix); 1428 else 1429 return 0; 1430 } 1431 1432 STATIC I32 1433 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock) 1434 { 1435 dVAR; 1436 I32 i; 1437 1438 PERL_ARGS_ASSERT_DOPOPTOSUB_AT; 1439 1440 for (i = startingblock; i >= 0; i--) { 1441 const PERL_CONTEXT * const cx = &cxstk[i]; 1442 switch (CxTYPE(cx)) { 1443 default: 1444 continue; 1445 case CXt_SUB: 1446 /* in sub foo { /(?{...})/ }, foo ends up on the CX stack 1447 * twice; the first for the normal foo() call, and the second 1448 * for a faked up re-entry into the sub to execute the 1449 * code block. Hide this faked entry from the world. */ 1450 if (cx->cx_type & CXp_SUB_RE_FAKE) 1451 continue; 1452 case CXt_EVAL: 1453 case CXt_FORMAT: 1454 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i)); 1455 return i; 1456 } 1457 } 1458 return i; 1459 } 1460 1461 STATIC I32 1462 S_dopoptoeval(pTHX_ I32 startingblock) 1463 { 1464 dVAR; 1465 I32 i; 1466 for (i = startingblock; i >= 0; i--) { 1467 const PERL_CONTEXT *cx = &cxstack[i]; 1468 switch (CxTYPE(cx)) { 1469 default: 1470 continue; 1471 case CXt_EVAL: 1472 DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i)); 1473 return i; 1474 } 1475 } 1476 return i; 1477 } 1478 1479 STATIC I32 1480 S_dopoptoloop(pTHX_ I32 startingblock) 1481 { 1482 dVAR; 1483 I32 i; 1484 for (i = startingblock; i >= 0; i--) { 1485 const PERL_CONTEXT * const cx = &cxstack[i]; 1486 switch (CxTYPE(cx)) { 1487 case CXt_SUBST: 1488 case CXt_SUB: 1489 case CXt_FORMAT: 1490 case CXt_EVAL: 1491 case CXt_NULL: 1492 /* diag_listed_as: Exiting subroutine via %s */ 1493 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s", 1494 context_name[CxTYPE(cx)], OP_NAME(PL_op)); 1495 if ((CxTYPE(cx)) == CXt_NULL) 1496 return -1; 1497 break; 1498 case CXt_LOOP_LAZYIV: 1499 case CXt_LOOP_LAZYSV: 1500 case CXt_LOOP_FOR: 1501 case CXt_LOOP_PLAIN: 1502 DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i)); 1503 return i; 1504 } 1505 } 1506 return i; 1507 } 1508 1509 STATIC I32 1510 S_dopoptogiven(pTHX_ I32 startingblock) 1511 { 1512 dVAR; 1513 I32 i; 1514 for (i = startingblock; i >= 0; i--) { 1515 const PERL_CONTEXT *cx = &cxstack[i]; 1516 switch (CxTYPE(cx)) { 1517 default: 1518 continue; 1519 case CXt_GIVEN: 1520 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i)); 1521 return i; 1522 case CXt_LOOP_PLAIN: 1523 assert(!CxFOREACHDEF(cx)); 1524 break; 1525 case CXt_LOOP_LAZYIV: 1526 case CXt_LOOP_LAZYSV: 1527 case CXt_LOOP_FOR: 1528 if (CxFOREACHDEF(cx)) { 1529 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i)); 1530 return i; 1531 } 1532 } 1533 } 1534 return i; 1535 } 1536 1537 STATIC I32 1538 S_dopoptowhen(pTHX_ I32 startingblock) 1539 { 1540 dVAR; 1541 I32 i; 1542 for (i = startingblock; i >= 0; i--) { 1543 const PERL_CONTEXT *cx = &cxstack[i]; 1544 switch (CxTYPE(cx)) { 1545 default: 1546 continue; 1547 case CXt_WHEN: 1548 DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i)); 1549 return i; 1550 } 1551 } 1552 return i; 1553 } 1554 1555 void 1556 Perl_dounwind(pTHX_ I32 cxix) 1557 { 1558 dVAR; 1559 I32 optype; 1560 1561 if (!PL_curstackinfo) /* can happen if die during thread cloning */ 1562 return; 1563 1564 while (cxstack_ix > cxix) { 1565 SV *sv; 1566 PERL_CONTEXT *cx = &cxstack[cxstack_ix]; 1567 DEBUG_CX("UNWIND"); \ 1568 /* Note: we don't need to restore the base context info till the end. */ 1569 switch (CxTYPE(cx)) { 1570 case CXt_SUBST: 1571 POPSUBST(cx); 1572 continue; /* not break */ 1573 case CXt_SUB: 1574 POPSUB(cx,sv); 1575 LEAVESUB(sv); 1576 break; 1577 case CXt_EVAL: 1578 POPEVAL(cx); 1579 break; 1580 case CXt_LOOP_LAZYIV: 1581 case CXt_LOOP_LAZYSV: 1582 case CXt_LOOP_FOR: 1583 case CXt_LOOP_PLAIN: 1584 POPLOOP(cx); 1585 break; 1586 case CXt_NULL: 1587 break; 1588 case CXt_FORMAT: 1589 POPFORMAT(cx); 1590 break; 1591 } 1592 cxstack_ix--; 1593 } 1594 PERL_UNUSED_VAR(optype); 1595 } 1596 1597 void 1598 Perl_qerror(pTHX_ SV *err) 1599 { 1600 dVAR; 1601 1602 PERL_ARGS_ASSERT_QERROR; 1603 1604 if (PL_in_eval) { 1605 if (PL_in_eval & EVAL_KEEPERR) { 1606 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf, 1607 SVfARG(err)); 1608 } 1609 else 1610 sv_catsv(ERRSV, err); 1611 } 1612 else if (PL_errors) 1613 sv_catsv(PL_errors, err); 1614 else 1615 Perl_warn(aTHX_ "%"SVf, SVfARG(err)); 1616 if (PL_parser) 1617 ++PL_parser->error_count; 1618 } 1619 1620 void 1621 Perl_die_unwind(pTHX_ SV *msv) 1622 { 1623 dVAR; 1624 SV *exceptsv = sv_mortalcopy(msv); 1625 U8 in_eval = PL_in_eval; 1626 PERL_ARGS_ASSERT_DIE_UNWIND; 1627 1628 if (in_eval) { 1629 I32 cxix; 1630 I32 gimme; 1631 1632 /* 1633 * Historically, perl used to set ERRSV ($@) early in the die 1634 * process and rely on it not getting clobbered during unwinding. 1635 * That sucked, because it was liable to get clobbered, so the 1636 * setting of ERRSV used to emit the exception from eval{} has 1637 * been moved to much later, after unwinding (see just before 1638 * JMPENV_JUMP below). However, some modules were relying on the 1639 * early setting, by examining $@ during unwinding to use it as 1640 * a flag indicating whether the current unwinding was caused by 1641 * an exception. It was never a reliable flag for that purpose, 1642 * being totally open to false positives even without actual 1643 * clobberage, but was useful enough for production code to 1644 * semantically rely on it. 1645 * 1646 * We'd like to have a proper introspective interface that 1647 * explicitly describes the reason for whatever unwinding 1648 * operations are currently in progress, so that those modules 1649 * work reliably and $@ isn't further overloaded. But we don't 1650 * have one yet. In its absence, as a stopgap measure, ERRSV is 1651 * now *additionally* set here, before unwinding, to serve as the 1652 * (unreliable) flag that it used to. 1653 * 1654 * This behaviour is temporary, and should be removed when a 1655 * proper way to detect exceptional unwinding has been developed. 1656 * As of 2010-12, the authors of modules relying on the hack 1657 * are aware of the issue, because the modules failed on 1658 * perls 5.13.{1..7} which had late setting of $@ without this 1659 * early-setting hack. 1660 */ 1661 if (!(in_eval & EVAL_KEEPERR)) { 1662 SvTEMP_off(exceptsv); 1663 sv_setsv(ERRSV, exceptsv); 1664 } 1665 1666 if (in_eval & EVAL_KEEPERR) { 1667 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf, 1668 SVfARG(exceptsv)); 1669 } 1670 1671 while ((cxix = dopoptoeval(cxstack_ix)) < 0 1672 && PL_curstackinfo->si_prev) 1673 { 1674 dounwind(-1); 1675 POPSTACK; 1676 } 1677 1678 if (cxix >= 0) { 1679 I32 optype; 1680 SV *namesv; 1681 PERL_CONTEXT *cx; 1682 SV **newsp; 1683 COP *oldcop; 1684 JMPENV *restartjmpenv; 1685 OP *restartop; 1686 1687 if (cxix < cxstack_ix) 1688 dounwind(cxix); 1689 1690 POPBLOCK(cx,PL_curpm); 1691 if (CxTYPE(cx) != CXt_EVAL) { 1692 STRLEN msglen; 1693 const char* message = SvPVx_const(exceptsv, msglen); 1694 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11); 1695 PerlIO_write(Perl_error_log, message, msglen); 1696 my_exit(1); 1697 } 1698 POPEVAL(cx); 1699 namesv = cx->blk_eval.old_namesv; 1700 oldcop = cx->blk_oldcop; 1701 restartjmpenv = cx->blk_eval.cur_top_env; 1702 restartop = cx->blk_eval.retop; 1703 1704 if (gimme == G_SCALAR) 1705 *++newsp = &PL_sv_undef; 1706 PL_stack_sp = newsp; 1707 1708 LEAVE; 1709 1710 /* LEAVE could clobber PL_curcop (see save_re_context()) 1711 * XXX it might be better to find a way to avoid messing with 1712 * PL_curcop in save_re_context() instead, but this is a more 1713 * minimal fix --GSAR */ 1714 PL_curcop = oldcop; 1715 1716 if (optype == OP_REQUIRE) { 1717 (void)hv_store(GvHVn(PL_incgv), 1718 SvPVX_const(namesv), 1719 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv), 1720 &PL_sv_undef, 0); 1721 /* note that unlike pp_entereval, pp_require isn't 1722 * supposed to trap errors. So now that we've popped the 1723 * EVAL that pp_require pushed, and processed the error 1724 * message, rethrow the error */ 1725 Perl_croak(aTHX_ "%"SVf"Compilation failed in require", 1726 SVfARG(exceptsv ? exceptsv : newSVpvs_flags("Unknown error\n", 1727 SVs_TEMP))); 1728 } 1729 if (!(in_eval & EVAL_KEEPERR)) 1730 sv_setsv(ERRSV, exceptsv); 1731 PL_restartjmpenv = restartjmpenv; 1732 PL_restartop = restartop; 1733 JMPENV_JUMP(3); 1734 assert(0); /* NOTREACHED */ 1735 } 1736 } 1737 1738 write_to_stderr(exceptsv); 1739 my_failure_exit(); 1740 assert(0); /* NOTREACHED */ 1741 } 1742 1743 PP(pp_xor) 1744 { 1745 dVAR; dSP; dPOPTOPssrl; 1746 if (SvTRUE(left) != SvTRUE(right)) 1747 RETSETYES; 1748 else 1749 RETSETNO; 1750 } 1751 1752 /* 1753 =for apidoc caller_cx 1754 1755 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The 1756 returned C<PERL_CONTEXT> structure can be interrogated to find all the 1757 information returned to Perl by C<caller>. Note that XSUBs don't get a 1758 stack frame, so C<caller_cx(0, NULL)> will return information for the 1759 immediately-surrounding Perl code. 1760 1761 This function skips over the automatic calls to C<&DB::sub> made on the 1762 behalf of the debugger. If the stack frame requested was a sub called by 1763 C<DB::sub>, the return value will be the frame for the call to 1764 C<DB::sub>, since that has the correct line number/etc. for the call 1765 site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the 1766 frame for the sub call itself. 1767 1768 =cut 1769 */ 1770 1771 const PERL_CONTEXT * 1772 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp) 1773 { 1774 I32 cxix = dopoptosub(cxstack_ix); 1775 const PERL_CONTEXT *cx; 1776 const PERL_CONTEXT *ccstack = cxstack; 1777 const PERL_SI *top_si = PL_curstackinfo; 1778 1779 for (;;) { 1780 /* we may be in a higher stacklevel, so dig down deeper */ 1781 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) { 1782 top_si = top_si->si_prev; 1783 ccstack = top_si->si_cxstack; 1784 cxix = dopoptosub_at(ccstack, top_si->si_cxix); 1785 } 1786 if (cxix < 0) 1787 return NULL; 1788 /* caller() should not report the automatic calls to &DB::sub */ 1789 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 && 1790 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub)) 1791 count++; 1792 if (!count--) 1793 break; 1794 cxix = dopoptosub_at(ccstack, cxix - 1); 1795 } 1796 1797 cx = &ccstack[cxix]; 1798 if (dbcxp) *dbcxp = cx; 1799 1800 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { 1801 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1); 1802 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the 1803 field below is defined for any cx. */ 1804 /* caller() should not report the automatic calls to &DB::sub */ 1805 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) 1806 cx = &ccstack[dbcxix]; 1807 } 1808 1809 return cx; 1810 } 1811 1812 PP(pp_caller) 1813 { 1814 dVAR; 1815 dSP; 1816 const PERL_CONTEXT *cx; 1817 const PERL_CONTEXT *dbcx; 1818 I32 gimme; 1819 const HEK *stash_hek; 1820 I32 count = 0; 1821 bool has_arg = MAXARG && TOPs; 1822 1823 if (MAXARG) { 1824 if (has_arg) 1825 count = POPi; 1826 else (void)POPs; 1827 } 1828 1829 cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx); 1830 if (!cx) { 1831 if (GIMME != G_ARRAY) { 1832 EXTEND(SP, 1); 1833 RETPUSHUNDEF; 1834 } 1835 RETURN; 1836 } 1837 1838 DEBUG_CX("CALLER"); 1839 assert(CopSTASH(cx->blk_oldcop)); 1840 stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV 1841 ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop)) 1842 : NULL; 1843 if (GIMME != G_ARRAY) { 1844 EXTEND(SP, 1); 1845 if (!stash_hek) 1846 PUSHs(&PL_sv_undef); 1847 else { 1848 dTARGET; 1849 sv_sethek(TARG, stash_hek); 1850 PUSHs(TARG); 1851 } 1852 RETURN; 1853 } 1854 1855 EXTEND(SP, 11); 1856 1857 if (!stash_hek) 1858 PUSHs(&PL_sv_undef); 1859 else { 1860 dTARGET; 1861 sv_sethek(TARG, stash_hek); 1862 PUSHTARG; 1863 } 1864 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0)); 1865 mPUSHi((I32)CopLINE(cx->blk_oldcop)); 1866 if (!has_arg) 1867 RETURN; 1868 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { 1869 GV * const cvgv = CvGV(dbcx->blk_sub.cv); 1870 /* So is ccstack[dbcxix]. */ 1871 if (cvgv && isGV(cvgv)) { 1872 SV * const sv = newSV(0); 1873 gv_efullname3(sv, cvgv, NULL); 1874 mPUSHs(sv); 1875 PUSHs(boolSV(CxHASARGS(cx))); 1876 } 1877 else { 1878 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP)); 1879 PUSHs(boolSV(CxHASARGS(cx))); 1880 } 1881 } 1882 else { 1883 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP)); 1884 mPUSHi(0); 1885 } 1886 gimme = (I32)cx->blk_gimme; 1887 if (gimme == G_VOID) 1888 PUSHs(&PL_sv_undef); 1889 else 1890 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY)); 1891 if (CxTYPE(cx) == CXt_EVAL) { 1892 /* eval STRING */ 1893 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) { 1894 PUSHs(newSVpvn_flags(SvPVX(cx->blk_eval.cur_text), 1895 SvCUR(cx->blk_eval.cur_text)-2, 1896 SvUTF8(cx->blk_eval.cur_text)|SVs_TEMP)); 1897 PUSHs(&PL_sv_no); 1898 } 1899 /* require */ 1900 else if (cx->blk_eval.old_namesv) { 1901 mPUSHs(newSVsv(cx->blk_eval.old_namesv)); 1902 PUSHs(&PL_sv_yes); 1903 } 1904 /* eval BLOCK (try blocks have old_namesv == 0) */ 1905 else { 1906 PUSHs(&PL_sv_undef); 1907 PUSHs(&PL_sv_undef); 1908 } 1909 } 1910 else { 1911 PUSHs(&PL_sv_undef); 1912 PUSHs(&PL_sv_undef); 1913 } 1914 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx) 1915 && CopSTASH_eq(PL_curcop, PL_debstash)) 1916 { 1917 AV * const ary = cx->blk_sub.argarray; 1918 const int off = AvARRAY(ary) - AvALLOC(ary); 1919 1920 Perl_init_dbargs(aTHX); 1921 1922 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off) 1923 av_extend(PL_dbargs, AvFILLp(ary) + off); 1924 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*); 1925 AvFILLp(PL_dbargs) = AvFILLp(ary) + off; 1926 } 1927 mPUSHi(CopHINTS_get(cx->blk_oldcop)); 1928 { 1929 SV * mask ; 1930 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ; 1931 1932 if (old_warnings == pWARN_NONE) 1933 mask = newSVpvn(WARN_NONEstring, WARNsize) ; 1934 else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0) 1935 mask = &PL_sv_undef ; 1936 else if (old_warnings == pWARN_ALL || 1937 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) { 1938 /* Get the bit mask for $warnings::Bits{all}, because 1939 * it could have been extended by warnings::register */ 1940 SV **bits_all; 1941 HV * const bits = get_hv("warnings::Bits", 0); 1942 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) { 1943 mask = newSVsv(*bits_all); 1944 } 1945 else { 1946 mask = newSVpvn(WARN_ALLstring, WARNsize) ; 1947 } 1948 } 1949 else 1950 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]); 1951 mPUSHs(mask); 1952 } 1953 1954 PUSHs(cx->blk_oldcop->cop_hints_hash ? 1955 sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0)))) 1956 : &PL_sv_undef); 1957 RETURN; 1958 } 1959 1960 PP(pp_reset) 1961 { 1962 dVAR; 1963 dSP; 1964 const char * tmps; 1965 STRLEN len = 0; 1966 if (MAXARG < 1 || (!TOPs && !POPs)) 1967 tmps = NULL, len = 0; 1968 else 1969 tmps = SvPVx_const(POPs, len); 1970 sv_resetpvn(tmps, len, CopSTASH(PL_curcop)); 1971 PUSHs(&PL_sv_yes); 1972 RETURN; 1973 } 1974 1975 /* like pp_nextstate, but used instead when the debugger is active */ 1976 1977 PP(pp_dbstate) 1978 { 1979 dVAR; 1980 PL_curcop = (COP*)PL_op; 1981 TAINT_NOT; /* Each statement is presumed innocent */ 1982 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp; 1983 FREETMPS; 1984 1985 PERL_ASYNC_CHECK(); 1986 1987 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */ 1988 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace)) 1989 { 1990 dSP; 1991 PERL_CONTEXT *cx; 1992 const I32 gimme = G_ARRAY; 1993 U8 hasargs; 1994 GV * const gv = PL_DBgv; 1995 CV * cv = NULL; 1996 1997 if (gv && isGV_with_GP(gv)) 1998 cv = GvCV(gv); 1999 2000 if (!cv || (!CvROOT(cv) && !CvXSUB(cv))) 2001 DIE(aTHX_ "No DB::DB routine defined"); 2002 2003 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG)) 2004 /* don't do recursive DB::DB call */ 2005 return NORMAL; 2006 2007 ENTER; 2008 SAVETMPS; 2009 2010 SAVEI32(PL_debug); 2011 SAVESTACK_POS(); 2012 PL_debug = 0; 2013 hasargs = 0; 2014 SPAGAIN; 2015 2016 if (CvISXSUB(cv)) { 2017 PUSHMARK(SP); 2018 (void)(*CvXSUB(cv))(aTHX_ cv); 2019 FREETMPS; 2020 LEAVE; 2021 return NORMAL; 2022 } 2023 else { 2024 PUSHBLOCK(cx, CXt_SUB, SP); 2025 PUSHSUB_DB(cx); 2026 cx->blk_sub.retop = PL_op->op_next; 2027 CvDEPTH(cv)++; 2028 if (CvDEPTH(cv) >= 2) { 2029 PERL_STACK_OVERFLOW_CHECK(); 2030 pad_push(CvPADLIST(cv), CvDEPTH(cv)); 2031 } 2032 SAVECOMPPAD(); 2033 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv)); 2034 RETURNOP(CvSTART(cv)); 2035 } 2036 } 2037 else 2038 return NORMAL; 2039 } 2040 2041 STATIC SV ** 2042 S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 flags) 2043 { 2044 bool padtmp = 0; 2045 PERL_ARGS_ASSERT_ADJUST_STACK_ON_LEAVE; 2046 2047 if (flags & SVs_PADTMP) { 2048 flags &= ~SVs_PADTMP; 2049 padtmp = 1; 2050 } 2051 if (gimme == G_SCALAR) { 2052 if (MARK < SP) 2053 *++newsp = ((SvFLAGS(*SP) & flags) || (padtmp && SvPADTMP(*SP))) 2054 ? *SP : sv_mortalcopy(*SP); 2055 else { 2056 /* MEXTEND() only updates MARK, so reuse it instead of newsp. */ 2057 MARK = newsp; 2058 MEXTEND(MARK, 1); 2059 *++MARK = &PL_sv_undef; 2060 return MARK; 2061 } 2062 } 2063 else if (gimme == G_ARRAY) { 2064 /* in case LEAVE wipes old return values */ 2065 while (++MARK <= SP) { 2066 if ((SvFLAGS(*MARK) & flags) || (padtmp && SvPADTMP(*MARK))) 2067 *++newsp = *MARK; 2068 else { 2069 *++newsp = sv_mortalcopy(*MARK); 2070 TAINT_NOT; /* Each item is independent */ 2071 } 2072 } 2073 /* When this function was called with MARK == newsp, we reach this 2074 * point with SP == newsp. */ 2075 } 2076 2077 return newsp; 2078 } 2079 2080 PP(pp_enter) 2081 { 2082 dVAR; dSP; 2083 PERL_CONTEXT *cx; 2084 I32 gimme = GIMME_V; 2085 2086 ENTER_with_name("block"); 2087 2088 SAVETMPS; 2089 PUSHBLOCK(cx, CXt_BLOCK, SP); 2090 2091 RETURN; 2092 } 2093 2094 PP(pp_leave) 2095 { 2096 dVAR; dSP; 2097 PERL_CONTEXT *cx; 2098 SV **newsp; 2099 PMOP *newpm; 2100 I32 gimme; 2101 2102 if (PL_op->op_flags & OPf_SPECIAL) { 2103 cx = &cxstack[cxstack_ix]; 2104 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */ 2105 } 2106 2107 POPBLOCK(cx,newpm); 2108 2109 gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR); 2110 2111 TAINT_NOT; 2112 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP); 2113 PL_curpm = newpm; /* Don't pop $1 et al till now */ 2114 2115 LEAVE_with_name("block"); 2116 2117 RETURN; 2118 } 2119 2120 PP(pp_enteriter) 2121 { 2122 dVAR; dSP; dMARK; 2123 PERL_CONTEXT *cx; 2124 const I32 gimme = GIMME_V; 2125 void *itervar; /* location of the iteration variable */ 2126 U8 cxtype = CXt_LOOP_FOR; 2127 2128 ENTER_with_name("loop1"); 2129 SAVETMPS; 2130 2131 if (PL_op->op_targ) { /* "my" variable */ 2132 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */ 2133 SvPADSTALE_off(PAD_SVl(PL_op->op_targ)); 2134 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ), 2135 SVs_PADSTALE, SVs_PADSTALE); 2136 } 2137 SAVEPADSVANDMORTALIZE(PL_op->op_targ); 2138 #ifdef USE_ITHREADS 2139 itervar = PL_comppad; 2140 #else 2141 itervar = &PAD_SVl(PL_op->op_targ); 2142 #endif 2143 } 2144 else { /* symbol table variable */ 2145 GV * const gv = MUTABLE_GV(POPs); 2146 SV** svp = &GvSV(gv); 2147 save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV); 2148 *svp = newSV(0); 2149 itervar = (void *)gv; 2150 } 2151 2152 if (PL_op->op_private & OPpITER_DEF) 2153 cxtype |= CXp_FOR_DEF; 2154 2155 ENTER_with_name("loop2"); 2156 2157 PUSHBLOCK(cx, cxtype, SP); 2158 PUSHLOOP_FOR(cx, itervar, MARK); 2159 if (PL_op->op_flags & OPf_STACKED) { 2160 SV *maybe_ary = POPs; 2161 if (SvTYPE(maybe_ary) != SVt_PVAV) { 2162 dPOPss; 2163 SV * const right = maybe_ary; 2164 SvGETMAGIC(sv); 2165 SvGETMAGIC(right); 2166 if (RANGE_IS_NUMERIC(sv,right)) { 2167 cx->cx_type &= ~CXTYPEMASK; 2168 cx->cx_type |= CXt_LOOP_LAZYIV; 2169 /* Make sure that no-one re-orders cop.h and breaks our 2170 assumptions */ 2171 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV); 2172 #ifdef NV_PRESERVES_UV 2173 if ((SvOK(sv) && ((SvNV_nomg(sv) < (NV)IV_MIN) || 2174 (SvNV_nomg(sv) > (NV)IV_MAX))) 2175 || 2176 (SvOK(right) && ((SvNV_nomg(right) > (NV)IV_MAX) || 2177 (SvNV_nomg(right) < (NV)IV_MIN)))) 2178 #else 2179 if ((SvOK(sv) && ((SvNV_nomg(sv) <= (NV)IV_MIN) 2180 || 2181 ((SvNV_nomg(sv) > 0) && 2182 ((SvUV_nomg(sv) > (UV)IV_MAX) || 2183 (SvNV_nomg(sv) > (NV)UV_MAX))))) 2184 || 2185 (SvOK(right) && ((SvNV_nomg(right) <= (NV)IV_MIN) 2186 || 2187 ((SvNV_nomg(right) > 0) && 2188 ((SvUV_nomg(right) > (UV)IV_MAX) || 2189 (SvNV_nomg(right) > (NV)UV_MAX)) 2190 )))) 2191 #endif 2192 DIE(aTHX_ "Range iterator outside integer range"); 2193 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv); 2194 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right); 2195 #ifdef DEBUGGING 2196 /* for correct -Dstv display */ 2197 cx->blk_oldsp = sp - PL_stack_base; 2198 #endif 2199 } 2200 else { 2201 cx->cx_type &= ~CXTYPEMASK; 2202 cx->cx_type |= CXt_LOOP_LAZYSV; 2203 /* Make sure that no-one re-orders cop.h and breaks our 2204 assumptions */ 2205 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV); 2206 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv); 2207 cx->blk_loop.state_u.lazysv.end = right; 2208 SvREFCNT_inc(right); 2209 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur); 2210 /* This will do the upgrade to SVt_PV, and warn if the value 2211 is uninitialised. */ 2212 (void) SvPV_nolen_const(right); 2213 /* Doing this avoids a check every time in pp_iter in pp_hot.c 2214 to replace !SvOK() with a pointer to "". */ 2215 if (!SvOK(right)) { 2216 SvREFCNT_dec(right); 2217 cx->blk_loop.state_u.lazysv.end = &PL_sv_no; 2218 } 2219 } 2220 } 2221 else /* SvTYPE(maybe_ary) == SVt_PVAV */ { 2222 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary); 2223 SvREFCNT_inc(maybe_ary); 2224 cx->blk_loop.state_u.ary.ix = 2225 (PL_op->op_private & OPpITER_REVERSED) ? 2226 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 : 2227 -1; 2228 } 2229 } 2230 else { /* iterating over items on the stack */ 2231 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */ 2232 if (PL_op->op_private & OPpITER_REVERSED) { 2233 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1; 2234 } 2235 else { 2236 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base; 2237 } 2238 } 2239 2240 RETURN; 2241 } 2242 2243 PP(pp_enterloop) 2244 { 2245 dVAR; dSP; 2246 PERL_CONTEXT *cx; 2247 const I32 gimme = GIMME_V; 2248 2249 ENTER_with_name("loop1"); 2250 SAVETMPS; 2251 ENTER_with_name("loop2"); 2252 2253 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP); 2254 PUSHLOOP_PLAIN(cx, SP); 2255 2256 RETURN; 2257 } 2258 2259 PP(pp_leaveloop) 2260 { 2261 dVAR; dSP; 2262 PERL_CONTEXT *cx; 2263 I32 gimme; 2264 SV **newsp; 2265 PMOP *newpm; 2266 SV **mark; 2267 2268 POPBLOCK(cx,newpm); 2269 assert(CxTYPE_is_LOOP(cx)); 2270 mark = newsp; 2271 newsp = PL_stack_base + cx->blk_loop.resetsp; 2272 2273 TAINT_NOT; 2274 SP = adjust_stack_on_leave(newsp, SP, MARK, gimme, 0); 2275 PUTBACK; 2276 2277 POPLOOP(cx); /* Stack values are safe: release loop vars ... */ 2278 PL_curpm = newpm; /* ... and pop $1 et al */ 2279 2280 LEAVE_with_name("loop2"); 2281 LEAVE_with_name("loop1"); 2282 2283 return NORMAL; 2284 } 2285 2286 STATIC void 2287 S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme, 2288 PERL_CONTEXT *cx, PMOP *newpm) 2289 { 2290 const bool ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS); 2291 if (gimme == G_SCALAR) { 2292 if (CxLVAL(cx) && !ref) { /* Leave it as it is if we can. */ 2293 SV *sv; 2294 const char *what = NULL; 2295 if (MARK < SP) { 2296 assert(MARK+1 == SP); 2297 if ((SvPADTMP(TOPs) || 2298 (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE)) 2299 == SVf_READONLY 2300 ) && 2301 !SvSMAGICAL(TOPs)) { 2302 what = 2303 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef" 2304 : "a readonly value" : "a temporary"; 2305 } 2306 else goto copy_sv; 2307 } 2308 else { 2309 /* sub:lvalue{} will take us here. */ 2310 what = "undef"; 2311 } 2312 LEAVE; 2313 cxstack_ix--; 2314 POPSUB(cx,sv); 2315 PL_curpm = newpm; 2316 LEAVESUB(sv); 2317 Perl_croak(aTHX_ 2318 "Can't return %s from lvalue subroutine", what 2319 ); 2320 } 2321 if (MARK < SP) { 2322 copy_sv: 2323 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) { 2324 if (!SvPADTMP(*SP)) { 2325 *++newsp = SvREFCNT_inc(*SP); 2326 FREETMPS; 2327 sv_2mortal(*newsp); 2328 } 2329 else { 2330 /* FREETMPS could clobber it */ 2331 SV *sv = SvREFCNT_inc(*SP); 2332 FREETMPS; 2333 *++newsp = sv_mortalcopy(sv); 2334 SvREFCNT_dec(sv); 2335 } 2336 } 2337 else 2338 *++newsp = 2339 SvPADTMP(*SP) 2340 ? sv_mortalcopy(*SP) 2341 : !SvTEMP(*SP) 2342 ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP)) 2343 : *SP; 2344 } 2345 else { 2346 EXTEND(newsp,1); 2347 *++newsp = &PL_sv_undef; 2348 } 2349 if (CxLVAL(cx) & OPpDEREF) { 2350 SvGETMAGIC(TOPs); 2351 if (!SvOK(TOPs)) { 2352 TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF); 2353 } 2354 } 2355 } 2356 else if (gimme == G_ARRAY) { 2357 assert (!(CxLVAL(cx) & OPpDEREF)); 2358 if (ref || !CxLVAL(cx)) 2359 while (++MARK <= SP) 2360 *++newsp = 2361 SvFLAGS(*MARK) & SVs_PADTMP 2362 ? sv_mortalcopy(*MARK) 2363 : SvTEMP(*MARK) 2364 ? *MARK 2365 : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK)); 2366 else while (++MARK <= SP) { 2367 if (*MARK != &PL_sv_undef 2368 && (SvPADTMP(*MARK) 2369 || (SvFLAGS(*MARK) & (SVf_READONLY|SVf_FAKE)) 2370 == SVf_READONLY 2371 ) 2372 ) { 2373 SV *sv; 2374 /* Might be flattened array after $#array = */ 2375 PUTBACK; 2376 LEAVE; 2377 cxstack_ix--; 2378 POPSUB(cx,sv); 2379 PL_curpm = newpm; 2380 LEAVESUB(sv); 2381 /* diag_listed_as: Can't return %s from lvalue subroutine */ 2382 Perl_croak(aTHX_ 2383 "Can't return a %s from lvalue subroutine", 2384 SvREADONLY(TOPs) ? "readonly value" : "temporary"); 2385 } 2386 else 2387 *++newsp = 2388 SvTEMP(*MARK) 2389 ? *MARK 2390 : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK)); 2391 } 2392 } 2393 PL_stack_sp = newsp; 2394 } 2395 2396 PP(pp_return) 2397 { 2398 dVAR; dSP; dMARK; 2399 PERL_CONTEXT *cx; 2400 bool popsub2 = FALSE; 2401 bool clear_errsv = FALSE; 2402 bool lval = FALSE; 2403 I32 gimme; 2404 SV **newsp; 2405 PMOP *newpm; 2406 I32 optype = 0; 2407 SV *namesv; 2408 SV *sv; 2409 OP *retop = NULL; 2410 2411 const I32 cxix = dopoptosub(cxstack_ix); 2412 2413 if (cxix < 0) { 2414 if (CxMULTICALL(cxstack)) { /* In this case we must be in a 2415 * sort block, which is a CXt_NULL 2416 * not a CXt_SUB */ 2417 dounwind(0); 2418 PL_stack_base[1] = *PL_stack_sp; 2419 PL_stack_sp = PL_stack_base + 1; 2420 return 0; 2421 } 2422 else 2423 DIE(aTHX_ "Can't return outside a subroutine"); 2424 } 2425 if (cxix < cxstack_ix) 2426 dounwind(cxix); 2427 2428 if (CxMULTICALL(&cxstack[cxix])) { 2429 gimme = cxstack[cxix].blk_gimme; 2430 if (gimme == G_VOID) 2431 PL_stack_sp = PL_stack_base; 2432 else if (gimme == G_SCALAR) { 2433 PL_stack_base[1] = *PL_stack_sp; 2434 PL_stack_sp = PL_stack_base + 1; 2435 } 2436 return 0; 2437 } 2438 2439 POPBLOCK(cx,newpm); 2440 switch (CxTYPE(cx)) { 2441 case CXt_SUB: 2442 popsub2 = TRUE; 2443 lval = !!CvLVALUE(cx->blk_sub.cv); 2444 retop = cx->blk_sub.retop; 2445 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */ 2446 break; 2447 case CXt_EVAL: 2448 if (!(PL_in_eval & EVAL_KEEPERR)) 2449 clear_errsv = TRUE; 2450 POPEVAL(cx); 2451 namesv = cx->blk_eval.old_namesv; 2452 retop = cx->blk_eval.retop; 2453 if (CxTRYBLOCK(cx)) 2454 break; 2455 if (optype == OP_REQUIRE && 2456 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) ) 2457 { 2458 /* Unassume the success we assumed earlier. */ 2459 (void)hv_delete(GvHVn(PL_incgv), 2460 SvPVX_const(namesv), 2461 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv), 2462 G_DISCARD); 2463 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv)); 2464 } 2465 break; 2466 case CXt_FORMAT: 2467 POPFORMAT(cx); 2468 retop = cx->blk_sub.retop; 2469 break; 2470 default: 2471 DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx)); 2472 } 2473 2474 TAINT_NOT; 2475 if (lval) S_return_lvalues(aTHX_ MARK, SP, newsp, gimme, cx, newpm); 2476 else { 2477 if (gimme == G_SCALAR) { 2478 if (MARK < SP) { 2479 if (popsub2) { 2480 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) { 2481 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1 2482 && !SvMAGICAL(TOPs)) { 2483 *++newsp = SvREFCNT_inc(*SP); 2484 FREETMPS; 2485 sv_2mortal(*newsp); 2486 } 2487 else { 2488 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */ 2489 FREETMPS; 2490 *++newsp = sv_mortalcopy(sv); 2491 SvREFCNT_dec(sv); 2492 } 2493 } 2494 else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1 2495 && !SvMAGICAL(*SP)) { 2496 *++newsp = *SP; 2497 } 2498 else 2499 *++newsp = sv_mortalcopy(*SP); 2500 } 2501 else 2502 *++newsp = sv_mortalcopy(*SP); 2503 } 2504 else 2505 *++newsp = &PL_sv_undef; 2506 } 2507 else if (gimme == G_ARRAY) { 2508 while (++MARK <= SP) { 2509 *++newsp = popsub2 && SvTEMP(*MARK) && SvREFCNT(*MARK) == 1 2510 && !SvGMAGICAL(*MARK) 2511 ? *MARK : sv_mortalcopy(*MARK); 2512 TAINT_NOT; /* Each item is independent */ 2513 } 2514 } 2515 PL_stack_sp = newsp; 2516 } 2517 2518 LEAVE; 2519 /* Stack values are safe: */ 2520 if (popsub2) { 2521 cxstack_ix--; 2522 POPSUB(cx,sv); /* release CV and @_ ... */ 2523 } 2524 else 2525 sv = NULL; 2526 PL_curpm = newpm; /* ... and pop $1 et al */ 2527 2528 LEAVESUB(sv); 2529 if (clear_errsv) { 2530 CLEAR_ERRSV(); 2531 } 2532 return retop; 2533 } 2534 2535 /* This duplicates parts of pp_leavesub, so that it can share code with 2536 * pp_return */ 2537 PP(pp_leavesublv) 2538 { 2539 dVAR; dSP; 2540 SV **newsp; 2541 PMOP *newpm; 2542 I32 gimme; 2543 PERL_CONTEXT *cx; 2544 SV *sv; 2545 2546 if (CxMULTICALL(&cxstack[cxstack_ix])) 2547 return 0; 2548 2549 POPBLOCK(cx,newpm); 2550 cxstack_ix++; /* temporarily protect top context */ 2551 2552 TAINT_NOT; 2553 2554 S_return_lvalues(aTHX_ newsp, SP, newsp, gimme, cx, newpm); 2555 2556 LEAVE; 2557 cxstack_ix--; 2558 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */ 2559 PL_curpm = newpm; /* ... and pop $1 et al */ 2560 2561 LEAVESUB(sv); 2562 return cx->blk_sub.retop; 2563 } 2564 2565 static I32 2566 S_unwind_loop(pTHX_ const char * const opname) 2567 { 2568 dVAR; 2569 I32 cxix; 2570 if (PL_op->op_flags & OPf_SPECIAL) { 2571 cxix = dopoptoloop(cxstack_ix); 2572 if (cxix < 0) 2573 /* diag_listed_as: Can't "last" outside a loop block */ 2574 Perl_croak(aTHX_ "Can't \"%s\" outside a loop block", opname); 2575 } 2576 else { 2577 dSP; 2578 STRLEN label_len; 2579 const char * const label = 2580 PL_op->op_flags & OPf_STACKED 2581 ? SvPV(TOPs,label_len) 2582 : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv); 2583 const U32 label_flags = 2584 PL_op->op_flags & OPf_STACKED 2585 ? SvUTF8(POPs) 2586 : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0; 2587 PUTBACK; 2588 cxix = dopoptolabel(label, label_len, label_flags); 2589 if (cxix < 0) 2590 /* diag_listed_as: Label not found for "last %s" */ 2591 Perl_croak(aTHX_ "Label not found for \"%s %"SVf"\"", 2592 opname, 2593 SVfARG(PL_op->op_flags & OPf_STACKED 2594 && !SvGMAGICAL(TOPp1s) 2595 ? TOPp1s 2596 : newSVpvn_flags(label, 2597 label_len, 2598 label_flags | SVs_TEMP))); 2599 } 2600 if (cxix < cxstack_ix) 2601 dounwind(cxix); 2602 return cxix; 2603 } 2604 2605 PP(pp_last) 2606 { 2607 dVAR; 2608 PERL_CONTEXT *cx; 2609 I32 pop2 = 0; 2610 I32 gimme; 2611 I32 optype; 2612 OP *nextop = NULL; 2613 SV **newsp; 2614 PMOP *newpm; 2615 SV **mark; 2616 SV *sv = NULL; 2617 2618 S_unwind_loop(aTHX_ "last"); 2619 2620 POPBLOCK(cx,newpm); 2621 cxstack_ix++; /* temporarily protect top context */ 2622 mark = newsp; 2623 switch (CxTYPE(cx)) { 2624 case CXt_LOOP_LAZYIV: 2625 case CXt_LOOP_LAZYSV: 2626 case CXt_LOOP_FOR: 2627 case CXt_LOOP_PLAIN: 2628 pop2 = CxTYPE(cx); 2629 newsp = PL_stack_base + cx->blk_loop.resetsp; 2630 nextop = cx->blk_loop.my_op->op_lastop->op_next; 2631 break; 2632 case CXt_SUB: 2633 pop2 = CXt_SUB; 2634 nextop = cx->blk_sub.retop; 2635 break; 2636 case CXt_EVAL: 2637 POPEVAL(cx); 2638 nextop = cx->blk_eval.retop; 2639 break; 2640 case CXt_FORMAT: 2641 POPFORMAT(cx); 2642 nextop = cx->blk_sub.retop; 2643 break; 2644 default: 2645 DIE(aTHX_ "panic: last, type=%u", (unsigned) CxTYPE(cx)); 2646 } 2647 2648 TAINT_NOT; 2649 PL_stack_sp = adjust_stack_on_leave(newsp, PL_stack_sp, MARK, gimme, 2650 pop2 == CXt_SUB ? SVs_TEMP : 0); 2651 2652 LEAVE; 2653 cxstack_ix--; 2654 /* Stack values are safe: */ 2655 switch (pop2) { 2656 case CXt_LOOP_LAZYIV: 2657 case CXt_LOOP_PLAIN: 2658 case CXt_LOOP_LAZYSV: 2659 case CXt_LOOP_FOR: 2660 POPLOOP(cx); /* release loop vars ... */ 2661 LEAVE; 2662 break; 2663 case CXt_SUB: 2664 POPSUB(cx,sv); /* release CV and @_ ... */ 2665 break; 2666 } 2667 PL_curpm = newpm; /* ... and pop $1 et al */ 2668 2669 LEAVESUB(sv); 2670 PERL_UNUSED_VAR(optype); 2671 PERL_UNUSED_VAR(gimme); 2672 return nextop; 2673 } 2674 2675 PP(pp_next) 2676 { 2677 dVAR; 2678 PERL_CONTEXT *cx; 2679 const I32 inner = PL_scopestack_ix; 2680 2681 S_unwind_loop(aTHX_ "next"); 2682 2683 /* clear off anything above the scope we're re-entering, but 2684 * save the rest until after a possible continue block */ 2685 TOPBLOCK(cx); 2686 if (PL_scopestack_ix < inner) 2687 leave_scope(PL_scopestack[PL_scopestack_ix]); 2688 PL_curcop = cx->blk_oldcop; 2689 PERL_ASYNC_CHECK(); 2690 return (cx)->blk_loop.my_op->op_nextop; 2691 } 2692 2693 PP(pp_redo) 2694 { 2695 dVAR; 2696 const I32 cxix = S_unwind_loop(aTHX_ "redo"); 2697 PERL_CONTEXT *cx; 2698 I32 oldsave; 2699 OP* redo_op = cxstack[cxix].blk_loop.my_op->op_redoop; 2700 2701 if (redo_op->op_type == OP_ENTER) { 2702 /* pop one less context to avoid $x being freed in while (my $x..) */ 2703 cxstack_ix++; 2704 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK); 2705 redo_op = redo_op->op_next; 2706 } 2707 2708 TOPBLOCK(cx); 2709 oldsave = PL_scopestack[PL_scopestack_ix - 1]; 2710 LEAVE_SCOPE(oldsave); 2711 FREETMPS; 2712 PL_curcop = cx->blk_oldcop; 2713 PERL_ASYNC_CHECK(); 2714 return redo_op; 2715 } 2716 2717 STATIC OP * 2718 S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit) 2719 { 2720 dVAR; 2721 OP **ops = opstack; 2722 static const char* const too_deep = "Target of goto is too deeply nested"; 2723 2724 PERL_ARGS_ASSERT_DOFINDLABEL; 2725 2726 if (ops >= oplimit) 2727 Perl_croak(aTHX_ "%s", too_deep); 2728 if (o->op_type == OP_LEAVE || 2729 o->op_type == OP_SCOPE || 2730 o->op_type == OP_LEAVELOOP || 2731 o->op_type == OP_LEAVESUB || 2732 o->op_type == OP_LEAVETRY) 2733 { 2734 *ops++ = cUNOPo->op_first; 2735 if (ops >= oplimit) 2736 Perl_croak(aTHX_ "%s", too_deep); 2737 } 2738 *ops = 0; 2739 if (o->op_flags & OPf_KIDS) { 2740 OP *kid; 2741 /* First try all the kids at this level, since that's likeliest. */ 2742 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { 2743 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) { 2744 STRLEN kid_label_len; 2745 U32 kid_label_flags; 2746 const char *kid_label = CopLABEL_len_flags(kCOP, 2747 &kid_label_len, &kid_label_flags); 2748 if (kid_label && ( 2749 ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ? 2750 (flags & SVf_UTF8) 2751 ? (bytes_cmp_utf8( 2752 (const U8*)kid_label, kid_label_len, 2753 (const U8*)label, len) == 0) 2754 : (bytes_cmp_utf8( 2755 (const U8*)label, len, 2756 (const U8*)kid_label, kid_label_len) == 0) 2757 : ( len == kid_label_len && ((kid_label == label) 2758 || memEQ(kid_label, label, len))))) 2759 return kid; 2760 } 2761 } 2762 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { 2763 if (kid == PL_lastgotoprobe) 2764 continue; 2765 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) { 2766 if (ops == opstack) 2767 *ops++ = kid; 2768 else if (ops[-1]->op_type == OP_NEXTSTATE || 2769 ops[-1]->op_type == OP_DBSTATE) 2770 ops[-1] = kid; 2771 else 2772 *ops++ = kid; 2773 } 2774 if ((o = dofindlabel(kid, label, len, flags, ops, oplimit))) 2775 return o; 2776 } 2777 } 2778 *ops = 0; 2779 return 0; 2780 } 2781 2782 PP(pp_goto) 2783 { 2784 dVAR; dSP; 2785 OP *retop = NULL; 2786 I32 ix; 2787 PERL_CONTEXT *cx; 2788 #define GOTO_DEPTH 64 2789 OP *enterops[GOTO_DEPTH]; 2790 const char *label = NULL; 2791 STRLEN label_len = 0; 2792 U32 label_flags = 0; 2793 const bool do_dump = (PL_op->op_type == OP_DUMP); 2794 static const char* const must_have_label = "goto must have label"; 2795 2796 if (PL_op->op_flags & OPf_STACKED) { 2797 SV * const sv = POPs; 2798 SvGETMAGIC(sv); 2799 2800 /* This egregious kludge implements goto &subroutine */ 2801 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) { 2802 I32 cxix; 2803 PERL_CONTEXT *cx; 2804 CV *cv = MUTABLE_CV(SvRV(sv)); 2805 AV *arg = GvAV(PL_defgv); 2806 I32 oldsave; 2807 2808 retry: 2809 if (!CvROOT(cv) && !CvXSUB(cv)) { 2810 const GV * const gv = CvGV(cv); 2811 if (gv) { 2812 GV *autogv; 2813 SV *tmpstr; 2814 /* autoloaded stub? */ 2815 if (cv != GvCV(gv) && (cv = GvCV(gv))) 2816 goto retry; 2817 autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), 2818 GvNAMELEN(gv), 2819 GvNAMEUTF8(gv) ? SVf_UTF8 : 0); 2820 if (autogv && (cv = GvCV(autogv))) 2821 goto retry; 2822 tmpstr = sv_newmortal(); 2823 gv_efullname3(tmpstr, gv, NULL); 2824 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr)); 2825 } 2826 DIE(aTHX_ "Goto undefined subroutine"); 2827 } 2828 2829 /* First do some returnish stuff. */ 2830 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */ 2831 FREETMPS; 2832 cxix = dopoptosub(cxstack_ix); 2833 if (cxix < cxstack_ix) { 2834 if (cxix < 0) { 2835 SvREFCNT_dec(cv); 2836 DIE(aTHX_ "Can't goto subroutine outside a subroutine"); 2837 } 2838 dounwind(cxix); 2839 } 2840 TOPBLOCK(cx); 2841 SPAGAIN; 2842 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */ 2843 if (CxTYPE(cx) == CXt_EVAL) { 2844 SvREFCNT_dec(cv); 2845 if (CxREALEVAL(cx)) 2846 /* diag_listed_as: Can't goto subroutine from an eval-%s */ 2847 DIE(aTHX_ "Can't goto subroutine from an eval-string"); 2848 else 2849 /* diag_listed_as: Can't goto subroutine from an eval-%s */ 2850 DIE(aTHX_ "Can't goto subroutine from an eval-block"); 2851 } 2852 else if (CxMULTICALL(cx)) 2853 { 2854 SvREFCNT_dec(cv); 2855 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)"); 2856 } 2857 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) { 2858 AV* av = cx->blk_sub.argarray; 2859 2860 /* abandon the original @_ if it got reified or if it is 2861 the same as the current @_ */ 2862 if (AvREAL(av) || av == arg) { 2863 SvREFCNT_dec(av); 2864 av = newAV(); 2865 AvREIFY_only(av); 2866 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av); 2867 } 2868 else CLEAR_ARGARRAY(av); 2869 } 2870 /* We donate this refcount later to the callee’s pad. */ 2871 SvREFCNT_inc_simple_void(arg); 2872 if (CxTYPE(cx) == CXt_SUB && 2873 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth)) 2874 SvREFCNT_dec(cx->blk_sub.cv); 2875 oldsave = PL_scopestack[PL_scopestack_ix - 1]; 2876 LEAVE_SCOPE(oldsave); 2877 2878 /* A destructor called during LEAVE_SCOPE could have undefined 2879 * our precious cv. See bug #99850. */ 2880 if (!CvROOT(cv) && !CvXSUB(cv)) { 2881 const GV * const gv = CvGV(cv); 2882 SvREFCNT_dec(arg); 2883 if (gv) { 2884 SV * const tmpstr = sv_newmortal(); 2885 gv_efullname3(tmpstr, gv, NULL); 2886 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", 2887 SVfARG(tmpstr)); 2888 } 2889 DIE(aTHX_ "Goto undefined subroutine"); 2890 } 2891 2892 /* Now do some callish stuff. */ 2893 SAVETMPS; 2894 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */ 2895 if (CvISXSUB(cv)) { 2896 OP* const retop = cx->blk_sub.retop; 2897 SV **newsp; 2898 I32 gimme; 2899 const SSize_t items = AvFILLp(arg) + 1; 2900 SV** mark; 2901 2902 PERL_UNUSED_VAR(newsp); 2903 PERL_UNUSED_VAR(gimme); 2904 2905 /* put GvAV(defgv) back onto stack */ 2906 EXTEND(SP, items+1); /* @_ could have been extended. */ 2907 Copy(AvARRAY(arg), SP + 1, items, SV*); 2908 mark = SP; 2909 SP += items; 2910 if (AvREAL(arg)) { 2911 I32 index; 2912 for (index=0; index<items; index++) 2913 SvREFCNT_inc_void(sv_2mortal(SP[-index])); 2914 } 2915 SvREFCNT_dec(arg); 2916 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) { 2917 /* Restore old @_ */ 2918 arg = GvAV(PL_defgv); 2919 GvAV(PL_defgv) = cx->blk_sub.savearray; 2920 SvREFCNT_dec(arg); 2921 } 2922 2923 /* XS subs don't have a CxSUB, so pop it */ 2924 POPBLOCK(cx, PL_curpm); 2925 /* Push a mark for the start of arglist */ 2926 PUSHMARK(mark); 2927 PUTBACK; 2928 (void)(*CvXSUB(cv))(aTHX_ cv); 2929 LEAVE; 2930 PERL_ASYNC_CHECK(); 2931 return retop; 2932 } 2933 else { 2934 PADLIST * const padlist = CvPADLIST(cv); 2935 cx->blk_sub.cv = cv; 2936 cx->blk_sub.olddepth = CvDEPTH(cv); 2937 2938 CvDEPTH(cv)++; 2939 if (CvDEPTH(cv) < 2) 2940 SvREFCNT_inc_simple_void_NN(cv); 2941 else { 2942 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)) 2943 sub_crush_depth(cv); 2944 pad_push(padlist, CvDEPTH(cv)); 2945 } 2946 PL_curcop = cx->blk_oldcop; 2947 SAVECOMPPAD(); 2948 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); 2949 if (CxHASARGS(cx)) 2950 { 2951 CX_CURPAD_SAVE(cx->blk_sub); 2952 2953 /* cx->blk_sub.argarray has no reference count, so we 2954 need something to hang on to our argument array so 2955 that cx->blk_sub.argarray does not end up pointing 2956 to freed memory as the result of undef *_. So put 2957 it in the callee’s pad, donating our refer- 2958 ence count. */ 2959 SvREFCNT_dec(PAD_SVl(0)); 2960 PAD_SVl(0) = (SV *)(cx->blk_sub.argarray = arg); 2961 2962 /* GvAV(PL_defgv) might have been modified on scope 2963 exit, so restore it. */ 2964 if (arg != GvAV(PL_defgv)) { 2965 AV * const av = GvAV(PL_defgv); 2966 GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg); 2967 SvREFCNT_dec(av); 2968 } 2969 } 2970 else SvREFCNT_dec(arg); 2971 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */ 2972 Perl_get_db_sub(aTHX_ NULL, cv); 2973 if (PERLDB_GOTO) { 2974 CV * const gotocv = get_cvs("DB::goto", 0); 2975 if (gotocv) { 2976 PUSHMARK( PL_stack_sp ); 2977 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG); 2978 PL_stack_sp--; 2979 } 2980 } 2981 } 2982 PERL_ASYNC_CHECK(); 2983 RETURNOP(CvSTART(cv)); 2984 } 2985 } 2986 else { 2987 label = SvPV_nomg_const(sv, label_len); 2988 label_flags = SvUTF8(sv); 2989 } 2990 } 2991 else if (!(PL_op->op_flags & OPf_SPECIAL)) { 2992 label = cPVOP->op_pv; 2993 label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0; 2994 label_len = strlen(label); 2995 } 2996 if (!(do_dump || label_len)) DIE(aTHX_ "%s", must_have_label); 2997 2998 PERL_ASYNC_CHECK(); 2999 3000 if (label_len) { 3001 OP *gotoprobe = NULL; 3002 bool leaving_eval = FALSE; 3003 bool in_block = FALSE; 3004 PERL_CONTEXT *last_eval_cx = NULL; 3005 3006 /* find label */ 3007 3008 PL_lastgotoprobe = NULL; 3009 *enterops = 0; 3010 for (ix = cxstack_ix; ix >= 0; ix--) { 3011 cx = &cxstack[ix]; 3012 switch (CxTYPE(cx)) { 3013 case CXt_EVAL: 3014 leaving_eval = TRUE; 3015 if (!CxTRYBLOCK(cx)) { 3016 gotoprobe = (last_eval_cx ? 3017 last_eval_cx->blk_eval.old_eval_root : 3018 PL_eval_root); 3019 last_eval_cx = cx; 3020 break; 3021 } 3022 /* else fall through */ 3023 case CXt_LOOP_LAZYIV: 3024 case CXt_LOOP_LAZYSV: 3025 case CXt_LOOP_FOR: 3026 case CXt_LOOP_PLAIN: 3027 case CXt_GIVEN: 3028 case CXt_WHEN: 3029 gotoprobe = cx->blk_oldcop->op_sibling; 3030 break; 3031 case CXt_SUBST: 3032 continue; 3033 case CXt_BLOCK: 3034 if (ix) { 3035 gotoprobe = cx->blk_oldcop->op_sibling; 3036 in_block = TRUE; 3037 } else 3038 gotoprobe = PL_main_root; 3039 break; 3040 case CXt_SUB: 3041 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) { 3042 gotoprobe = CvROOT(cx->blk_sub.cv); 3043 break; 3044 } 3045 /* FALL THROUGH */ 3046 case CXt_FORMAT: 3047 case CXt_NULL: 3048 DIE(aTHX_ "Can't \"goto\" out of a pseudo block"); 3049 default: 3050 if (ix) 3051 DIE(aTHX_ "panic: goto, type=%u, ix=%ld", 3052 CxTYPE(cx), (long) ix); 3053 gotoprobe = PL_main_root; 3054 break; 3055 } 3056 if (gotoprobe) { 3057 retop = dofindlabel(gotoprobe, label, label_len, label_flags, 3058 enterops, enterops + GOTO_DEPTH); 3059 if (retop) 3060 break; 3061 if (gotoprobe->op_sibling && 3062 gotoprobe->op_sibling->op_type == OP_UNSTACK && 3063 gotoprobe->op_sibling->op_sibling) { 3064 retop = dofindlabel(gotoprobe->op_sibling->op_sibling, 3065 label, label_len, label_flags, enterops, 3066 enterops + GOTO_DEPTH); 3067 if (retop) 3068 break; 3069 } 3070 } 3071 PL_lastgotoprobe = gotoprobe; 3072 } 3073 if (!retop) 3074 DIE(aTHX_ "Can't find label %"SVf, 3075 SVfARG(newSVpvn_flags(label, label_len, 3076 SVs_TEMP | label_flags))); 3077 3078 /* if we're leaving an eval, check before we pop any frames 3079 that we're not going to punt, otherwise the error 3080 won't be caught */ 3081 3082 if (leaving_eval && *enterops && enterops[1]) { 3083 I32 i; 3084 for (i = 1; enterops[i]; i++) 3085 if (enterops[i]->op_type == OP_ENTERITER) 3086 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop"); 3087 } 3088 3089 if (*enterops && enterops[1]) { 3090 I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1; 3091 if (enterops[i]) 3092 deprecate("\"goto\" to jump into a construct"); 3093 } 3094 3095 /* pop unwanted frames */ 3096 3097 if (ix < cxstack_ix) { 3098 I32 oldsave; 3099 3100 if (ix < 0) 3101 ix = 0; 3102 dounwind(ix); 3103 TOPBLOCK(cx); 3104 oldsave = PL_scopestack[PL_scopestack_ix]; 3105 LEAVE_SCOPE(oldsave); 3106 } 3107 3108 /* push wanted frames */ 3109 3110 if (*enterops && enterops[1]) { 3111 OP * const oldop = PL_op; 3112 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1; 3113 for (; enterops[ix]; ix++) { 3114 PL_op = enterops[ix]; 3115 /* Eventually we may want to stack the needed arguments 3116 * for each op. For now, we punt on the hard ones. */ 3117 if (PL_op->op_type == OP_ENTERITER) 3118 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop"); 3119 PL_op->op_ppaddr(aTHX); 3120 } 3121 PL_op = oldop; 3122 } 3123 } 3124 3125 if (do_dump) { 3126 #ifdef VMS 3127 if (!retop) retop = PL_main_start; 3128 #endif 3129 PL_restartop = retop; 3130 PL_do_undump = TRUE; 3131 3132 my_unexec(); 3133 3134 PL_restartop = 0; /* hmm, must be GNU unexec().. */ 3135 PL_do_undump = FALSE; 3136 } 3137 3138 PERL_ASYNC_CHECK(); 3139 RETURNOP(retop); 3140 } 3141 3142 PP(pp_exit) 3143 { 3144 dVAR; 3145 dSP; 3146 I32 anum; 3147 3148 if (MAXARG < 1) 3149 anum = 0; 3150 else if (!TOPs) { 3151 anum = 0; (void)POPs; 3152 } 3153 else { 3154 anum = SvIVx(POPs); 3155 #ifdef VMS 3156 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH)) 3157 anum = 0; 3158 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH); 3159 #endif 3160 } 3161 PL_exit_flags |= PERL_EXIT_EXPECTED; 3162 #ifdef PERL_MAD 3163 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */ 3164 if (anum || !(PL_minus_c && PL_madskills)) 3165 my_exit(anum); 3166 #else 3167 my_exit(anum); 3168 #endif 3169 PUSHs(&PL_sv_undef); 3170 RETURN; 3171 } 3172 3173 /* Eval. */ 3174 3175 STATIC void 3176 S_save_lines(pTHX_ AV *array, SV *sv) 3177 { 3178 const char *s = SvPVX_const(sv); 3179 const char * const send = SvPVX_const(sv) + SvCUR(sv); 3180 I32 line = 1; 3181 3182 PERL_ARGS_ASSERT_SAVE_LINES; 3183 3184 while (s && s < send) { 3185 const char *t; 3186 SV * const tmpstr = newSV_type(SVt_PVMG); 3187 3188 t = (const char *)memchr(s, '\n', send - s); 3189 if (t) 3190 t++; 3191 else 3192 t = send; 3193 3194 sv_setpvn(tmpstr, s, t - s); 3195 av_store(array, line++, tmpstr); 3196 s = t; 3197 } 3198 } 3199 3200 /* 3201 =for apidoc docatch 3202 3203 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context. 3204 3205 0 is used as continue inside eval, 3206 3207 3 is used for a die caught by an inner eval - continue inner loop 3208 3209 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must 3210 establish a local jmpenv to handle exception traps. 3211 3212 =cut 3213 */ 3214 STATIC OP * 3215 S_docatch(pTHX_ OP *o) 3216 { 3217 dVAR; 3218 int ret; 3219 OP * const oldop = PL_op; 3220 dJMPENV; 3221 3222 #ifdef DEBUGGING 3223 assert(CATCH_GET == TRUE); 3224 #endif 3225 PL_op = o; 3226 3227 JMPENV_PUSH(ret); 3228 switch (ret) { 3229 case 0: 3230 assert(cxstack_ix >= 0); 3231 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL); 3232 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env; 3233 redo_body: 3234 CALLRUNOPS(aTHX); 3235 break; 3236 case 3: 3237 /* die caught by an inner eval - continue inner loop */ 3238 if (PL_restartop && PL_restartjmpenv == PL_top_env) { 3239 PL_restartjmpenv = NULL; 3240 PL_op = PL_restartop; 3241 PL_restartop = 0; 3242 goto redo_body; 3243 } 3244 /* FALL THROUGH */ 3245 default: 3246 JMPENV_POP; 3247 PL_op = oldop; 3248 JMPENV_JUMP(ret); 3249 assert(0); /* NOTREACHED */ 3250 } 3251 JMPENV_POP; 3252 PL_op = oldop; 3253 return NULL; 3254 } 3255 3256 3257 /* 3258 =for apidoc find_runcv 3259 3260 Locate the CV corresponding to the currently executing sub or eval. 3261 If db_seqp is non_null, skip CVs that are in the DB package and populate 3262 *db_seqp with the cop sequence number at the point that the DB:: code was 3263 entered. (allows debuggers to eval in the scope of the breakpoint rather 3264 than in the scope of the debugger itself). 3265 3266 =cut 3267 */ 3268 3269 CV* 3270 Perl_find_runcv(pTHX_ U32 *db_seqp) 3271 { 3272 return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp); 3273 } 3274 3275 /* If this becomes part of the API, it might need a better name. */ 3276 CV * 3277 Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp) 3278 { 3279 dVAR; 3280 PERL_SI *si; 3281 int level = 0; 3282 3283 if (db_seqp) 3284 *db_seqp = 3285 PL_curcop == &PL_compiling 3286 ? PL_cop_seqmax 3287 : PL_curcop->cop_seq; 3288 3289 for (si = PL_curstackinfo; si; si = si->si_prev) { 3290 I32 ix; 3291 for (ix = si->si_cxix; ix >= 0; ix--) { 3292 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]); 3293 CV *cv = NULL; 3294 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { 3295 cv = cx->blk_sub.cv; 3296 /* skip DB:: code */ 3297 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) { 3298 *db_seqp = cx->blk_oldcop->cop_seq; 3299 continue; 3300 } 3301 if (cx->cx_type & CXp_SUB_RE) 3302 continue; 3303 } 3304 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx)) 3305 cv = cx->blk_eval.cv; 3306 if (cv) { 3307 switch (cond) { 3308 case FIND_RUNCV_padid_eq: 3309 if (!CvPADLIST(cv) 3310 || PadlistNAMES(CvPADLIST(cv)) != INT2PTR(PADNAMELIST *, arg)) 3311 continue; 3312 return cv; 3313 case FIND_RUNCV_level_eq: 3314 if (level++ != arg) continue; 3315 /* GERONIMO! */ 3316 default: 3317 return cv; 3318 } 3319 } 3320 } 3321 } 3322 return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv; 3323 } 3324 3325 3326 /* Run yyparse() in a setjmp wrapper. Returns: 3327 * 0: yyparse() successful 3328 * 1: yyparse() failed 3329 * 3: yyparse() died 3330 */ 3331 STATIC int 3332 S_try_yyparse(pTHX_ int gramtype) 3333 { 3334 int ret; 3335 dJMPENV; 3336 3337 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL); 3338 JMPENV_PUSH(ret); 3339 switch (ret) { 3340 case 0: 3341 ret = yyparse(gramtype) ? 1 : 0; 3342 break; 3343 case 3: 3344 break; 3345 default: 3346 JMPENV_POP; 3347 JMPENV_JUMP(ret); 3348 assert(0); /* NOTREACHED */ 3349 } 3350 JMPENV_POP; 3351 return ret; 3352 } 3353 3354 3355 /* Compile a require/do or an eval ''. 3356 * 3357 * outside is the lexically enclosing CV (if any) that invoked us. 3358 * seq is the current COP scope value. 3359 * hh is the saved hints hash, if any. 3360 * 3361 * Returns a bool indicating whether the compile was successful; if so, 3362 * PL_eval_start contains the first op of the compiled code; otherwise, 3363 * pushes undef. 3364 * 3365 * This function is called from two places: pp_require and pp_entereval. 3366 * These can be distinguished by whether PL_op is entereval. 3367 */ 3368 3369 STATIC bool 3370 S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh) 3371 { 3372 dVAR; dSP; 3373 OP * const saveop = PL_op; 3374 bool clear_hints = saveop->op_type != OP_ENTEREVAL; 3375 COP * const oldcurcop = PL_curcop; 3376 bool in_require = (saveop->op_type == OP_REQUIRE); 3377 int yystatus; 3378 CV *evalcv; 3379 3380 PL_in_eval = (in_require 3381 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL)) 3382 : (EVAL_INEVAL | 3383 ((PL_op->op_private & OPpEVAL_RE_REPARSING) 3384 ? EVAL_RE_REPARSING : 0))); 3385 3386 PUSHMARK(SP); 3387 3388 evalcv = MUTABLE_CV(newSV_type(SVt_PVCV)); 3389 CvEVAL_on(evalcv); 3390 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL); 3391 cxstack[cxstack_ix].blk_eval.cv = evalcv; 3392 cxstack[cxstack_ix].blk_gimme = gimme; 3393 3394 CvOUTSIDE_SEQ(evalcv) = seq; 3395 CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside)); 3396 3397 /* set up a scratch pad */ 3398 3399 CvPADLIST(evalcv) = pad_new(padnew_SAVE); 3400 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */ 3401 3402 3403 if (!PL_madskills) 3404 SAVEMORTALIZESV(evalcv); /* must remain until end of current statement */ 3405 3406 /* make sure we compile in the right package */ 3407 3408 if (CopSTASH_ne(PL_curcop, PL_curstash)) { 3409 SAVEGENERICSV(PL_curstash); 3410 PL_curstash = (HV *)SvREFCNT_inc_simple(CopSTASH(PL_curcop)); 3411 } 3412 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */ 3413 SAVESPTR(PL_beginav); 3414 PL_beginav = newAV(); 3415 SAVEFREESV(PL_beginav); 3416 SAVESPTR(PL_unitcheckav); 3417 PL_unitcheckav = newAV(); 3418 SAVEFREESV(PL_unitcheckav); 3419 3420 #ifdef PERL_MAD 3421 SAVEBOOL(PL_madskills); 3422 PL_madskills = 0; 3423 #endif 3424 3425 ENTER_with_name("evalcomp"); 3426 SAVESPTR(PL_compcv); 3427 PL_compcv = evalcv; 3428 3429 /* try to compile it */ 3430 3431 PL_eval_root = NULL; 3432 PL_curcop = &PL_compiling; 3433 if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL)) 3434 PL_in_eval |= EVAL_KEEPERR; 3435 else 3436 CLEAR_ERRSV(); 3437 3438 SAVEHINTS(); 3439 if (clear_hints) { 3440 PL_hints = 0; 3441 hv_clear(GvHV(PL_hintgv)); 3442 } 3443 else { 3444 PL_hints = saveop->op_private & OPpEVAL_COPHH 3445 ? oldcurcop->cop_hints : saveop->op_targ; 3446 3447 /* making 'use re eval' not be in scope when compiling the 3448 * qr/mabye_has_runtime_code_block/ ensures that we don't get 3449 * infinite recursion when S_has_runtime_code() gives a false 3450 * positive: the second time round, HINT_RE_EVAL isn't set so we 3451 * don't bother calling S_has_runtime_code() */ 3452 if (PL_in_eval & EVAL_RE_REPARSING) 3453 PL_hints &= ~HINT_RE_EVAL; 3454 3455 if (hh) { 3456 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */ 3457 SvREFCNT_dec(GvHV(PL_hintgv)); 3458 GvHV(PL_hintgv) = hh; 3459 } 3460 } 3461 SAVECOMPILEWARNINGS(); 3462 if (clear_hints) { 3463 if (PL_dowarn & G_WARN_ALL_ON) 3464 PL_compiling.cop_warnings = pWARN_ALL ; 3465 else if (PL_dowarn & G_WARN_ALL_OFF) 3466 PL_compiling.cop_warnings = pWARN_NONE ; 3467 else 3468 PL_compiling.cop_warnings = pWARN_STD ; 3469 } 3470 else { 3471 PL_compiling.cop_warnings = 3472 DUP_WARNINGS(oldcurcop->cop_warnings); 3473 cophh_free(CopHINTHASH_get(&PL_compiling)); 3474 if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) { 3475 /* The label, if present, is the first entry on the chain. So rather 3476 than writing a blank label in front of it (which involves an 3477 allocation), just use the next entry in the chain. */ 3478 PL_compiling.cop_hints_hash 3479 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next); 3480 /* Check the assumption that this removed the label. */ 3481 assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL); 3482 } 3483 else 3484 PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash); 3485 } 3486 3487 CALL_BLOCK_HOOKS(bhk_eval, saveop); 3488 3489 /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>, 3490 * so honour CATCH_GET and trap it here if necessary */ 3491 3492 yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG); 3493 3494 if (yystatus || PL_parser->error_count || !PL_eval_root) { 3495 SV **newsp; /* Used by POPBLOCK. */ 3496 PERL_CONTEXT *cx; 3497 I32 optype; /* Used by POPEVAL. */ 3498 SV *namesv; 3499 SV *errsv = NULL; 3500 3501 cx = NULL; 3502 namesv = NULL; 3503 PERL_UNUSED_VAR(newsp); 3504 PERL_UNUSED_VAR(optype); 3505 3506 /* note that if yystatus == 3, then the EVAL CX block has already 3507 * been popped, and various vars restored */ 3508 PL_op = saveop; 3509 if (yystatus != 3) { 3510 if (PL_eval_root) { 3511 op_free(PL_eval_root); 3512 PL_eval_root = NULL; 3513 } 3514 SP = PL_stack_base + POPMARK; /* pop original mark */ 3515 POPBLOCK(cx,PL_curpm); 3516 POPEVAL(cx); 3517 namesv = cx->blk_eval.old_namesv; 3518 /* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */ 3519 LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */ 3520 } 3521 3522 errsv = ERRSV; 3523 if (in_require) { 3524 if (!cx) { 3525 /* If cx is still NULL, it means that we didn't go in the 3526 * POPEVAL branch. */ 3527 cx = &cxstack[cxstack_ix]; 3528 assert(CxTYPE(cx) == CXt_EVAL); 3529 namesv = cx->blk_eval.old_namesv; 3530 } 3531 (void)hv_store(GvHVn(PL_incgv), 3532 SvPVX_const(namesv), 3533 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv), 3534 &PL_sv_undef, 0); 3535 Perl_croak(aTHX_ "%"SVf"Compilation failed in require", 3536 SVfARG(errsv 3537 ? errsv 3538 : newSVpvs_flags("Unknown error\n", SVs_TEMP))); 3539 } 3540 else { 3541 if (!*(SvPV_nolen_const(errsv))) { 3542 sv_setpvs(errsv, "Compilation error"); 3543 } 3544 } 3545 if (gimme != G_ARRAY) PUSHs(&PL_sv_undef); 3546 PUTBACK; 3547 return FALSE; 3548 } 3549 else 3550 LEAVE_with_name("evalcomp"); 3551 3552 CopLINE_set(&PL_compiling, 0); 3553 SAVEFREEOP(PL_eval_root); 3554 cv_forget_slab(evalcv); 3555 3556 DEBUG_x(dump_eval()); 3557 3558 /* Register with debugger: */ 3559 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) { 3560 CV * const cv = get_cvs("DB::postponed", 0); 3561 if (cv) { 3562 dSP; 3563 PUSHMARK(SP); 3564 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling))); 3565 PUTBACK; 3566 call_sv(MUTABLE_SV(cv), G_DISCARD); 3567 } 3568 } 3569 3570 if (PL_unitcheckav) { 3571 OP *es = PL_eval_start; 3572 call_list(PL_scopestack_ix, PL_unitcheckav); 3573 PL_eval_start = es; 3574 } 3575 3576 /* compiled okay, so do it */ 3577 3578 CvDEPTH(evalcv) = 1; 3579 SP = PL_stack_base + POPMARK; /* pop original mark */ 3580 PL_op = saveop; /* The caller may need it. */ 3581 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */ 3582 3583 PUTBACK; 3584 return TRUE; 3585 } 3586 3587 STATIC PerlIO * 3588 S_check_type_and_open(pTHX_ SV *name) 3589 { 3590 Stat_t st; 3591 const char *p = SvPV_nolen_const(name); 3592 const int st_rc = PerlLIO_stat(p, &st); 3593 3594 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN; 3595 3596 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) { 3597 return NULL; 3598 } 3599 3600 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO) 3601 return PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name); 3602 #else 3603 return PerlIO_open(p, PERL_SCRIPT_MODE); 3604 #endif 3605 } 3606 3607 #ifndef PERL_DISABLE_PMC 3608 STATIC PerlIO * 3609 S_doopen_pm(pTHX_ SV *name) 3610 { 3611 STRLEN namelen; 3612 const char *p = SvPV_const(name, namelen); 3613 3614 PERL_ARGS_ASSERT_DOOPEN_PM; 3615 3616 if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) { 3617 SV *const pmcsv = sv_newmortal(); 3618 Stat_t pmcstat; 3619 3620 SvSetSV_nosteal(pmcsv,name); 3621 sv_catpvn(pmcsv, "c", 1); 3622 3623 if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0) 3624 return check_type_and_open(pmcsv); 3625 } 3626 return check_type_and_open(name); 3627 } 3628 #else 3629 # define doopen_pm(name) check_type_and_open(name) 3630 #endif /* !PERL_DISABLE_PMC */ 3631 3632 PP(pp_require) 3633 { 3634 dVAR; dSP; 3635 PERL_CONTEXT *cx; 3636 SV *sv; 3637 const char *name; 3638 STRLEN len; 3639 char * unixname; 3640 STRLEN unixlen; 3641 #ifdef VMS 3642 int vms_unixname = 0; 3643 char *unixnamebuf; 3644 char *unixdir; 3645 char *unixdirbuf; 3646 #endif 3647 const char *tryname = NULL; 3648 SV *namesv = NULL; 3649 const I32 gimme = GIMME_V; 3650 int filter_has_file = 0; 3651 PerlIO *tryrsfp = NULL; 3652 SV *filter_cache = NULL; 3653 SV *filter_state = NULL; 3654 SV *filter_sub = NULL; 3655 SV *hook_sv = NULL; 3656 SV *encoding; 3657 OP *op; 3658 int saved_errno; 3659 3660 sv = POPs; 3661 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) { 3662 sv = sv_2mortal(new_version(sv)); 3663 if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0)) 3664 upg_version(PL_patchlevel, TRUE); 3665 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) { 3666 if ( vcmp(sv,PL_patchlevel) <= 0 ) 3667 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped", 3668 SVfARG(sv_2mortal(vnormal(sv))), 3669 SVfARG(sv_2mortal(vnormal(PL_patchlevel))) 3670 ); 3671 } 3672 else { 3673 if ( vcmp(sv,PL_patchlevel) > 0 ) { 3674 I32 first = 0; 3675 AV *lav; 3676 SV * const req = SvRV(sv); 3677 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE); 3678 3679 /* get the left hand term */ 3680 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE))); 3681 3682 first = SvIV(*av_fetch(lav,0,0)); 3683 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */ 3684 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */ 3685 || av_len(lav) > 1 /* FP with > 3 digits */ 3686 || strstr(SvPVX(pv),".0") /* FP with leading 0 */ 3687 ) { 3688 DIE(aTHX_ "Perl %"SVf" required--this is only " 3689 "%"SVf", stopped", 3690 SVfARG(sv_2mortal(vnormal(req))), 3691 SVfARG(sv_2mortal(vnormal(PL_patchlevel))) 3692 ); 3693 } 3694 else { /* probably 'use 5.10' or 'use 5.8' */ 3695 SV *hintsv; 3696 I32 second = 0; 3697 3698 if (av_len(lav)>=1) 3699 second = SvIV(*av_fetch(lav,1,0)); 3700 3701 second /= second >= 600 ? 100 : 10; 3702 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0", 3703 (int)first, (int)second); 3704 upg_version(hintsv, TRUE); 3705 3706 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)" 3707 "--this is only %"SVf", stopped", 3708 SVfARG(sv_2mortal(vnormal(req))), 3709 SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))), 3710 SVfARG(sv_2mortal(vnormal(PL_patchlevel))) 3711 ); 3712 } 3713 } 3714 } 3715 3716 RETPUSHYES; 3717 } 3718 name = SvPV_const(sv, len); 3719 if (!(name && len > 0 && *name)) 3720 DIE(aTHX_ "Null filename used"); 3721 TAINT_PROPER("require"); 3722 3723 3724 #ifdef VMS 3725 /* The key in the %ENV hash is in the syntax of file passed as the argument 3726 * usually this is in UNIX format, but sometimes in VMS format, which 3727 * can result in a module being pulled in more than once. 3728 * To prevent this, the key must be stored in UNIX format if the VMS 3729 * name can be translated to UNIX. 3730 */ 3731 3732 if ((unixnamebuf = SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))) 3733 && (unixname = tounixspec(name, unixnamebuf)) != NULL) { 3734 unixlen = strlen(unixname); 3735 vms_unixname = 1; 3736 } 3737 else 3738 #endif 3739 { 3740 /* if not VMS or VMS name can not be translated to UNIX, pass it 3741 * through. 3742 */ 3743 unixname = (char *) name; 3744 unixlen = len; 3745 } 3746 if (PL_op->op_type == OP_REQUIRE) { 3747 SV * const * const svp = hv_fetch(GvHVn(PL_incgv), 3748 unixname, unixlen, 0); 3749 if ( svp ) { 3750 if (*svp != &PL_sv_undef) 3751 RETPUSHYES; 3752 else 3753 DIE(aTHX_ "Attempt to reload %s aborted.\n" 3754 "Compilation failed in require", unixname); 3755 } 3756 } 3757 3758 LOADING_FILE_PROBE(unixname); 3759 3760 /* prepare to compile file */ 3761 3762 if (path_is_absolute(name)) { 3763 /* At this point, name is SvPVX(sv) */ 3764 tryname = name; 3765 tryrsfp = doopen_pm(sv); 3766 } 3767 if (!tryrsfp && !(errno == EACCES && path_is_absolute(name))) { 3768 AV * const ar = GvAVn(PL_incgv); 3769 I32 i; 3770 #ifdef VMS 3771 if (vms_unixname) 3772 #endif 3773 { 3774 namesv = newSV_type(SVt_PV); 3775 for (i = 0; i <= AvFILL(ar); i++) { 3776 SV * const dirsv = *av_fetch(ar, i, TRUE); 3777 3778 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied)) 3779 mg_get(dirsv); 3780 if (SvROK(dirsv)) { 3781 int count; 3782 SV **svp; 3783 SV *loader = dirsv; 3784 3785 if (SvTYPE(SvRV(loader)) == SVt_PVAV 3786 && !sv_isobject(loader)) 3787 { 3788 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE); 3789 } 3790 3791 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s", 3792 PTR2UV(SvRV(dirsv)), name); 3793 tryname = SvPVX_const(namesv); 3794 tryrsfp = NULL; 3795 3796 ENTER_with_name("call_INC"); 3797 SAVETMPS; 3798 EXTEND(SP, 2); 3799 3800 PUSHMARK(SP); 3801 PUSHs(dirsv); 3802 PUSHs(sv); 3803 PUTBACK; 3804 if (sv_isobject(loader)) 3805 count = call_method("INC", G_ARRAY); 3806 else 3807 count = call_sv(loader, G_ARRAY); 3808 SPAGAIN; 3809 3810 if (count > 0) { 3811 int i = 0; 3812 SV *arg; 3813 3814 SP -= count - 1; 3815 arg = SP[i++]; 3816 3817 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV) 3818 && !isGV_with_GP(SvRV(arg))) { 3819 filter_cache = SvRV(arg); 3820 SvREFCNT_inc_simple_void_NN(filter_cache); 3821 3822 if (i < count) { 3823 arg = SP[i++]; 3824 } 3825 } 3826 3827 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) { 3828 arg = SvRV(arg); 3829 } 3830 3831 if (isGV_with_GP(arg)) { 3832 IO * const io = GvIO((const GV *)arg); 3833 3834 ++filter_has_file; 3835 3836 if (io) { 3837 tryrsfp = IoIFP(io); 3838 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { 3839 PerlIO_close(IoOFP(io)); 3840 } 3841 IoIFP(io) = NULL; 3842 IoOFP(io) = NULL; 3843 } 3844 3845 if (i < count) { 3846 arg = SP[i++]; 3847 } 3848 } 3849 3850 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) { 3851 filter_sub = arg; 3852 SvREFCNT_inc_simple_void_NN(filter_sub); 3853 3854 if (i < count) { 3855 filter_state = SP[i]; 3856 SvREFCNT_inc_simple_void(filter_state); 3857 } 3858 } 3859 3860 if (!tryrsfp && (filter_cache || filter_sub)) { 3861 tryrsfp = PerlIO_open(BIT_BUCKET, 3862 PERL_SCRIPT_MODE); 3863 } 3864 SP--; 3865 } 3866 3867 PUTBACK; 3868 FREETMPS; 3869 LEAVE_with_name("call_INC"); 3870 3871 /* Adjust file name if the hook has set an %INC entry. 3872 This needs to happen after the FREETMPS above. */ 3873 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0); 3874 if (svp) 3875 tryname = SvPV_nolen_const(*svp); 3876 3877 if (tryrsfp) { 3878 hook_sv = dirsv; 3879 break; 3880 } 3881 3882 filter_has_file = 0; 3883 if (filter_cache) { 3884 SvREFCNT_dec(filter_cache); 3885 filter_cache = NULL; 3886 } 3887 if (filter_state) { 3888 SvREFCNT_dec(filter_state); 3889 filter_state = NULL; 3890 } 3891 if (filter_sub) { 3892 SvREFCNT_dec(filter_sub); 3893 filter_sub = NULL; 3894 } 3895 } 3896 else { 3897 if (!path_is_absolute(name) 3898 ) { 3899 const char *dir; 3900 STRLEN dirlen; 3901 3902 if (SvOK(dirsv)) { 3903 dir = SvPV_const(dirsv, dirlen); 3904 } else { 3905 dir = ""; 3906 dirlen = 0; 3907 } 3908 3909 #ifdef VMS 3910 if (((unixdirbuf = SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))) == NULL) 3911 || ((unixdir = tounixpath(dir, unixdirbuf)) == NULL)) 3912 continue; 3913 sv_setpv(namesv, unixdir); 3914 sv_catpv(namesv, unixname); 3915 #else 3916 # ifdef __SYMBIAN32__ 3917 if (PL_origfilename[0] && 3918 PL_origfilename[1] == ':' && 3919 !(dir[0] && dir[1] == ':')) 3920 Perl_sv_setpvf(aTHX_ namesv, 3921 "%c:%s\\%s", 3922 PL_origfilename[0], 3923 dir, name); 3924 else 3925 Perl_sv_setpvf(aTHX_ namesv, 3926 "%s\\%s", 3927 dir, name); 3928 # else 3929 /* The equivalent of 3930 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name); 3931 but without the need to parse the format string, or 3932 call strlen on either pointer, and with the correct 3933 allocation up front. */ 3934 { 3935 char *tmp = SvGROW(namesv, dirlen + len + 2); 3936 3937 memcpy(tmp, dir, dirlen); 3938 tmp +=dirlen; 3939 3940 /* Avoid '<dir>//<file>' */ 3941 if (!dirlen || *(tmp-1) != '/') { 3942 *tmp++ = '/'; 3943 } 3944 3945 /* name came from an SV, so it will have a '\0' at the 3946 end that we can copy as part of this memcpy(). */ 3947 memcpy(tmp, name, len + 1); 3948 3949 SvCUR_set(namesv, dirlen + len + 1); 3950 SvPOK_on(namesv); 3951 } 3952 # endif 3953 #endif 3954 TAINT_PROPER("require"); 3955 tryname = SvPVX_const(namesv); 3956 tryrsfp = doopen_pm(namesv); 3957 if (tryrsfp) { 3958 if (tryname[0] == '.' && tryname[1] == '/') { 3959 ++tryname; 3960 while (*++tryname == '/') {} 3961 } 3962 break; 3963 } 3964 else if (errno == EMFILE || errno == EACCES) { 3965 /* no point in trying other paths if out of handles; 3966 * on the other hand, if we couldn't open one of the 3967 * files, then going on with the search could lead to 3968 * unexpected results; see perl #113422 3969 */ 3970 break; 3971 } 3972 } 3973 } 3974 } 3975 } 3976 } 3977 saved_errno = errno; /* sv_2mortal can realloc things */ 3978 sv_2mortal(namesv); 3979 if (!tryrsfp) { 3980 if (PL_op->op_type == OP_REQUIRE) { 3981 if(saved_errno == EMFILE || saved_errno == EACCES) { 3982 /* diag_listed_as: Can't locate %s */ 3983 DIE(aTHX_ "Can't locate %s: %s", name, Strerror(saved_errno)); 3984 } else { 3985 if (namesv) { /* did we lookup @INC? */ 3986 AV * const ar = GvAVn(PL_incgv); 3987 I32 i; 3988 SV *const msg = newSVpvs_flags("", SVs_TEMP); 3989 SV *const inc = newSVpvs_flags("", SVs_TEMP); 3990 for (i = 0; i <= AvFILL(ar); i++) { 3991 sv_catpvs(inc, " "); 3992 sv_catsv(inc, *av_fetch(ar, i, TRUE)); 3993 } 3994 if (len >= 4 && memEQ(name + len - 3, ".pm", 4)) { 3995 const char *c, *e = name + len - 3; 3996 sv_catpv(msg, " (you may need to install the "); 3997 for (c = name; c < e; c++) { 3998 if (*c == '/') { 3999 sv_catpvn(msg, "::", 2); 4000 } 4001 else { 4002 sv_catpvn(msg, c, 1); 4003 } 4004 } 4005 sv_catpv(msg, " module)"); 4006 } 4007 else if (len >= 2 && memEQ(name + len - 2, ".h", 3)) { 4008 sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)"); 4009 } 4010 else if (len >= 3 && memEQ(name + len - 3, ".ph", 4)) { 4011 sv_catpv(msg, " (did you run h2ph?)"); 4012 } 4013 4014 /* diag_listed_as: Can't locate %s */ 4015 DIE(aTHX_ 4016 "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")", 4017 name, msg, inc); 4018 } 4019 } 4020 DIE(aTHX_ "Can't locate %s", name); 4021 } 4022 4023 CLEAR_ERRSV(); 4024 RETPUSHUNDEF; 4025 } 4026 else 4027 SETERRNO(0, SS_NORMAL); 4028 4029 /* Assume success here to prevent recursive requirement. */ 4030 /* name is never assigned to again, so len is still strlen(name) */ 4031 /* Check whether a hook in @INC has already filled %INC */ 4032 if (!hook_sv) { 4033 (void)hv_store(GvHVn(PL_incgv), 4034 unixname, unixlen, newSVpv(tryname,0),0); 4035 } else { 4036 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0); 4037 if (!svp) 4038 (void)hv_store(GvHVn(PL_incgv), 4039 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 ); 4040 } 4041 4042 ENTER_with_name("eval"); 4043 SAVETMPS; 4044 SAVECOPFILE_FREE(&PL_compiling); 4045 CopFILE_set(&PL_compiling, tryname); 4046 lex_start(NULL, tryrsfp, 0); 4047 4048 if (filter_sub || filter_cache) { 4049 /* We can use the SvPV of the filter PVIO itself as our cache, rather 4050 than hanging another SV from it. In turn, filter_add() optionally 4051 takes the SV to use as the filter (or creates a new SV if passed 4052 NULL), so simply pass in whatever value filter_cache has. */ 4053 SV * const datasv = filter_add(S_run_user_filter, filter_cache); 4054 IoLINES(datasv) = filter_has_file; 4055 IoTOP_GV(datasv) = MUTABLE_GV(filter_state); 4056 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub); 4057 } 4058 4059 /* switch to eval mode */ 4060 PUSHBLOCK(cx, CXt_EVAL, SP); 4061 PUSHEVAL(cx, name); 4062 cx->blk_eval.retop = PL_op->op_next; 4063 4064 SAVECOPLINE(&PL_compiling); 4065 CopLINE_set(&PL_compiling, 0); 4066 4067 PUTBACK; 4068 4069 /* Store and reset encoding. */ 4070 encoding = PL_encoding; 4071 PL_encoding = NULL; 4072 4073 if (doeval(gimme, NULL, PL_curcop->cop_seq, NULL)) 4074 op = DOCATCH(PL_eval_start); 4075 else 4076 op = PL_op->op_next; 4077 4078 /* Restore encoding. */ 4079 PL_encoding = encoding; 4080 4081 LOADED_FILE_PROBE(unixname); 4082 4083 return op; 4084 } 4085 4086 /* This is a op added to hold the hints hash for 4087 pp_entereval. The hash can be modified by the code 4088 being eval'ed, so we return a copy instead. */ 4089 4090 PP(pp_hintseval) 4091 { 4092 dVAR; 4093 dSP; 4094 mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv)))); 4095 RETURN; 4096 } 4097 4098 4099 PP(pp_entereval) 4100 { 4101 dVAR; dSP; 4102 PERL_CONTEXT *cx; 4103 SV *sv; 4104 const I32 gimme = GIMME_V; 4105 const U32 was = PL_breakable_sub_gen; 4106 char tbuf[TYPE_DIGITS(long) + 12]; 4107 bool saved_delete = FALSE; 4108 char *tmpbuf = tbuf; 4109 STRLEN len; 4110 CV* runcv; 4111 U32 seq, lex_flags = 0; 4112 HV *saved_hh = NULL; 4113 const bool bytes = PL_op->op_private & OPpEVAL_BYTES; 4114 4115 if (PL_op->op_private & OPpEVAL_HAS_HH) { 4116 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs)); 4117 } 4118 else if (PL_hints & HINT_LOCALIZE_HH || ( 4119 PL_op->op_private & OPpEVAL_COPHH 4120 && PL_curcop->cop_hints & HINT_LOCALIZE_HH 4121 )) { 4122 saved_hh = cop_hints_2hv(PL_curcop, 0); 4123 hv_magic(saved_hh, NULL, PERL_MAGIC_hints); 4124 } 4125 sv = POPs; 4126 if (!SvPOK(sv)) { 4127 /* make sure we've got a plain PV (no overload etc) before testing 4128 * for taint. Making a copy here is probably overkill, but better 4129 * safe than sorry */ 4130 STRLEN len; 4131 const char * const p = SvPV_const(sv, len); 4132 4133 sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv)); 4134 lex_flags |= LEX_START_COPIED; 4135 4136 if (bytes && SvUTF8(sv)) 4137 SvPVbyte_force(sv, len); 4138 } 4139 else if (bytes && SvUTF8(sv)) { 4140 /* Don't modify someone else's scalar */ 4141 STRLEN len; 4142 sv = newSVsv(sv); 4143 (void)sv_2mortal(sv); 4144 SvPVbyte_force(sv,len); 4145 lex_flags |= LEX_START_COPIED; 4146 } 4147 4148 TAINT_IF(SvTAINTED(sv)); 4149 TAINT_PROPER("eval"); 4150 4151 ENTER_with_name("eval"); 4152 lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE 4153 ? LEX_IGNORE_UTF8_HINTS 4154 : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER 4155 ) 4156 ); 4157 SAVETMPS; 4158 4159 /* switch to eval mode */ 4160 4161 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) { 4162 SV * const temp_sv = sv_newmortal(); 4163 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]", 4164 (unsigned long)++PL_evalseq, 4165 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); 4166 tmpbuf = SvPVX(temp_sv); 4167 len = SvCUR(temp_sv); 4168 } 4169 else 4170 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq); 4171 SAVECOPFILE_FREE(&PL_compiling); 4172 CopFILE_set(&PL_compiling, tmpbuf+2); 4173 SAVECOPLINE(&PL_compiling); 4174 CopLINE_set(&PL_compiling, 1); 4175 /* special case: an eval '' executed within the DB package gets lexically 4176 * placed in the first non-DB CV rather than the current CV - this 4177 * allows the debugger to execute code, find lexicals etc, in the 4178 * scope of the code being debugged. Passing &seq gets find_runcv 4179 * to do the dirty work for us */ 4180 runcv = find_runcv(&seq); 4181 4182 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP); 4183 PUSHEVAL(cx, 0); 4184 cx->blk_eval.retop = PL_op->op_next; 4185 4186 /* prepare to compile string */ 4187 4188 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) 4189 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr); 4190 else { 4191 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up 4192 deleting the eval's FILEGV from the stash before gv_check() runs 4193 (i.e. before run-time proper). To work around the coredump that 4194 ensues, we always turn GvMULTI_on for any globals that were 4195 introduced within evals. See force_ident(). GSAR 96-10-12 */ 4196 char *const safestr = savepvn(tmpbuf, len); 4197 SAVEDELETE(PL_defstash, safestr, len); 4198 saved_delete = TRUE; 4199 } 4200 4201 PUTBACK; 4202 4203 if (doeval(gimme, runcv, seq, saved_hh)) { 4204 if (was != PL_breakable_sub_gen /* Some subs defined here. */ 4205 ? (PERLDB_LINE || PERLDB_SAVESRC) 4206 : PERLDB_SAVESRC_NOSUBS) { 4207 /* Retain the filegv we created. */ 4208 } else if (!saved_delete) { 4209 char *const safestr = savepvn(tmpbuf, len); 4210 SAVEDELETE(PL_defstash, safestr, len); 4211 } 4212 return DOCATCH(PL_eval_start); 4213 } else { 4214 /* We have already left the scope set up earlier thanks to the LEAVE 4215 in doeval(). */ 4216 if (was != PL_breakable_sub_gen /* Some subs defined here. */ 4217 ? (PERLDB_LINE || PERLDB_SAVESRC) 4218 : PERLDB_SAVESRC_INVALID) { 4219 /* Retain the filegv we created. */ 4220 } else if (!saved_delete) { 4221 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD); 4222 } 4223 return PL_op->op_next; 4224 } 4225 } 4226 4227 PP(pp_leaveeval) 4228 { 4229 dVAR; dSP; 4230 SV **newsp; 4231 PMOP *newpm; 4232 I32 gimme; 4233 PERL_CONTEXT *cx; 4234 OP *retop; 4235 const U8 save_flags = PL_op -> op_flags; 4236 I32 optype; 4237 SV *namesv; 4238 CV *evalcv; 4239 4240 PERL_ASYNC_CHECK(); 4241 POPBLOCK(cx,newpm); 4242 POPEVAL(cx); 4243 namesv = cx->blk_eval.old_namesv; 4244 retop = cx->blk_eval.retop; 4245 evalcv = cx->blk_eval.cv; 4246 4247 TAINT_NOT; 4248 SP = adjust_stack_on_leave((gimme == G_VOID) ? SP : newsp, SP, newsp, 4249 gimme, SVs_TEMP); 4250 PL_curpm = newpm; /* Don't pop $1 et al till now */ 4251 4252 #ifdef DEBUGGING 4253 assert(CvDEPTH(evalcv) == 1); 4254 #endif 4255 CvDEPTH(evalcv) = 0; 4256 4257 if (optype == OP_REQUIRE && 4258 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp)) 4259 { 4260 /* Unassume the success we assumed earlier. */ 4261 (void)hv_delete(GvHVn(PL_incgv), 4262 SvPVX_const(namesv), 4263 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv), 4264 G_DISCARD); 4265 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", 4266 SVfARG(namesv)); 4267 /* die_unwind() did LEAVE, or we won't be here */ 4268 } 4269 else { 4270 LEAVE_with_name("eval"); 4271 if (!(save_flags & OPf_SPECIAL)) { 4272 CLEAR_ERRSV(); 4273 } 4274 } 4275 4276 RETURNOP(retop); 4277 } 4278 4279 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it 4280 close to the related Perl_create_eval_scope. */ 4281 void 4282 Perl_delete_eval_scope(pTHX) 4283 { 4284 SV **newsp; 4285 PMOP *newpm; 4286 I32 gimme; 4287 PERL_CONTEXT *cx; 4288 I32 optype; 4289 4290 POPBLOCK(cx,newpm); 4291 POPEVAL(cx); 4292 PL_curpm = newpm; 4293 LEAVE_with_name("eval_scope"); 4294 PERL_UNUSED_VAR(newsp); 4295 PERL_UNUSED_VAR(gimme); 4296 PERL_UNUSED_VAR(optype); 4297 } 4298 4299 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was 4300 also needed by Perl_fold_constants. */ 4301 PERL_CONTEXT * 4302 Perl_create_eval_scope(pTHX_ U32 flags) 4303 { 4304 PERL_CONTEXT *cx; 4305 const I32 gimme = GIMME_V; 4306 4307 ENTER_with_name("eval_scope"); 4308 SAVETMPS; 4309 4310 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp); 4311 PUSHEVAL(cx, 0); 4312 4313 PL_in_eval = EVAL_INEVAL; 4314 if (flags & G_KEEPERR) 4315 PL_in_eval |= EVAL_KEEPERR; 4316 else 4317 CLEAR_ERRSV(); 4318 if (flags & G_FAKINGEVAL) { 4319 PL_eval_root = PL_op; /* Only needed so that goto works right. */ 4320 } 4321 return cx; 4322 } 4323 4324 PP(pp_entertry) 4325 { 4326 dVAR; 4327 PERL_CONTEXT * const cx = create_eval_scope(0); 4328 cx->blk_eval.retop = cLOGOP->op_other->op_next; 4329 return DOCATCH(PL_op->op_next); 4330 } 4331 4332 PP(pp_leavetry) 4333 { 4334 dVAR; dSP; 4335 SV **newsp; 4336 PMOP *newpm; 4337 I32 gimme; 4338 PERL_CONTEXT *cx; 4339 I32 optype; 4340 4341 PERL_ASYNC_CHECK(); 4342 POPBLOCK(cx,newpm); 4343 POPEVAL(cx); 4344 PERL_UNUSED_VAR(optype); 4345 4346 TAINT_NOT; 4347 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP); 4348 PL_curpm = newpm; /* Don't pop $1 et al till now */ 4349 4350 LEAVE_with_name("eval_scope"); 4351 CLEAR_ERRSV(); 4352 RETURN; 4353 } 4354 4355 PP(pp_entergiven) 4356 { 4357 dVAR; dSP; 4358 PERL_CONTEXT *cx; 4359 const I32 gimme = GIMME_V; 4360 4361 ENTER_with_name("given"); 4362 SAVETMPS; 4363 4364 if (PL_op->op_targ) { 4365 SAVEPADSVANDMORTALIZE(PL_op->op_targ); 4366 SvREFCNT_dec(PAD_SVl(PL_op->op_targ)); 4367 PAD_SVl(PL_op->op_targ) = SvREFCNT_inc_NN(POPs); 4368 } 4369 else { 4370 SAVE_DEFSV; 4371 DEFSV_set(POPs); 4372 } 4373 4374 PUSHBLOCK(cx, CXt_GIVEN, SP); 4375 PUSHGIVEN(cx); 4376 4377 RETURN; 4378 } 4379 4380 PP(pp_leavegiven) 4381 { 4382 dVAR; dSP; 4383 PERL_CONTEXT *cx; 4384 I32 gimme; 4385 SV **newsp; 4386 PMOP *newpm; 4387 PERL_UNUSED_CONTEXT; 4388 4389 POPBLOCK(cx,newpm); 4390 assert(CxTYPE(cx) == CXt_GIVEN); 4391 4392 TAINT_NOT; 4393 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP); 4394 PL_curpm = newpm; /* Don't pop $1 et al till now */ 4395 4396 LEAVE_with_name("given"); 4397 RETURN; 4398 } 4399 4400 /* Helper routines used by pp_smartmatch */ 4401 STATIC PMOP * 4402 S_make_matcher(pTHX_ REGEXP *re) 4403 { 4404 dVAR; 4405 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED); 4406 4407 PERL_ARGS_ASSERT_MAKE_MATCHER; 4408 4409 PM_SETRE(matcher, ReREFCNT_inc(re)); 4410 4411 SAVEFREEOP((OP *) matcher); 4412 ENTER_with_name("matcher"); SAVETMPS; 4413 SAVEOP(); 4414 return matcher; 4415 } 4416 4417 STATIC bool 4418 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv) 4419 { 4420 dVAR; 4421 dSP; 4422 4423 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV; 4424 4425 PL_op = (OP *) matcher; 4426 XPUSHs(sv); 4427 PUTBACK; 4428 (void) Perl_pp_match(aTHX); 4429 SPAGAIN; 4430 return (SvTRUEx(POPs)); 4431 } 4432 4433 STATIC void 4434 S_destroy_matcher(pTHX_ PMOP *matcher) 4435 { 4436 dVAR; 4437 4438 PERL_ARGS_ASSERT_DESTROY_MATCHER; 4439 PERL_UNUSED_ARG(matcher); 4440 4441 FREETMPS; 4442 LEAVE_with_name("matcher"); 4443 } 4444 4445 /* Do a smart match */ 4446 PP(pp_smartmatch) 4447 { 4448 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n")); 4449 return do_smartmatch(NULL, NULL, 0); 4450 } 4451 4452 /* This version of do_smartmatch() implements the 4453 * table of smart matches that is found in perlsyn. 4454 */ 4455 STATIC OP * 4456 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied) 4457 { 4458 dVAR; 4459 dSP; 4460 4461 bool object_on_left = FALSE; 4462 SV *e = TOPs; /* e is for 'expression' */ 4463 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */ 4464 4465 /* Take care only to invoke mg_get() once for each argument. 4466 * Currently we do this by copying the SV if it's magical. */ 4467 if (d) { 4468 if (!copied && SvGMAGICAL(d)) 4469 d = sv_mortalcopy(d); 4470 } 4471 else 4472 d = &PL_sv_undef; 4473 4474 assert(e); 4475 if (SvGMAGICAL(e)) 4476 e = sv_mortalcopy(e); 4477 4478 /* First of all, handle overload magic of the rightmost argument */ 4479 if (SvAMAGIC(e)) { 4480 SV * tmpsv; 4481 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n")); 4482 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n")); 4483 4484 tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft); 4485 if (tmpsv) { 4486 SPAGAIN; 4487 (void)POPs; 4488 SETs(tmpsv); 4489 RETURN; 4490 } 4491 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n")); 4492 } 4493 4494 SP -= 2; /* Pop the values */ 4495 4496 4497 /* ~~ undef */ 4498 if (!SvOK(e)) { 4499 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n")); 4500 if (SvOK(d)) 4501 RETPUSHNO; 4502 else 4503 RETPUSHYES; 4504 } 4505 4506 if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) { 4507 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n")); 4508 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation"); 4509 } 4510 if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP)) 4511 object_on_left = TRUE; 4512 4513 /* ~~ sub */ 4514 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) { 4515 I32 c; 4516 if (object_on_left) { 4517 goto sm_any_sub; /* Treat objects like scalars */ 4518 } 4519 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) { 4520 /* Test sub truth for each key */ 4521 HE *he; 4522 bool andedresults = TRUE; 4523 HV *hv = (HV*) SvRV(d); 4524 I32 numkeys = hv_iterinit(hv); 4525 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n")); 4526 if (numkeys == 0) 4527 RETPUSHYES; 4528 while ( (he = hv_iternext(hv)) ) { 4529 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n")); 4530 ENTER_with_name("smartmatch_hash_key_test"); 4531 SAVETMPS; 4532 PUSHMARK(SP); 4533 PUSHs(hv_iterkeysv(he)); 4534 PUTBACK; 4535 c = call_sv(e, G_SCALAR); 4536 SPAGAIN; 4537 if (c == 0) 4538 andedresults = FALSE; 4539 else 4540 andedresults = SvTRUEx(POPs) && andedresults; 4541 FREETMPS; 4542 LEAVE_with_name("smartmatch_hash_key_test"); 4543 } 4544 if (andedresults) 4545 RETPUSHYES; 4546 else 4547 RETPUSHNO; 4548 } 4549 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { 4550 /* Test sub truth for each element */ 4551 I32 i; 4552 bool andedresults = TRUE; 4553 AV *av = (AV*) SvRV(d); 4554 const I32 len = av_len(av); 4555 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n")); 4556 if (len == -1) 4557 RETPUSHYES; 4558 for (i = 0; i <= len; ++i) { 4559 SV * const * const svp = av_fetch(av, i, FALSE); 4560 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n")); 4561 ENTER_with_name("smartmatch_array_elem_test"); 4562 SAVETMPS; 4563 PUSHMARK(SP); 4564 if (svp) 4565 PUSHs(*svp); 4566 PUTBACK; 4567 c = call_sv(e, G_SCALAR); 4568 SPAGAIN; 4569 if (c == 0) 4570 andedresults = FALSE; 4571 else 4572 andedresults = SvTRUEx(POPs) && andedresults; 4573 FREETMPS; 4574 LEAVE_with_name("smartmatch_array_elem_test"); 4575 } 4576 if (andedresults) 4577 RETPUSHYES; 4578 else 4579 RETPUSHNO; 4580 } 4581 else { 4582 sm_any_sub: 4583 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n")); 4584 ENTER_with_name("smartmatch_coderef"); 4585 SAVETMPS; 4586 PUSHMARK(SP); 4587 PUSHs(d); 4588 PUTBACK; 4589 c = call_sv(e, G_SCALAR); 4590 SPAGAIN; 4591 if (c == 0) 4592 PUSHs(&PL_sv_no); 4593 else if (SvTEMP(TOPs)) 4594 SvREFCNT_inc_void(TOPs); 4595 FREETMPS; 4596 LEAVE_with_name("smartmatch_coderef"); 4597 RETURN; 4598 } 4599 } 4600 /* ~~ %hash */ 4601 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) { 4602 if (object_on_left) { 4603 goto sm_any_hash; /* Treat objects like scalars */ 4604 } 4605 else if (!SvOK(d)) { 4606 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n")); 4607 RETPUSHNO; 4608 } 4609 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) { 4610 /* Check that the key-sets are identical */ 4611 HE *he; 4612 HV *other_hv = MUTABLE_HV(SvRV(d)); 4613 bool tied = FALSE; 4614 bool other_tied = FALSE; 4615 U32 this_key_count = 0, 4616 other_key_count = 0; 4617 HV *hv = MUTABLE_HV(SvRV(e)); 4618 4619 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n")); 4620 /* Tied hashes don't know how many keys they have. */ 4621 if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) { 4622 tied = TRUE; 4623 } 4624 else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) { 4625 HV * const temp = other_hv; 4626 other_hv = hv; 4627 hv = temp; 4628 tied = TRUE; 4629 } 4630 if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) 4631 other_tied = TRUE; 4632 4633 if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv)) 4634 RETPUSHNO; 4635 4636 /* The hashes have the same number of keys, so it suffices 4637 to check that one is a subset of the other. */ 4638 (void) hv_iterinit(hv); 4639 while ( (he = hv_iternext(hv)) ) { 4640 SV *key = hv_iterkeysv(he); 4641 4642 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n")); 4643 ++ this_key_count; 4644 4645 if(!hv_exists_ent(other_hv, key, 0)) { 4646 (void) hv_iterinit(hv); /* reset iterator */ 4647 RETPUSHNO; 4648 } 4649 } 4650 4651 if (other_tied) { 4652 (void) hv_iterinit(other_hv); 4653 while ( hv_iternext(other_hv) ) 4654 ++other_key_count; 4655 } 4656 else 4657 other_key_count = HvUSEDKEYS(other_hv); 4658 4659 if (this_key_count != other_key_count) 4660 RETPUSHNO; 4661 else 4662 RETPUSHYES; 4663 } 4664 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { 4665 AV * const other_av = MUTABLE_AV(SvRV(d)); 4666 const I32 other_len = av_len(other_av) + 1; 4667 I32 i; 4668 HV *hv = MUTABLE_HV(SvRV(e)); 4669 4670 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n")); 4671 for (i = 0; i < other_len; ++i) { 4672 SV ** const svp = av_fetch(other_av, i, FALSE); 4673 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n")); 4674 if (svp) { /* ??? When can this not happen? */ 4675 if (hv_exists_ent(hv, *svp, 0)) 4676 RETPUSHYES; 4677 } 4678 } 4679 RETPUSHNO; 4680 } 4681 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) { 4682 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n")); 4683 sm_regex_hash: 4684 { 4685 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d)); 4686 HE *he; 4687 HV *hv = MUTABLE_HV(SvRV(e)); 4688 4689 (void) hv_iterinit(hv); 4690 while ( (he = hv_iternext(hv)) ) { 4691 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n")); 4692 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) { 4693 (void) hv_iterinit(hv); 4694 destroy_matcher(matcher); 4695 RETPUSHYES; 4696 } 4697 } 4698 destroy_matcher(matcher); 4699 RETPUSHNO; 4700 } 4701 } 4702 else { 4703 sm_any_hash: 4704 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n")); 4705 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0)) 4706 RETPUSHYES; 4707 else 4708 RETPUSHNO; 4709 } 4710 } 4711 /* ~~ @array */ 4712 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) { 4713 if (object_on_left) { 4714 goto sm_any_array; /* Treat objects like scalars */ 4715 } 4716 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) { 4717 AV * const other_av = MUTABLE_AV(SvRV(e)); 4718 const I32 other_len = av_len(other_av) + 1; 4719 I32 i; 4720 4721 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n")); 4722 for (i = 0; i < other_len; ++i) { 4723 SV ** const svp = av_fetch(other_av, i, FALSE); 4724 4725 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n")); 4726 if (svp) { /* ??? When can this not happen? */ 4727 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0)) 4728 RETPUSHYES; 4729 } 4730 } 4731 RETPUSHNO; 4732 } 4733 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { 4734 AV *other_av = MUTABLE_AV(SvRV(d)); 4735 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n")); 4736 if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av)) 4737 RETPUSHNO; 4738 else { 4739 I32 i; 4740 const I32 other_len = av_len(other_av); 4741 4742 if (NULL == seen_this) { 4743 seen_this = newHV(); 4744 (void) sv_2mortal(MUTABLE_SV(seen_this)); 4745 } 4746 if (NULL == seen_other) { 4747 seen_other = newHV(); 4748 (void) sv_2mortal(MUTABLE_SV(seen_other)); 4749 } 4750 for(i = 0; i <= other_len; ++i) { 4751 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE); 4752 SV * const * const other_elem = av_fetch(other_av, i, FALSE); 4753 4754 if (!this_elem || !other_elem) { 4755 if ((this_elem && SvOK(*this_elem)) 4756 || (other_elem && SvOK(*other_elem))) 4757 RETPUSHNO; 4758 } 4759 else if (hv_exists_ent(seen_this, 4760 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) || 4761 hv_exists_ent(seen_other, 4762 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0)) 4763 { 4764 if (*this_elem != *other_elem) 4765 RETPUSHNO; 4766 } 4767 else { 4768 (void)hv_store_ent(seen_this, 4769 sv_2mortal(newSViv(PTR2IV(*this_elem))), 4770 &PL_sv_undef, 0); 4771 (void)hv_store_ent(seen_other, 4772 sv_2mortal(newSViv(PTR2IV(*other_elem))), 4773 &PL_sv_undef, 0); 4774 PUSHs(*other_elem); 4775 PUSHs(*this_elem); 4776 4777 PUTBACK; 4778 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n")); 4779 (void) do_smartmatch(seen_this, seen_other, 0); 4780 SPAGAIN; 4781 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n")); 4782 4783 if (!SvTRUEx(POPs)) 4784 RETPUSHNO; 4785 } 4786 } 4787 RETPUSHYES; 4788 } 4789 } 4790 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) { 4791 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n")); 4792 sm_regex_array: 4793 { 4794 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d)); 4795 const I32 this_len = av_len(MUTABLE_AV(SvRV(e))); 4796 I32 i; 4797 4798 for(i = 0; i <= this_len; ++i) { 4799 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE); 4800 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n")); 4801 if (svp && matcher_matches_sv(matcher, *svp)) { 4802 destroy_matcher(matcher); 4803 RETPUSHYES; 4804 } 4805 } 4806 destroy_matcher(matcher); 4807 RETPUSHNO; 4808 } 4809 } 4810 else if (!SvOK(d)) { 4811 /* undef ~~ array */ 4812 const I32 this_len = av_len(MUTABLE_AV(SvRV(e))); 4813 I32 i; 4814 4815 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n")); 4816 for (i = 0; i <= this_len; ++i) { 4817 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE); 4818 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n")); 4819 if (!svp || !SvOK(*svp)) 4820 RETPUSHYES; 4821 } 4822 RETPUSHNO; 4823 } 4824 else { 4825 sm_any_array: 4826 { 4827 I32 i; 4828 const I32 this_len = av_len(MUTABLE_AV(SvRV(e))); 4829 4830 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n")); 4831 for (i = 0; i <= this_len; ++i) { 4832 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE); 4833 if (!svp) 4834 continue; 4835 4836 PUSHs(d); 4837 PUSHs(*svp); 4838 PUTBACK; 4839 /* infinite recursion isn't supposed to happen here */ 4840 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n")); 4841 (void) do_smartmatch(NULL, NULL, 1); 4842 SPAGAIN; 4843 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n")); 4844 if (SvTRUEx(POPs)) 4845 RETPUSHYES; 4846 } 4847 RETPUSHNO; 4848 } 4849 } 4850 } 4851 /* ~~ qr// */ 4852 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) { 4853 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) { 4854 SV *t = d; d = e; e = t; 4855 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n")); 4856 goto sm_regex_hash; 4857 } 4858 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { 4859 SV *t = d; d = e; e = t; 4860 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n")); 4861 goto sm_regex_array; 4862 } 4863 else { 4864 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e)); 4865 4866 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n")); 4867 PUTBACK; 4868 PUSHs(matcher_matches_sv(matcher, d) 4869 ? &PL_sv_yes 4870 : &PL_sv_no); 4871 destroy_matcher(matcher); 4872 RETURN; 4873 } 4874 } 4875 /* ~~ scalar */ 4876 /* See if there is overload magic on left */ 4877 else if (object_on_left && SvAMAGIC(d)) { 4878 SV *tmpsv; 4879 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n")); 4880 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n")); 4881 PUSHs(d); PUSHs(e); 4882 PUTBACK; 4883 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright); 4884 if (tmpsv) { 4885 SPAGAIN; 4886 (void)POPs; 4887 SETs(tmpsv); 4888 RETURN; 4889 } 4890 SP -= 2; 4891 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n")); 4892 goto sm_any_scalar; 4893 } 4894 else if (!SvOK(d)) { 4895 /* undef ~~ scalar ; we already know that the scalar is SvOK */ 4896 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n")); 4897 RETPUSHNO; 4898 } 4899 else 4900 sm_any_scalar: 4901 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) { 4902 DEBUG_M(if (SvNIOK(e)) 4903 Perl_deb(aTHX_ " applying rule Any-Num\n"); 4904 else 4905 Perl_deb(aTHX_ " applying rule Num-numish\n"); 4906 ); 4907 /* numeric comparison */ 4908 PUSHs(d); PUSHs(e); 4909 PUTBACK; 4910 if (CopHINTS_get(PL_curcop) & HINT_INTEGER) 4911 (void) Perl_pp_i_eq(aTHX); 4912 else 4913 (void) Perl_pp_eq(aTHX); 4914 SPAGAIN; 4915 if (SvTRUEx(POPs)) 4916 RETPUSHYES; 4917 else 4918 RETPUSHNO; 4919 } 4920 4921 /* As a last resort, use string comparison */ 4922 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n")); 4923 PUSHs(d); PUSHs(e); 4924 PUTBACK; 4925 return Perl_pp_seq(aTHX); 4926 } 4927 4928 PP(pp_enterwhen) 4929 { 4930 dVAR; dSP; 4931 PERL_CONTEXT *cx; 4932 const I32 gimme = GIMME_V; 4933 4934 /* This is essentially an optimization: if the match 4935 fails, we don't want to push a context and then 4936 pop it again right away, so we skip straight 4937 to the op that follows the leavewhen. 4938 RETURNOP calls PUTBACK which restores the stack pointer after the POPs. 4939 */ 4940 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs)) 4941 RETURNOP(cLOGOP->op_other->op_next); 4942 4943 ENTER_with_name("when"); 4944 SAVETMPS; 4945 4946 PUSHBLOCK(cx, CXt_WHEN, SP); 4947 PUSHWHEN(cx); 4948 4949 RETURN; 4950 } 4951 4952 PP(pp_leavewhen) 4953 { 4954 dVAR; dSP; 4955 I32 cxix; 4956 PERL_CONTEXT *cx; 4957 I32 gimme; 4958 SV **newsp; 4959 PMOP *newpm; 4960 4961 cxix = dopoptogiven(cxstack_ix); 4962 if (cxix < 0) 4963 /* diag_listed_as: Can't "when" outside a topicalizer */ 4964 DIE(aTHX_ "Can't \"%s\" outside a topicalizer", 4965 PL_op->op_flags & OPf_SPECIAL ? "default" : "when"); 4966 4967 POPBLOCK(cx,newpm); 4968 assert(CxTYPE(cx) == CXt_WHEN); 4969 4970 TAINT_NOT; 4971 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP); 4972 PL_curpm = newpm; /* pop $1 et al */ 4973 4974 LEAVE_with_name("when"); 4975 4976 if (cxix < cxstack_ix) 4977 dounwind(cxix); 4978 4979 cx = &cxstack[cxix]; 4980 4981 if (CxFOREACH(cx)) { 4982 /* clear off anything above the scope we're re-entering */ 4983 I32 inner = PL_scopestack_ix; 4984 4985 TOPBLOCK(cx); 4986 if (PL_scopestack_ix < inner) 4987 leave_scope(PL_scopestack[PL_scopestack_ix]); 4988 PL_curcop = cx->blk_oldcop; 4989 4990 PERL_ASYNC_CHECK(); 4991 return cx->blk_loop.my_op->op_nextop; 4992 } 4993 else { 4994 PERL_ASYNC_CHECK(); 4995 RETURNOP(cx->blk_givwhen.leave_op); 4996 } 4997 } 4998 4999 PP(pp_continue) 5000 { 5001 dVAR; dSP; 5002 I32 cxix; 5003 PERL_CONTEXT *cx; 5004 I32 gimme; 5005 SV **newsp; 5006 PMOP *newpm; 5007 5008 PERL_UNUSED_VAR(gimme); 5009 5010 cxix = dopoptowhen(cxstack_ix); 5011 if (cxix < 0) 5012 DIE(aTHX_ "Can't \"continue\" outside a when block"); 5013 5014 if (cxix < cxstack_ix) 5015 dounwind(cxix); 5016 5017 POPBLOCK(cx,newpm); 5018 assert(CxTYPE(cx) == CXt_WHEN); 5019 5020 SP = newsp; 5021 PL_curpm = newpm; /* pop $1 et al */ 5022 5023 LEAVE_with_name("when"); 5024 RETURNOP(cx->blk_givwhen.leave_op->op_next); 5025 } 5026 5027 PP(pp_break) 5028 { 5029 dVAR; 5030 I32 cxix; 5031 PERL_CONTEXT *cx; 5032 5033 cxix = dopoptogiven(cxstack_ix); 5034 if (cxix < 0) 5035 DIE(aTHX_ "Can't \"break\" outside a given block"); 5036 5037 cx = &cxstack[cxix]; 5038 if (CxFOREACH(cx)) 5039 DIE(aTHX_ "Can't \"break\" in a loop topicalizer"); 5040 5041 if (cxix < cxstack_ix) 5042 dounwind(cxix); 5043 5044 /* Restore the sp at the time we entered the given block */ 5045 TOPBLOCK(cx); 5046 5047 return cx->blk_givwhen.leave_op; 5048 } 5049 5050 static MAGIC * 5051 S_doparseform(pTHX_ SV *sv) 5052 { 5053 STRLEN len; 5054 char *s = SvPV(sv, len); 5055 char *send; 5056 char *base = NULL; /* start of current field */ 5057 I32 skipspaces = 0; /* number of contiguous spaces seen */ 5058 bool noblank = FALSE; /* ~ or ~~ seen on this line */ 5059 bool repeat = FALSE; /* ~~ seen on this line */ 5060 bool postspace = FALSE; /* a text field may need right padding */ 5061 U32 *fops; 5062 U32 *fpc; 5063 U32 *linepc = NULL; /* position of last FF_LINEMARK */ 5064 I32 arg; 5065 bool ischop; /* it's a ^ rather than a @ */ 5066 bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */ 5067 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */ 5068 MAGIC *mg = NULL; 5069 SV *sv_copy; 5070 5071 PERL_ARGS_ASSERT_DOPARSEFORM; 5072 5073 if (len == 0) 5074 Perl_croak(aTHX_ "Null picture in formline"); 5075 5076 if (SvTYPE(sv) >= SVt_PVMG) { 5077 /* This might, of course, still return NULL. */ 5078 mg = mg_find(sv, PERL_MAGIC_fm); 5079 } else { 5080 sv_upgrade(sv, SVt_PVMG); 5081 } 5082 5083 if (mg) { 5084 /* still the same as previously-compiled string? */ 5085 SV *old = mg->mg_obj; 5086 if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv)) 5087 && len == SvCUR(old) 5088 && strnEQ(SvPVX(old), SvPVX(sv), len) 5089 ) { 5090 DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n")); 5091 return mg; 5092 } 5093 5094 DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n")); 5095 Safefree(mg->mg_ptr); 5096 mg->mg_ptr = NULL; 5097 SvREFCNT_dec(old); 5098 mg->mg_obj = NULL; 5099 } 5100 else { 5101 DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n")); 5102 mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0); 5103 } 5104 5105 sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv)); 5106 s = SvPV(sv_copy, len); /* work on the copy, not the original */ 5107 send = s + len; 5108 5109 5110 /* estimate the buffer size needed */ 5111 for (base = s; s <= send; s++) { 5112 if (*s == '\n' || *s == '@' || *s == '^') 5113 maxops += 10; 5114 } 5115 s = base; 5116 base = NULL; 5117 5118 Newx(fops, maxops, U32); 5119 fpc = fops; 5120 5121 if (s < send) { 5122 linepc = fpc; 5123 *fpc++ = FF_LINEMARK; 5124 noblank = repeat = FALSE; 5125 base = s; 5126 } 5127 5128 while (s <= send) { 5129 switch (*s++) { 5130 default: 5131 skipspaces = 0; 5132 continue; 5133 5134 case '~': 5135 if (*s == '~') { 5136 repeat = TRUE; 5137 skipspaces++; 5138 s++; 5139 } 5140 noblank = TRUE; 5141 /* FALL THROUGH */ 5142 case ' ': case '\t': 5143 skipspaces++; 5144 continue; 5145 case 0: 5146 if (s < send) { 5147 skipspaces = 0; 5148 continue; 5149 } /* else FALL THROUGH */ 5150 case '\n': 5151 arg = s - base; 5152 skipspaces++; 5153 arg -= skipspaces; 5154 if (arg) { 5155 if (postspace) 5156 *fpc++ = FF_SPACE; 5157 *fpc++ = FF_LITERAL; 5158 *fpc++ = (U32)arg; 5159 } 5160 postspace = FALSE; 5161 if (s <= send) 5162 skipspaces--; 5163 if (skipspaces) { 5164 *fpc++ = FF_SKIP; 5165 *fpc++ = (U32)skipspaces; 5166 } 5167 skipspaces = 0; 5168 if (s <= send) 5169 *fpc++ = FF_NEWLINE; 5170 if (noblank) { 5171 *fpc++ = FF_BLANK; 5172 if (repeat) 5173 arg = fpc - linepc + 1; 5174 else 5175 arg = 0; 5176 *fpc++ = (U32)arg; 5177 } 5178 if (s < send) { 5179 linepc = fpc; 5180 *fpc++ = FF_LINEMARK; 5181 noblank = repeat = FALSE; 5182 base = s; 5183 } 5184 else 5185 s++; 5186 continue; 5187 5188 case '@': 5189 case '^': 5190 ischop = s[-1] == '^'; 5191 5192 if (postspace) { 5193 *fpc++ = FF_SPACE; 5194 postspace = FALSE; 5195 } 5196 arg = (s - base) - 1; 5197 if (arg) { 5198 *fpc++ = FF_LITERAL; 5199 *fpc++ = (U32)arg; 5200 } 5201 5202 base = s - 1; 5203 *fpc++ = FF_FETCH; 5204 if (*s == '*') { /* @* or ^* */ 5205 s++; 5206 *fpc++ = 2; /* skip the @* or ^* */ 5207 if (ischop) { 5208 *fpc++ = FF_LINESNGL; 5209 *fpc++ = FF_CHOP; 5210 } else 5211 *fpc++ = FF_LINEGLOB; 5212 } 5213 else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */ 5214 arg = ischop ? FORM_NUM_BLANK : 0; 5215 base = s - 1; 5216 while (*s == '#') 5217 s++; 5218 if (*s == '.') { 5219 const char * const f = ++s; 5220 while (*s == '#') 5221 s++; 5222 arg |= FORM_NUM_POINT + (s - f); 5223 } 5224 *fpc++ = s - base; /* fieldsize for FETCH */ 5225 *fpc++ = FF_DECIMAL; 5226 *fpc++ = (U32)arg; 5227 unchopnum |= ! ischop; 5228 } 5229 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */ 5230 arg = ischop ? FORM_NUM_BLANK : 0; 5231 base = s - 1; 5232 s++; /* skip the '0' first */ 5233 while (*s == '#') 5234 s++; 5235 if (*s == '.') { 5236 const char * const f = ++s; 5237 while (*s == '#') 5238 s++; 5239 arg |= FORM_NUM_POINT + (s - f); 5240 } 5241 *fpc++ = s - base; /* fieldsize for FETCH */ 5242 *fpc++ = FF_0DECIMAL; 5243 *fpc++ = (U32)arg; 5244 unchopnum |= ! ischop; 5245 } 5246 else { /* text field */ 5247 I32 prespace = 0; 5248 bool ismore = FALSE; 5249 5250 if (*s == '>') { 5251 while (*++s == '>') ; 5252 prespace = FF_SPACE; 5253 } 5254 else if (*s == '|') { 5255 while (*++s == '|') ; 5256 prespace = FF_HALFSPACE; 5257 postspace = TRUE; 5258 } 5259 else { 5260 if (*s == '<') 5261 while (*++s == '<') ; 5262 postspace = TRUE; 5263 } 5264 if (*s == '.' && s[1] == '.' && s[2] == '.') { 5265 s += 3; 5266 ismore = TRUE; 5267 } 5268 *fpc++ = s - base; /* fieldsize for FETCH */ 5269 5270 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL; 5271 5272 if (prespace) 5273 *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */ 5274 *fpc++ = FF_ITEM; 5275 if (ismore) 5276 *fpc++ = FF_MORE; 5277 if (ischop) 5278 *fpc++ = FF_CHOP; 5279 } 5280 base = s; 5281 skipspaces = 0; 5282 continue; 5283 } 5284 } 5285 *fpc++ = FF_END; 5286 5287 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */ 5288 arg = fpc - fops; 5289 5290 mg->mg_ptr = (char *) fops; 5291 mg->mg_len = arg * sizeof(U32); 5292 mg->mg_obj = sv_copy; 5293 mg->mg_flags |= MGf_REFCOUNTED; 5294 5295 if (unchopnum && repeat) 5296 Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)"); 5297 5298 return mg; 5299 } 5300 5301 5302 STATIC bool 5303 S_num_overflow(NV value, I32 fldsize, I32 frcsize) 5304 { 5305 /* Can value be printed in fldsize chars, using %*.*f ? */ 5306 NV pwr = 1; 5307 NV eps = 0.5; 5308 bool res = FALSE; 5309 int intsize = fldsize - (value < 0 ? 1 : 0); 5310 5311 if (frcsize & FORM_NUM_POINT) 5312 intsize--; 5313 frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK); 5314 intsize -= frcsize; 5315 5316 while (intsize--) pwr *= 10.0; 5317 while (frcsize--) eps /= 10.0; 5318 5319 if( value >= 0 ){ 5320 if (value + eps >= pwr) 5321 res = TRUE; 5322 } else { 5323 if (value - eps <= -pwr) 5324 res = TRUE; 5325 } 5326 return res; 5327 } 5328 5329 static I32 5330 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) 5331 { 5332 dVAR; 5333 SV * const datasv = FILTER_DATA(idx); 5334 const int filter_has_file = IoLINES(datasv); 5335 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv)); 5336 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv)); 5337 int status = 0; 5338 SV *upstream; 5339 STRLEN got_len; 5340 char *got_p = NULL; 5341 char *prune_from = NULL; 5342 bool read_from_cache = FALSE; 5343 STRLEN umaxlen; 5344 SV *err = NULL; 5345 5346 PERL_ARGS_ASSERT_RUN_USER_FILTER; 5347 5348 assert(maxlen >= 0); 5349 umaxlen = maxlen; 5350 5351 /* I was having segfault trouble under Linux 2.2.5 after a 5352 parse error occured. (Had to hack around it with a test 5353 for PL_parser->error_count == 0.) Solaris doesn't segfault -- 5354 not sure where the trouble is yet. XXX */ 5355 5356 { 5357 SV *const cache = datasv; 5358 if (SvOK(cache)) { 5359 STRLEN cache_len; 5360 const char *cache_p = SvPV(cache, cache_len); 5361 STRLEN take = 0; 5362 5363 if (umaxlen) { 5364 /* Running in block mode and we have some cached data already. 5365 */ 5366 if (cache_len >= umaxlen) { 5367 /* In fact, so much data we don't even need to call 5368 filter_read. */ 5369 take = umaxlen; 5370 } 5371 } else { 5372 const char *const first_nl = 5373 (const char *)memchr(cache_p, '\n', cache_len); 5374 if (first_nl) { 5375 take = first_nl + 1 - cache_p; 5376 } 5377 } 5378 if (take) { 5379 sv_catpvn(buf_sv, cache_p, take); 5380 sv_chop(cache, cache_p + take); 5381 /* Definitely not EOF */ 5382 return 1; 5383 } 5384 5385 sv_catsv(buf_sv, cache); 5386 if (umaxlen) { 5387 umaxlen -= cache_len; 5388 } 5389 SvOK_off(cache); 5390 read_from_cache = TRUE; 5391 } 5392 } 5393 5394 /* Filter API says that the filter appends to the contents of the buffer. 5395 Usually the buffer is "", so the details don't matter. But if it's not, 5396 then clearly what it contains is already filtered by this filter, so we 5397 don't want to pass it in a second time. 5398 I'm going to use a mortal in case the upstream filter croaks. */ 5399 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv)) 5400 ? sv_newmortal() : buf_sv; 5401 SvUPGRADE(upstream, SVt_PV); 5402 5403 if (filter_has_file) { 5404 status = FILTER_READ(idx+1, upstream, 0); 5405 } 5406 5407 if (filter_sub && status >= 0) { 5408 dSP; 5409 int count; 5410 5411 ENTER_with_name("call_filter_sub"); 5412 SAVE_DEFSV; 5413 SAVETMPS; 5414 EXTEND(SP, 2); 5415 5416 DEFSV_set(upstream); 5417 PUSHMARK(SP); 5418 mPUSHi(0); 5419 if (filter_state) { 5420 PUSHs(filter_state); 5421 } 5422 PUTBACK; 5423 count = call_sv(filter_sub, G_SCALAR|G_EVAL); 5424 SPAGAIN; 5425 5426 if (count > 0) { 5427 SV *out = POPs; 5428 if (SvOK(out)) { 5429 status = SvIV(out); 5430 } 5431 else { 5432 SV * const errsv = ERRSV; 5433 if (SvTRUE_NN(errsv)) 5434 err = newSVsv(errsv); 5435 } 5436 } 5437 5438 PUTBACK; 5439 FREETMPS; 5440 LEAVE_with_name("call_filter_sub"); 5441 } 5442 5443 if (SvIsCOW(upstream)) sv_force_normal(upstream); 5444 if(!err && SvOK(upstream)) { 5445 got_p = SvPV(upstream, got_len); 5446 if (umaxlen) { 5447 if (got_len > umaxlen) { 5448 prune_from = got_p + umaxlen; 5449 } 5450 } else { 5451 char *const first_nl = (char *)memchr(got_p, '\n', got_len); 5452 if (first_nl && first_nl + 1 < got_p + got_len) { 5453 /* There's a second line here... */ 5454 prune_from = first_nl + 1; 5455 } 5456 } 5457 } 5458 if (!err && prune_from) { 5459 /* Oh. Too long. Stuff some in our cache. */ 5460 STRLEN cached_len = got_p + got_len - prune_from; 5461 SV *const cache = datasv; 5462 5463 if (SvOK(cache)) { 5464 /* Cache should be empty. */ 5465 assert(!SvCUR(cache)); 5466 } 5467 5468 sv_setpvn(cache, prune_from, cached_len); 5469 /* If you ask for block mode, you may well split UTF-8 characters. 5470 "If it breaks, you get to keep both parts" 5471 (Your code is broken if you don't put them back together again 5472 before something notices.) */ 5473 if (SvUTF8(upstream)) { 5474 SvUTF8_on(cache); 5475 } 5476 SvCUR_set(upstream, got_len - cached_len); 5477 *prune_from = 0; 5478 /* Can't yet be EOF */ 5479 if (status == 0) 5480 status = 1; 5481 } 5482 5483 /* If they are at EOF but buf_sv has something in it, then they may never 5484 have touched the SV upstream, so it may be undefined. If we naively 5485 concatenate it then we get a warning about use of uninitialised value. 5486 */ 5487 if (!err && upstream != buf_sv && 5488 (SvOK(upstream) || SvGMAGICAL(upstream))) { 5489 sv_catsv(buf_sv, upstream); 5490 } 5491 5492 if (status <= 0) { 5493 IoLINES(datasv) = 0; 5494 if (filter_state) { 5495 SvREFCNT_dec(filter_state); 5496 IoTOP_GV(datasv) = NULL; 5497 } 5498 if (filter_sub) { 5499 SvREFCNT_dec(filter_sub); 5500 IoBOTTOM_GV(datasv) = NULL; 5501 } 5502 filter_del(S_run_user_filter); 5503 } 5504 5505 if (err) 5506 croak_sv(err); 5507 5508 if (status == 0 && read_from_cache) { 5509 /* If we read some data from the cache (and by getting here it implies 5510 that we emptied the cache) then we aren't yet at EOF, and mustn't 5511 report that to our caller. */ 5512 return 1; 5513 } 5514 return status; 5515 } 5516 5517 /* perhaps someone can come up with a better name for 5518 this? it is not really "absolute", per se ... */ 5519 static bool 5520 S_path_is_absolute(const char *name) 5521 { 5522 PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE; 5523 5524 if (PERL_FILE_IS_ABSOLUTE(name) 5525 #ifdef WIN32 5526 || (*name == '.' && ((name[1] == '/' || 5527 (name[1] == '.' && name[2] == '/')) 5528 || (name[1] == '\\' || 5529 ( name[1] == '.' && name[2] == '\\'))) 5530 ) 5531 #else 5532 || (*name == '.' && (name[1] == '/' || 5533 (name[1] == '.' && name[2] == '/'))) 5534 #endif 5535 ) 5536 { 5537 return TRUE; 5538 } 5539 else 5540 return FALSE; 5541 } 5542 5543 /* 5544 * Local variables: 5545 * c-indentation-style: bsd 5546 * c-basic-offset: 4 5547 * indent-tabs-mode: nil 5548 * End: 5549 * 5550 * ex: set ts=8 sts=4 sw=4 et: 5551 */ 5552