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