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