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