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 (strchr(PL_chopset, *s)) { 657 /* provisional split point */ 658 /* for a non-space split char, we include 659 * the split char; hence the '+1' */ 660 chophere = s + 1; 661 itemsize = size; 662 } 663 if (size == fieldsize) 664 break; 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 CALLRUNOPS(aTHX); 3351 break; 3352 case 3: 3353 /* die caught by an inner eval - continue inner loop */ 3354 if (PL_restartop && PL_restartjmpenv == PL_top_env) { 3355 PL_restartjmpenv = NULL; 3356 PL_op = PL_restartop; 3357 PL_restartop = 0; 3358 goto redo_body; 3359 } 3360 /* FALLTHROUGH */ 3361 default: 3362 JMPENV_POP; 3363 PL_op = oldop; 3364 JMPENV_JUMP(ret); 3365 NOT_REACHED; /* NOTREACHED */ 3366 } 3367 JMPENV_POP; 3368 PL_op = oldop; 3369 return NULL; 3370 } 3371 3372 3373 /* 3374 =for apidoc find_runcv 3375 3376 Locate the CV corresponding to the currently executing sub or eval. 3377 If C<db_seqp> is non_null, skip CVs that are in the DB package and populate 3378 C<*db_seqp> with the cop sequence number at the point that the DB:: code was 3379 entered. (This allows debuggers to eval in the scope of the breakpoint 3380 rather than in the scope of the debugger itself.) 3381 3382 =cut 3383 */ 3384 3385 CV* 3386 Perl_find_runcv(pTHX_ U32 *db_seqp) 3387 { 3388 return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp); 3389 } 3390 3391 /* If this becomes part of the API, it might need a better name. */ 3392 CV * 3393 Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp) 3394 { 3395 PERL_SI *si; 3396 int level = 0; 3397 3398 if (db_seqp) 3399 *db_seqp = 3400 PL_curcop == &PL_compiling 3401 ? PL_cop_seqmax 3402 : PL_curcop->cop_seq; 3403 3404 for (si = PL_curstackinfo; si; si = si->si_prev) { 3405 I32 ix; 3406 for (ix = si->si_cxix; ix >= 0; ix--) { 3407 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]); 3408 CV *cv = NULL; 3409 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { 3410 cv = cx->blk_sub.cv; 3411 /* skip DB:: code */ 3412 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) { 3413 *db_seqp = cx->blk_oldcop->cop_seq; 3414 continue; 3415 } 3416 if (cx->cx_type & CXp_SUB_RE) 3417 continue; 3418 } 3419 else if (CxTYPE(cx) == CXt_EVAL && !CxEVALBLOCK(cx)) 3420 cv = cx->blk_eval.cv; 3421 if (cv) { 3422 switch (cond) { 3423 case FIND_RUNCV_padid_eq: 3424 if (!CvPADLIST(cv) 3425 || CvPADLIST(cv)->xpadl_id != (U32)arg) 3426 continue; 3427 return cv; 3428 case FIND_RUNCV_level_eq: 3429 if (level++ != arg) continue; 3430 /* FALLTHROUGH */ 3431 default: 3432 return cv; 3433 } 3434 } 3435 } 3436 } 3437 return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv; 3438 } 3439 3440 3441 /* Run yyparse() in a setjmp wrapper. Returns: 3442 * 0: yyparse() successful 3443 * 1: yyparse() failed 3444 * 3: yyparse() died 3445 */ 3446 STATIC int 3447 S_try_yyparse(pTHX_ int gramtype) 3448 { 3449 int ret; 3450 dJMPENV; 3451 3452 assert(CxTYPE(CX_CUR()) == CXt_EVAL); 3453 JMPENV_PUSH(ret); 3454 switch (ret) { 3455 case 0: 3456 ret = yyparse(gramtype) ? 1 : 0; 3457 break; 3458 case 3: 3459 break; 3460 default: 3461 JMPENV_POP; 3462 JMPENV_JUMP(ret); 3463 NOT_REACHED; /* NOTREACHED */ 3464 } 3465 JMPENV_POP; 3466 return ret; 3467 } 3468 3469 3470 /* Compile a require/do or an eval ''. 3471 * 3472 * outside is the lexically enclosing CV (if any) that invoked us. 3473 * seq is the current COP scope value. 3474 * hh is the saved hints hash, if any. 3475 * 3476 * Returns a bool indicating whether the compile was successful; if so, 3477 * PL_eval_start contains the first op of the compiled code; otherwise, 3478 * pushes undef. 3479 * 3480 * This function is called from two places: pp_require and pp_entereval. 3481 * These can be distinguished by whether PL_op is entereval. 3482 */ 3483 3484 STATIC bool 3485 S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh) 3486 { 3487 dSP; 3488 OP * const saveop = PL_op; 3489 bool clear_hints = saveop->op_type != OP_ENTEREVAL; 3490 COP * const oldcurcop = PL_curcop; 3491 bool in_require = (saveop->op_type == OP_REQUIRE); 3492 int yystatus; 3493 CV *evalcv; 3494 3495 PL_in_eval = (in_require 3496 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL)) 3497 : (EVAL_INEVAL | 3498 ((PL_op->op_private & OPpEVAL_RE_REPARSING) 3499 ? EVAL_RE_REPARSING : 0))); 3500 3501 PUSHMARK(SP); 3502 3503 evalcv = MUTABLE_CV(newSV_type(SVt_PVCV)); 3504 CvEVAL_on(evalcv); 3505 assert(CxTYPE(CX_CUR()) == CXt_EVAL); 3506 CX_CUR()->blk_eval.cv = evalcv; 3507 CX_CUR()->blk_gimme = gimme; 3508 3509 CvOUTSIDE_SEQ(evalcv) = seq; 3510 CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside)); 3511 3512 /* set up a scratch pad */ 3513 3514 CvPADLIST_set(evalcv, pad_new(padnew_SAVE)); 3515 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */ 3516 3517 3518 SAVEMORTALIZESV(evalcv); /* must remain until end of current statement */ 3519 3520 /* make sure we compile in the right package */ 3521 3522 if (CopSTASH_ne(PL_curcop, PL_curstash)) { 3523 SAVEGENERICSV(PL_curstash); 3524 PL_curstash = (HV *)CopSTASH(PL_curcop); 3525 if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL; 3526 else { 3527 SvREFCNT_inc_simple_void(PL_curstash); 3528 save_item(PL_curstname); 3529 sv_sethek(PL_curstname, HvNAME_HEK(PL_curstash)); 3530 } 3531 } 3532 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */ 3533 SAVESPTR(PL_beginav); 3534 PL_beginav = newAV(); 3535 SAVEFREESV(PL_beginav); 3536 SAVESPTR(PL_unitcheckav); 3537 PL_unitcheckav = newAV(); 3538 SAVEFREESV(PL_unitcheckav); 3539 3540 3541 ENTER_with_name("evalcomp"); 3542 SAVESPTR(PL_compcv); 3543 PL_compcv = evalcv; 3544 3545 /* try to compile it */ 3546 3547 PL_eval_root = NULL; 3548 PL_curcop = &PL_compiling; 3549 if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL)) 3550 PL_in_eval |= EVAL_KEEPERR; 3551 else 3552 CLEAR_ERRSV(); 3553 3554 SAVEHINTS(); 3555 if (clear_hints) { 3556 PL_hints = HINTS_DEFAULT; 3557 PL_prevailing_version = 0; 3558 hv_clear(GvHV(PL_hintgv)); 3559 CLEARFEATUREBITS(); 3560 } 3561 else { 3562 PL_hints = saveop->op_private & OPpEVAL_COPHH 3563 ? oldcurcop->cop_hints : (U32)saveop->op_targ; 3564 3565 /* making 'use re eval' not be in scope when compiling the 3566 * qr/mabye_has_runtime_code_block/ ensures that we don't get 3567 * infinite recursion when S_has_runtime_code() gives a false 3568 * positive: the second time round, HINT_RE_EVAL isn't set so we 3569 * don't bother calling S_has_runtime_code() */ 3570 if (PL_in_eval & EVAL_RE_REPARSING) 3571 PL_hints &= ~HINT_RE_EVAL; 3572 3573 if (hh) { 3574 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */ 3575 SvREFCNT_dec(GvHV(PL_hintgv)); 3576 GvHV(PL_hintgv) = hh; 3577 FETCHFEATUREBITSHH(hh); 3578 } 3579 } 3580 SAVECOMPILEWARNINGS(); 3581 if (clear_hints) { 3582 if (PL_dowarn & G_WARN_ALL_ON) 3583 PL_compiling.cop_warnings = pWARN_ALL ; 3584 else if (PL_dowarn & G_WARN_ALL_OFF) 3585 PL_compiling.cop_warnings = pWARN_NONE ; 3586 else 3587 PL_compiling.cop_warnings = pWARN_STD ; 3588 } 3589 else { 3590 PL_compiling.cop_warnings = 3591 DUP_WARNINGS(oldcurcop->cop_warnings); 3592 cophh_free(CopHINTHASH_get(&PL_compiling)); 3593 if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) { 3594 /* The label, if present, is the first entry on the chain. So rather 3595 than writing a blank label in front of it (which involves an 3596 allocation), just use the next entry in the chain. */ 3597 PL_compiling.cop_hints_hash 3598 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next); 3599 /* Check the assumption that this removed the label. */ 3600 assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL); 3601 } 3602 else 3603 PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash); 3604 } 3605 3606 CALL_BLOCK_HOOKS(bhk_eval, saveop); 3607 3608 /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>, 3609 * so honour CATCH_GET and trap it here if necessary */ 3610 3611 3612 /* compile the code */ 3613 yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG); 3614 3615 if (yystatus || PL_parser->error_count || !PL_eval_root) { 3616 PERL_CONTEXT *cx; 3617 SV *errsv; 3618 3619 PL_op = saveop; 3620 /* note that if yystatus == 3, then the require/eval died during 3621 * compilation, so the EVAL CX block has already been popped, and 3622 * various vars restored */ 3623 if (yystatus != 3) { 3624 if (PL_eval_root) { 3625 op_free(PL_eval_root); 3626 PL_eval_root = NULL; 3627 } 3628 SP = PL_stack_base + POPMARK; /* pop original mark */ 3629 cx = CX_CUR(); 3630 assert(CxTYPE(cx) == CXt_EVAL); 3631 /* pop the CXt_EVAL, and if was a require, croak */ 3632 S_pop_eval_context_maybe_croak(aTHX_ cx, ERRSV, 2); 3633 } 3634 3635 /* die_unwind() re-croaks when in require, having popped the 3636 * require EVAL context. So we should never catch a require 3637 * exception here */ 3638 assert(!in_require); 3639 3640 errsv = ERRSV; 3641 if (!*(SvPV_nolen_const(errsv))) 3642 sv_setpvs(errsv, "Compilation error"); 3643 3644 if (gimme != G_LIST) PUSHs(&PL_sv_undef); 3645 PUTBACK; 3646 return FALSE; 3647 } 3648 3649 /* Compilation successful. Now clean up */ 3650 3651 LEAVE_with_name("evalcomp"); 3652 3653 CopLINE_set(&PL_compiling, 0); 3654 SAVEFREEOP(PL_eval_root); 3655 cv_forget_slab(evalcv); 3656 3657 DEBUG_x(dump_eval()); 3658 3659 /* Register with debugger: */ 3660 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) { 3661 CV * const cv = get_cvs("DB::postponed", 0); 3662 if (cv) { 3663 dSP; 3664 PUSHMARK(SP); 3665 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling))); 3666 PUTBACK; 3667 call_sv(MUTABLE_SV(cv), G_DISCARD); 3668 } 3669 } 3670 3671 if (PL_unitcheckav) { 3672 OP *es = PL_eval_start; 3673 call_list(PL_scopestack_ix, PL_unitcheckav); 3674 PL_eval_start = es; 3675 } 3676 3677 CvDEPTH(evalcv) = 1; 3678 SP = PL_stack_base + POPMARK; /* pop original mark */ 3679 PL_op = saveop; /* The caller may need it. */ 3680 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */ 3681 3682 PUTBACK; 3683 return TRUE; 3684 } 3685 3686 /* Return NULL if the file doesn't exist or isn't a file; 3687 * else return PerlIO_openn(). 3688 */ 3689 3690 STATIC PerlIO * 3691 S_check_type_and_open(pTHX_ SV *name) 3692 { 3693 Stat_t st; 3694 STRLEN len; 3695 PerlIO * retio; 3696 const char *p = SvPV_const(name, len); 3697 int st_rc; 3698 3699 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN; 3700 3701 /* checking here captures a reasonable error message when 3702 * PERL_DISABLE_PMC is true, but when PMC checks are enabled, the 3703 * user gets a confusing message about looking for the .pmc file 3704 * rather than for the .pm file so do the check in S_doopen_pm when 3705 * PMC is on instead of here. S_doopen_pm calls this func. 3706 * This check prevents a \0 in @INC causing problems. 3707 */ 3708 #ifdef PERL_DISABLE_PMC 3709 if (!IS_SAFE_PATHNAME(p, len, "require")) 3710 return NULL; 3711 #endif 3712 3713 /* on Win32 stat is expensive (it does an open() and close() twice and 3714 a couple other IO calls), the open will fail with a dir on its own with 3715 errno EACCES, so only do a stat to separate a dir from a real EACCES 3716 caused by user perms */ 3717 #ifndef WIN32 3718 st_rc = PerlLIO_stat(p, &st); 3719 3720 if (st_rc < 0) 3721 return NULL; 3722 else { 3723 int eno; 3724 if(S_ISBLK(st.st_mode)) { 3725 eno = EINVAL; 3726 goto not_file; 3727 } 3728 else if(S_ISDIR(st.st_mode)) { 3729 eno = EISDIR; 3730 not_file: 3731 errno = eno; 3732 return NULL; 3733 } 3734 } 3735 #endif 3736 3737 retio = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name); 3738 #ifdef WIN32 3739 /* EACCES stops the INC search early in pp_require to implement 3740 feature RT #113422 */ 3741 if(!retio && errno == EACCES) { /* exists but probably a directory */ 3742 int eno; 3743 st_rc = PerlLIO_stat(p, &st); 3744 if (st_rc >= 0) { 3745 if(S_ISDIR(st.st_mode)) 3746 eno = EISDIR; 3747 else if(S_ISBLK(st.st_mode)) 3748 eno = EINVAL; 3749 else 3750 eno = EACCES; 3751 errno = eno; 3752 } 3753 } 3754 #endif 3755 return retio; 3756 } 3757 3758 /* doopen_pm(): return the equivalent of PerlIO_openn() on the given name, 3759 * but first check for bad names (\0) and non-files. 3760 * Also if the filename ends in .pm and unless PERL_DISABLE_PMC, 3761 * try loading Foo.pmc first. 3762 */ 3763 #ifndef PERL_DISABLE_PMC 3764 STATIC PerlIO * 3765 S_doopen_pm(pTHX_ SV *name) 3766 { 3767 STRLEN namelen; 3768 const char *p = SvPV_const(name, namelen); 3769 3770 PERL_ARGS_ASSERT_DOOPEN_PM; 3771 3772 /* check the name before trying for the .pmc name to avoid the 3773 * warning referring to the .pmc which the user probably doesn't 3774 * know or care about 3775 */ 3776 if (!IS_SAFE_PATHNAME(p, namelen, "require")) 3777 return NULL; 3778 3779 if (memENDPs(p, namelen, ".pm")) { 3780 SV *const pmcsv = sv_newmortal(); 3781 PerlIO * pmcio; 3782 3783 SvSetSV_nosteal(pmcsv,name); 3784 sv_catpvs(pmcsv, "c"); 3785 3786 pmcio = check_type_and_open(pmcsv); 3787 if (pmcio) 3788 return pmcio; 3789 } 3790 return check_type_and_open(name); 3791 } 3792 #else 3793 # define doopen_pm(name) check_type_and_open(name) 3794 #endif /* !PERL_DISABLE_PMC */ 3795 3796 /* require doesn't search in @INC for absolute names, or when the name is 3797 explicitly relative the current directory: i.e. ./, ../ */ 3798 PERL_STATIC_INLINE bool 3799 S_path_is_searchable(const char *name) 3800 { 3801 PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE; 3802 3803 if (PERL_FILE_IS_ABSOLUTE(name) 3804 #ifdef WIN32 3805 || (*name == '.' && ((name[1] == '/' || 3806 (name[1] == '.' && name[2] == '/')) 3807 || (name[1] == '\\' || 3808 ( name[1] == '.' && name[2] == '\\'))) 3809 ) 3810 #else 3811 || (*name == '.' && (name[1] == '/' || 3812 (name[1] == '.' && name[2] == '/'))) 3813 #endif 3814 ) 3815 { 3816 return FALSE; 3817 } 3818 else 3819 return TRUE; 3820 } 3821 3822 3823 /* implement 'require 5.010001' */ 3824 3825 static OP * 3826 S_require_version(pTHX_ SV *sv) 3827 { 3828 dSP; 3829 3830 sv = sv_2mortal(new_version(sv)); 3831 if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0)) 3832 upg_version(PL_patchlevel, TRUE); 3833 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) { 3834 if ( vcmp(sv,PL_patchlevel) <= 0 ) 3835 DIE(aTHX_ "Perls since %" SVf " too modern--this is %" SVf ", stopped", 3836 SVfARG(sv_2mortal(vnormal(sv))), 3837 SVfARG(sv_2mortal(vnormal(PL_patchlevel))) 3838 ); 3839 } 3840 else { 3841 if ( vcmp(sv,PL_patchlevel) > 0 ) { 3842 I32 first = 0; 3843 AV *lav; 3844 SV * const req = SvRV(sv); 3845 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE); 3846 3847 /* get the left hand term */ 3848 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE))); 3849 3850 first = SvIV(*av_fetch(lav,0,0)); 3851 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */ 3852 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */ 3853 || av_count(lav) > 2 /* FP with > 3 digits */ 3854 || strstr(SvPVX(pv),".0") /* FP with leading 0 */ 3855 ) { 3856 DIE(aTHX_ "Perl %" SVf " required--this is only " 3857 "%" SVf ", stopped", 3858 SVfARG(sv_2mortal(vnormal(req))), 3859 SVfARG(sv_2mortal(vnormal(PL_patchlevel))) 3860 ); 3861 } 3862 else { /* probably 'use 5.10' or 'use 5.8' */ 3863 SV *hintsv; 3864 I32 second = 0; 3865 3866 if (av_count(lav) > 1) 3867 second = SvIV(*av_fetch(lav,1,0)); 3868 3869 second /= second >= 600 ? 100 : 10; 3870 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0", 3871 (int)first, (int)second); 3872 upg_version(hintsv, TRUE); 3873 3874 DIE(aTHX_ "Perl %" SVf " required (did you mean %" SVf "?)" 3875 "--this is only %" SVf ", stopped", 3876 SVfARG(sv_2mortal(vnormal(req))), 3877 SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))), 3878 SVfARG(sv_2mortal(vnormal(PL_patchlevel))) 3879 ); 3880 } 3881 } 3882 } 3883 3884 RETPUSHYES; 3885 } 3886 3887 /* Handle C<require Foo::Bar>, C<require "Foo/Bar.pm"> and C<do "Foo.pm">. 3888 * The first form will have already been converted at compile time to 3889 * the second form */ 3890 3891 static OP * 3892 S_require_file(pTHX_ SV *sv) 3893 { 3894 dSP; 3895 3896 PERL_CONTEXT *cx; 3897 const char *name; 3898 STRLEN len; 3899 char * unixname; 3900 STRLEN unixlen; 3901 #ifdef VMS 3902 int vms_unixname = 0; 3903 char *unixdir; 3904 #endif 3905 /* tryname is the actual pathname (with @INC prefix) which was loaded. 3906 * It's stored as a value in %INC, and used for error messages */ 3907 const char *tryname = NULL; 3908 SV *namesv = NULL; /* SV equivalent of tryname */ 3909 const U8 gimme = GIMME_V; 3910 int filter_has_file = 0; 3911 PerlIO *tryrsfp = NULL; 3912 SV *filter_cache = NULL; 3913 SV *filter_state = NULL; 3914 SV *filter_sub = NULL; 3915 SV *hook_sv = NULL; 3916 OP *op; 3917 int saved_errno; 3918 bool path_searchable; 3919 I32 old_savestack_ix; 3920 const bool op_is_require = PL_op->op_type == OP_REQUIRE; 3921 const char *const op_name = op_is_require ? "require" : "do"; 3922 SV ** svp_cached = NULL; 3923 3924 assert(op_is_require || PL_op->op_type == OP_DOFILE); 3925 3926 if (!SvOK(sv)) 3927 DIE(aTHX_ "Missing or undefined argument to %s", op_name); 3928 name = SvPV_nomg_const(sv, len); 3929 if (!(name && len > 0 && *name)) 3930 DIE(aTHX_ "Missing or undefined argument to %s", op_name); 3931 3932 #ifndef VMS 3933 /* try to return earlier (save the SAFE_PATHNAME check) if INC already got the name */ 3934 if (op_is_require) { 3935 /* can optimize to only perform one single lookup */ 3936 svp_cached = hv_fetch(GvHVn(PL_incgv), (char*) name, len, 0); 3937 if ( svp_cached && (SvGETMAGIC(*svp_cached), SvOK(*svp_cached)) ) RETPUSHYES; 3938 } 3939 #endif 3940 3941 if (!IS_SAFE_PATHNAME(name, len, op_name)) { 3942 if (!op_is_require) { 3943 CLEAR_ERRSV(); 3944 RETPUSHUNDEF; 3945 } 3946 DIE(aTHX_ "Can't locate %s: %s", 3947 pv_escape(newSVpvs_flags("",SVs_TEMP),name,len,len*2, 3948 NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0), 3949 Strerror(ENOENT)); 3950 } 3951 TAINT_PROPER(op_name); 3952 3953 path_searchable = path_is_searchable(name); 3954 3955 #ifdef VMS 3956 /* The key in the %ENV hash is in the syntax of file passed as the argument 3957 * usually this is in UNIX format, but sometimes in VMS format, which 3958 * can result in a module being pulled in more than once. 3959 * To prevent this, the key must be stored in UNIX format if the VMS 3960 * name can be translated to UNIX. 3961 */ 3962 3963 if ((unixname = 3964 tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1))))) 3965 != NULL) { 3966 unixlen = strlen(unixname); 3967 vms_unixname = 1; 3968 } 3969 else 3970 #endif 3971 { 3972 /* if not VMS or VMS name can not be translated to UNIX, pass it 3973 * through. 3974 */ 3975 unixname = (char *) name; 3976 unixlen = len; 3977 } 3978 if (op_is_require) { 3979 /* reuse the previous hv_fetch result if possible */ 3980 SV * const * const svp = svp_cached ? svp_cached : hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0); 3981 if ( svp ) { 3982 /* we already did a get magic if this was cached */ 3983 if (!svp_cached) 3984 SvGETMAGIC(*svp); 3985 if (SvOK(*svp)) 3986 RETPUSHYES; 3987 else 3988 DIE(aTHX_ "Attempt to reload %s aborted.\n" 3989 "Compilation failed in require", unixname); 3990 } 3991 3992 /*XXX OPf_KIDS should always be true? -dapm 4/2017 */ 3993 if (PL_op->op_flags & OPf_KIDS) { 3994 SVOP * const kid = (SVOP*)cUNOP->op_first; 3995 3996 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { 3997 /* Make sure that a bareword module name (e.g. ::Foo::Bar) 3998 * doesn't map to a naughty pathname like /Foo/Bar.pm. 3999 * Note that the parser will normally detect such errors 4000 * at compile time before we reach here, but 4001 * Perl_load_module() can fake up an identical optree 4002 * without going near the parser, and being able to put 4003 * anything as the bareword. So we include a duplicate set 4004 * of checks here at runtime. 4005 */ 4006 const STRLEN package_len = len - 3; 4007 const char slashdot[2] = {'/', '.'}; 4008 #ifdef DOSISH 4009 const char backslashdot[2] = {'\\', '.'}; 4010 #endif 4011 4012 /* Disallow *purported* barewords that map to absolute 4013 filenames, filenames relative to the current or parent 4014 directory, or (*nix) hidden filenames. Also sanity check 4015 that the generated filename ends .pm */ 4016 if (!path_searchable || len < 3 || name[0] == '.' 4017 || !memEQs(name + package_len, len - package_len, ".pm")) 4018 DIE(aTHX_ "Bareword in require maps to disallowed filename \"%" SVf "\"", sv); 4019 if (memchr(name, 0, package_len)) { 4020 /* diag_listed_as: Bareword in require contains "%s" */ 4021 DIE(aTHX_ "Bareword in require contains \"\\0\""); 4022 } 4023 if (ninstr(name, name + package_len, slashdot, 4024 slashdot + sizeof(slashdot))) { 4025 /* diag_listed_as: Bareword in require contains "%s" */ 4026 DIE(aTHX_ "Bareword in require contains \"/.\""); 4027 } 4028 #ifdef DOSISH 4029 if (ninstr(name, name + package_len, backslashdot, 4030 backslashdot + sizeof(backslashdot))) { 4031 /* diag_listed_as: Bareword in require contains "%s" */ 4032 DIE(aTHX_ "Bareword in require contains \"\\.\""); 4033 } 4034 #endif 4035 } 4036 } 4037 } 4038 4039 PERL_DTRACE_PROBE_FILE_LOADING(unixname); 4040 4041 /* Try to locate and open a file, possibly using @INC */ 4042 4043 /* with "/foo/bar.pm", "./foo.pm" and "../foo/bar.pm", try to load 4044 * the file directly rather than via @INC ... */ 4045 if (!path_searchable) { 4046 /* At this point, name is SvPVX(sv) */ 4047 tryname = name; 4048 tryrsfp = doopen_pm(sv); 4049 } 4050 4051 /* ... but if we fail, still search @INC for code references; 4052 * these are applied even on non-searchable paths (except 4053 * if we got EACESS). 4054 * 4055 * For searchable paths, just search @INC normally 4056 */ 4057 if (!tryrsfp && !(errno == EACCES && !path_searchable)) { 4058 AV * const ar = GvAVn(PL_incgv); 4059 SSize_t i; 4060 #ifdef VMS 4061 if (vms_unixname) 4062 #endif 4063 { 4064 SV *nsv = sv; 4065 namesv = newSV_type(SVt_PV); 4066 for (i = 0; i <= AvFILL(ar); i++) { 4067 SV * const dirsv = *av_fetch(ar, i, TRUE); 4068 4069 SvGETMAGIC(dirsv); 4070 if (SvROK(dirsv)) { 4071 int count; 4072 SV **svp; 4073 SV *loader = dirsv; 4074 4075 if (SvTYPE(SvRV(loader)) == SVt_PVAV 4076 && !SvOBJECT(SvRV(loader))) 4077 { 4078 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE); 4079 SvGETMAGIC(loader); 4080 } 4081 4082 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%" UVxf "/%s", 4083 PTR2UV(SvRV(dirsv)), name); 4084 tryname = SvPVX_const(namesv); 4085 tryrsfp = NULL; 4086 4087 if (SvPADTMP(nsv)) { 4088 nsv = sv_newmortal(); 4089 SvSetSV_nosteal(nsv,sv); 4090 } 4091 4092 ENTER_with_name("call_INC"); 4093 SAVETMPS; 4094 EXTEND(SP, 2); 4095 4096 PUSHMARK(SP); 4097 PUSHs(dirsv); 4098 PUSHs(nsv); 4099 PUTBACK; 4100 if (SvGMAGICAL(loader)) { 4101 SV *l = sv_newmortal(); 4102 sv_setsv_nomg(l, loader); 4103 loader = l; 4104 } 4105 if (sv_isobject(loader)) 4106 count = call_method("INC", G_LIST); 4107 else 4108 count = call_sv(loader, G_LIST); 4109 SPAGAIN; 4110 4111 if (count > 0) { 4112 int i = 0; 4113 SV *arg; 4114 4115 SP -= count - 1; 4116 arg = SP[i++]; 4117 4118 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV) 4119 && !isGV_with_GP(SvRV(arg))) { 4120 filter_cache = SvRV(arg); 4121 4122 if (i < count) { 4123 arg = SP[i++]; 4124 } 4125 } 4126 4127 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) { 4128 arg = SvRV(arg); 4129 } 4130 4131 if (isGV_with_GP(arg)) { 4132 IO * const io = GvIO((const GV *)arg); 4133 4134 ++filter_has_file; 4135 4136 if (io) { 4137 tryrsfp = IoIFP(io); 4138 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { 4139 PerlIO_close(IoOFP(io)); 4140 } 4141 IoIFP(io) = NULL; 4142 IoOFP(io) = NULL; 4143 } 4144 4145 if (i < count) { 4146 arg = SP[i++]; 4147 } 4148 } 4149 4150 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) { 4151 filter_sub = arg; 4152 SvREFCNT_inc_simple_void_NN(filter_sub); 4153 4154 if (i < count) { 4155 filter_state = SP[i]; 4156 SvREFCNT_inc_simple_void(filter_state); 4157 } 4158 } 4159 4160 if (!tryrsfp && (filter_cache || filter_sub)) { 4161 tryrsfp = PerlIO_open(BIT_BUCKET, 4162 PERL_SCRIPT_MODE); 4163 } 4164 SP--; 4165 } 4166 4167 /* FREETMPS may free our filter_cache */ 4168 SvREFCNT_inc_simple_void(filter_cache); 4169 4170 PUTBACK; 4171 FREETMPS; 4172 LEAVE_with_name("call_INC"); 4173 4174 /* Now re-mortalize it. */ 4175 sv_2mortal(filter_cache); 4176 4177 /* Adjust file name if the hook has set an %INC entry. 4178 This needs to happen after the FREETMPS above. */ 4179 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0); 4180 if (svp) 4181 tryname = SvPV_nolen_const(*svp); 4182 4183 if (tryrsfp) { 4184 hook_sv = dirsv; 4185 break; 4186 } 4187 4188 filter_has_file = 0; 4189 filter_cache = NULL; 4190 if (filter_state) { 4191 SvREFCNT_dec_NN(filter_state); 4192 filter_state = NULL; 4193 } 4194 if (filter_sub) { 4195 SvREFCNT_dec_NN(filter_sub); 4196 filter_sub = NULL; 4197 } 4198 } 4199 else if (path_searchable) { 4200 /* match against a plain @INC element (non-searchable 4201 * paths are only matched against refs in @INC) */ 4202 const char *dir; 4203 STRLEN dirlen; 4204 4205 if (SvOK(dirsv)) { 4206 dir = SvPV_nomg_const(dirsv, dirlen); 4207 } else { 4208 dir = ""; 4209 dirlen = 0; 4210 } 4211 4212 if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", op_name)) 4213 continue; 4214 #ifdef VMS 4215 if ((unixdir = 4216 tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1))))) 4217 == NULL) 4218 continue; 4219 sv_setpv(namesv, unixdir); 4220 sv_catpv(namesv, unixname); 4221 #else 4222 /* The equivalent of 4223 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name); 4224 but without the need to parse the format string, or 4225 call strlen on either pointer, and with the correct 4226 allocation up front. */ 4227 { 4228 char *tmp = SvGROW(namesv, dirlen + len + 2); 4229 4230 memcpy(tmp, dir, dirlen); 4231 tmp +=dirlen; 4232 4233 /* Avoid '<dir>//<file>' */ 4234 if (!dirlen || *(tmp-1) != '/') { 4235 *tmp++ = '/'; 4236 } else { 4237 /* So SvCUR_set reports the correct length below */ 4238 dirlen--; 4239 } 4240 4241 /* name came from an SV, so it will have a '\0' at the 4242 end that we can copy as part of this memcpy(). */ 4243 memcpy(tmp, name, len + 1); 4244 4245 SvCUR_set(namesv, dirlen + len + 1); 4246 SvPOK_on(namesv); 4247 } 4248 #endif 4249 TAINT_PROPER(op_name); 4250 tryname = SvPVX_const(namesv); 4251 tryrsfp = doopen_pm(namesv); 4252 if (tryrsfp) { 4253 if (tryname[0] == '.' && tryname[1] == '/') { 4254 ++tryname; 4255 while (*++tryname == '/') {} 4256 } 4257 break; 4258 } 4259 else if (errno == EMFILE || errno == EACCES) { 4260 /* no point in trying other paths if out of handles; 4261 * on the other hand, if we couldn't open one of the 4262 * files, then going on with the search could lead to 4263 * unexpected results; see perl #113422 4264 */ 4265 break; 4266 } 4267 } 4268 } 4269 } 4270 } 4271 4272 /* at this point we've ether opened a file (tryrsfp) or set errno */ 4273 4274 saved_errno = errno; /* sv_2mortal can realloc things */ 4275 sv_2mortal(namesv); 4276 if (!tryrsfp) { 4277 /* we failed; croak if require() or return undef if do() */ 4278 if (op_is_require) { 4279 if(saved_errno == EMFILE || saved_errno == EACCES) { 4280 /* diag_listed_as: Can't locate %s */ 4281 DIE(aTHX_ "Can't locate %s: %s: %s", 4282 name, tryname, Strerror(saved_errno)); 4283 } else { 4284 if (path_searchable) { /* did we lookup @INC? */ 4285 AV * const ar = GvAVn(PL_incgv); 4286 SSize_t i; 4287 SV *const msg = newSVpvs_flags("", SVs_TEMP); 4288 SV *const inc = newSVpvs_flags("", SVs_TEMP); 4289 for (i = 0; i <= AvFILL(ar); i++) { 4290 sv_catpvs(inc, " "); 4291 sv_catsv(inc, *av_fetch(ar, i, TRUE)); 4292 } 4293 if (memENDPs(name, len, ".pm")) { 4294 const char *e = name + len - (sizeof(".pm") - 1); 4295 const char *c; 4296 bool utf8 = cBOOL(SvUTF8(sv)); 4297 4298 /* if the filename, when converted from "Foo/Bar.pm" 4299 * form back to Foo::Bar form, makes a valid 4300 * package name (i.e. parseable by C<require 4301 * Foo::Bar>), then emit a hint. 4302 * 4303 * this loop is modelled after the one in 4304 S_parse_ident */ 4305 c = name; 4306 while (c < e) { 4307 if (utf8 && isIDFIRST_utf8_safe(c, e)) { 4308 c += UTF8SKIP(c); 4309 while (c < e && isIDCONT_utf8_safe( 4310 (const U8*) c, (const U8*) e)) 4311 c += UTF8SKIP(c); 4312 } 4313 else if (isWORDCHAR_A(*c)) { 4314 while (c < e && isWORDCHAR_A(*c)) 4315 c++; 4316 } 4317 else if (*c == '/') 4318 c++; 4319 else 4320 break; 4321 } 4322 4323 if (c == e && isIDFIRST_lazy_if_safe(name, e, utf8)) { 4324 sv_catpvs(msg, " (you may need to install the "); 4325 for (c = name; c < e; c++) { 4326 if (*c == '/') { 4327 sv_catpvs(msg, "::"); 4328 } 4329 else { 4330 sv_catpvn(msg, c, 1); 4331 } 4332 } 4333 sv_catpvs(msg, " module)"); 4334 } 4335 } 4336 else if (memENDs(name, len, ".h")) { 4337 sv_catpvs(msg, " (change .h to .ph maybe?) (did you run h2ph?)"); 4338 } 4339 else if (memENDs(name, len, ".ph")) { 4340 sv_catpvs(msg, " (did you run h2ph?)"); 4341 } 4342 4343 /* diag_listed_as: Can't locate %s */ 4344 DIE(aTHX_ 4345 "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")", 4346 name, msg, inc); 4347 } 4348 } 4349 DIE(aTHX_ "Can't locate %s", name); 4350 } 4351 else { 4352 #ifdef DEFAULT_INC_EXCLUDES_DOT 4353 Stat_t st; 4354 PerlIO *io = NULL; 4355 dSAVE_ERRNO; 4356 /* the complication is to match the logic from doopen_pm() so 4357 * we don't treat do "sda1" as a previously successful "do". 4358 */ 4359 bool do_warn = namesv && ckWARN_d(WARN_DEPRECATED) 4360 && PerlLIO_stat(name, &st) == 0 && !S_ISDIR(st.st_mode) && !S_ISBLK(st.st_mode) 4361 && (io = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &sv)) != NULL; 4362 if (io) 4363 PerlIO_close(io); 4364 4365 RESTORE_ERRNO; 4366 if (do_warn) { 4367 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), 4368 "do \"%s\" failed, '.' is no longer in @INC; " 4369 "did you mean do \"./%s\"?", 4370 name, name); 4371 } 4372 #endif 4373 CLEAR_ERRSV(); 4374 RETPUSHUNDEF; 4375 } 4376 } 4377 else 4378 SETERRNO(0, SS_NORMAL); 4379 4380 /* Update %INC. Assume success here to prevent recursive requirement. */ 4381 /* name is never assigned to again, so len is still strlen(name) */ 4382 /* Check whether a hook in @INC has already filled %INC */ 4383 if (!hook_sv) { 4384 (void)hv_store(GvHVn(PL_incgv), 4385 unixname, unixlen, newSVpv(tryname,0),0); 4386 } else { 4387 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0); 4388 if (!svp) 4389 (void)hv_store(GvHVn(PL_incgv), 4390 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 ); 4391 } 4392 4393 /* Now parse the file */ 4394 4395 old_savestack_ix = PL_savestack_ix; 4396 SAVECOPFILE_FREE(&PL_compiling); 4397 CopFILE_set(&PL_compiling, tryname); 4398 lex_start(NULL, tryrsfp, 0); 4399 4400 if (filter_sub || filter_cache) { 4401 /* We can use the SvPV of the filter PVIO itself as our cache, rather 4402 than hanging another SV from it. In turn, filter_add() optionally 4403 takes the SV to use as the filter (or creates a new SV if passed 4404 NULL), so simply pass in whatever value filter_cache has. */ 4405 SV * const fc = filter_cache ? newSV_type(SVt_NULL) : NULL; 4406 SV *datasv; 4407 if (fc) sv_copypv(fc, filter_cache); 4408 datasv = filter_add(S_run_user_filter, fc); 4409 IoLINES(datasv) = filter_has_file; 4410 IoTOP_GV(datasv) = MUTABLE_GV(filter_state); 4411 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub); 4412 } 4413 4414 /* switch to eval mode */ 4415 assert(!CATCH_GET); 4416 cx = cx_pushblock(CXt_EVAL, gimme, SP, old_savestack_ix); 4417 cx_pusheval(cx, PL_op->op_next, newSVpv(name, 0)); 4418 4419 SAVECOPLINE(&PL_compiling); 4420 CopLINE_set(&PL_compiling, 0); 4421 4422 PUTBACK; 4423 4424 if (doeval_compile(gimme, NULL, PL_curcop->cop_seq, NULL)) 4425 op = PL_eval_start; 4426 else 4427 op = PL_op->op_next; 4428 4429 PERL_DTRACE_PROBE_FILE_LOADED(unixname); 4430 4431 return op; 4432 } 4433 4434 4435 /* also used for: pp_dofile() */ 4436 4437 PP(pp_require) 4438 { 4439 RUN_PP_CATCHABLY(Perl_pp_require); 4440 4441 { 4442 dSP; 4443 SV *sv = POPs; 4444 SvGETMAGIC(sv); 4445 PUTBACK; 4446 return ((SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) 4447 ? S_require_version(aTHX_ sv) 4448 : S_require_file(aTHX_ sv); 4449 } 4450 } 4451 4452 4453 /* This is a op added to hold the hints hash for 4454 pp_entereval. The hash can be modified by the code 4455 being eval'ed, so we return a copy instead. */ 4456 4457 PP(pp_hintseval) 4458 { 4459 dSP; 4460 mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv)))); 4461 RETURN; 4462 } 4463 4464 4465 PP(pp_entereval) 4466 { 4467 dSP; 4468 PERL_CONTEXT *cx; 4469 SV *sv; 4470 U8 gimme; 4471 U32 was; 4472 char tbuf[TYPE_DIGITS(long) + 12]; 4473 bool saved_delete; 4474 char *tmpbuf; 4475 STRLEN len; 4476 CV* runcv; 4477 U32 seq, lex_flags; 4478 HV *saved_hh; 4479 bool bytes; 4480 I32 old_savestack_ix; 4481 4482 RUN_PP_CATCHABLY(Perl_pp_entereval); 4483 4484 gimme = GIMME_V; 4485 was = PL_breakable_sub_gen; 4486 saved_delete = FALSE; 4487 tmpbuf = tbuf; 4488 lex_flags = 0; 4489 saved_hh = NULL; 4490 bytes = PL_op->op_private & OPpEVAL_BYTES; 4491 4492 if (PL_op->op_private & OPpEVAL_HAS_HH) { 4493 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs)); 4494 } 4495 else if (PL_hints & HINT_LOCALIZE_HH || ( 4496 PL_op->op_private & OPpEVAL_COPHH 4497 && PL_curcop->cop_hints & HINT_LOCALIZE_HH 4498 )) { 4499 saved_hh = cop_hints_2hv(PL_curcop, 0); 4500 hv_magic(saved_hh, NULL, PERL_MAGIC_hints); 4501 } 4502 sv = POPs; 4503 if (!SvPOK(sv)) { 4504 /* make sure we've got a plain PV (no overload etc) before testing 4505 * for taint. Making a copy here is probably overkill, but better 4506 * safe than sorry */ 4507 STRLEN len; 4508 const char * const p = SvPV_const(sv, len); 4509 4510 sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv)); 4511 lex_flags |= LEX_START_COPIED; 4512 4513 if (bytes && SvUTF8(sv)) 4514 SvPVbyte_force(sv, len); 4515 } 4516 else if (bytes && SvUTF8(sv)) { 4517 /* Don't modify someone else's scalar */ 4518 STRLEN len; 4519 sv = newSVsv(sv); 4520 (void)sv_2mortal(sv); 4521 SvPVbyte_force(sv,len); 4522 lex_flags |= LEX_START_COPIED; 4523 } 4524 4525 TAINT_IF(SvTAINTED(sv)); 4526 TAINT_PROPER("eval"); 4527 4528 old_savestack_ix = PL_savestack_ix; 4529 4530 lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE 4531 ? LEX_IGNORE_UTF8_HINTS 4532 : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER 4533 ) 4534 ); 4535 4536 /* switch to eval mode */ 4537 4538 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) { 4539 SV * const temp_sv = sv_newmortal(); 4540 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%" IVdf "]", 4541 (unsigned long)++PL_evalseq, 4542 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); 4543 tmpbuf = SvPVX(temp_sv); 4544 len = SvCUR(temp_sv); 4545 } 4546 else 4547 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq); 4548 SAVECOPFILE_FREE(&PL_compiling); 4549 CopFILE_set(&PL_compiling, tmpbuf+2); 4550 SAVECOPLINE(&PL_compiling); 4551 CopLINE_set(&PL_compiling, 1); 4552 /* special case: an eval '' executed within the DB package gets lexically 4553 * placed in the first non-DB CV rather than the current CV - this 4554 * allows the debugger to execute code, find lexicals etc, in the 4555 * scope of the code being debugged. Passing &seq gets find_runcv 4556 * to do the dirty work for us */ 4557 runcv = find_runcv(&seq); 4558 4559 assert(!CATCH_GET); 4560 cx = cx_pushblock((CXt_EVAL|CXp_REAL), gimme, SP, old_savestack_ix); 4561 cx_pusheval(cx, PL_op->op_next, NULL); 4562 4563 /* prepare to compile string */ 4564 4565 if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash) 4566 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr); 4567 else { 4568 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up 4569 deleting the eval's FILEGV from the stash before gv_check() runs 4570 (i.e. before run-time proper). To work around the coredump that 4571 ensues, we always turn GvMULTI_on for any globals that were 4572 introduced within evals. See force_ident(). GSAR 96-10-12 */ 4573 char *const safestr = savepvn(tmpbuf, len); 4574 SAVEDELETE(PL_defstash, safestr, len); 4575 saved_delete = TRUE; 4576 } 4577 4578 PUTBACK; 4579 4580 if (doeval_compile(gimme, runcv, seq, saved_hh)) { 4581 if (was != PL_breakable_sub_gen /* Some subs defined here. */ 4582 ? PERLDB_LINE_OR_SAVESRC 4583 : PERLDB_SAVESRC_NOSUBS) { 4584 /* Retain the filegv we created. */ 4585 } else if (!saved_delete) { 4586 char *const safestr = savepvn(tmpbuf, len); 4587 SAVEDELETE(PL_defstash, safestr, len); 4588 } 4589 return PL_eval_start; 4590 } else { 4591 /* We have already left the scope set up earlier thanks to the LEAVE 4592 in doeval_compile(). */ 4593 if (was != PL_breakable_sub_gen /* Some subs defined here. */ 4594 ? PERLDB_LINE_OR_SAVESRC 4595 : PERLDB_SAVESRC_INVALID) { 4596 /* Retain the filegv we created. */ 4597 } else if (!saved_delete) { 4598 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD); 4599 } 4600 return PL_op->op_next; 4601 } 4602 } 4603 4604 4605 /* also tail-called by pp_return */ 4606 4607 PP(pp_leaveeval) 4608 { 4609 SV **oldsp; 4610 U8 gimme; 4611 PERL_CONTEXT *cx; 4612 OP *retop; 4613 int failed; 4614 CV *evalcv; 4615 bool keep; 4616 4617 PERL_ASYNC_CHECK(); 4618 4619 cx = CX_CUR(); 4620 assert(CxTYPE(cx) == CXt_EVAL); 4621 4622 oldsp = PL_stack_base + cx->blk_oldsp; 4623 gimme = cx->blk_gimme; 4624 4625 /* did require return a false value? */ 4626 failed = CxOLD_OP_TYPE(cx) == OP_REQUIRE 4627 && !(gimme == G_SCALAR 4628 ? SvTRUE_NN(*PL_stack_sp) 4629 : PL_stack_sp > oldsp); 4630 4631 if (gimme == G_VOID) { 4632 PL_stack_sp = oldsp; 4633 /* free now to avoid late-called destructors clobbering $@ */ 4634 FREETMPS; 4635 } 4636 else 4637 leave_adjust_stacks(oldsp, oldsp, gimme, 0); 4638 4639 /* the cx_popeval does a leavescope, which frees the optree associated 4640 * with eval, which if it frees the nextstate associated with 4641 * PL_curcop, sets PL_curcop to NULL. Which can mess up freeing a 4642 * regex when running under 'use re Debug' because it needs PL_curcop 4643 * to get the current hints. So restore it early. 4644 */ 4645 PL_curcop = cx->blk_oldcop; 4646 4647 /* grab this value before cx_popeval restores the old PL_in_eval */ 4648 keep = cBOOL(PL_in_eval & EVAL_KEEPERR); 4649 retop = cx->blk_eval.retop; 4650 evalcv = cx->blk_eval.cv; 4651 #ifdef DEBUGGING 4652 assert(CvDEPTH(evalcv) == 1); 4653 #endif 4654 CvDEPTH(evalcv) = 0; 4655 4656 /* pop the CXt_EVAL, and if a require failed, croak */ 4657 S_pop_eval_context_maybe_croak(aTHX_ cx, NULL, failed); 4658 4659 if (!keep) 4660 CLEAR_ERRSV(); 4661 4662 return retop; 4663 } 4664 4665 /* Ops that implement try/catch syntax 4666 * Note the asymmetry here: 4667 * pp_entertrycatch does two pushblocks 4668 * pp_leavetrycatch pops only the outer one; the inner one is popped by 4669 * pp_poptry or by stack-unwind of die within the try block 4670 */ 4671 4672 PP(pp_entertrycatch) 4673 { 4674 PERL_CONTEXT *cx; 4675 const U8 gimme = GIMME_V; 4676 4677 RUN_PP_CATCHABLY(Perl_pp_entertrycatch); 4678 4679 assert(!CATCH_GET); 4680 4681 Perl_pp_enter(aTHX); /* performs cx_pushblock(CXt_BLOCK, ...) */ 4682 4683 save_scalar(PL_errgv); 4684 CLEAR_ERRSV(); 4685 4686 cx = cx_pushblock((CXt_EVAL|CXp_EVALBLOCK|CXp_TRY), gimme, 4687 PL_stack_sp, PL_savestack_ix); 4688 cx_pushtry(cx, cLOGOP->op_other); 4689 4690 PL_in_eval = EVAL_INEVAL; 4691 4692 return NORMAL; 4693 } 4694 4695 PP(pp_leavetrycatch) 4696 { 4697 /* leavetrycatch is leave */ 4698 return Perl_pp_leave(aTHX); 4699 } 4700 4701 PP(pp_poptry) 4702 { 4703 /* poptry is leavetry */ 4704 return Perl_pp_leavetry(aTHX); 4705 } 4706 4707 PP(pp_catch) 4708 { 4709 dTARGET; 4710 4711 save_clearsv(&(PAD_SVl(PL_op->op_targ))); 4712 sv_setsv(TARG, ERRSV); 4713 CLEAR_ERRSV(); 4714 4715 return cLOGOP->op_other; 4716 } 4717 4718 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it 4719 close to the related Perl_create_eval_scope. */ 4720 void 4721 Perl_delete_eval_scope(pTHX) 4722 { 4723 PERL_CONTEXT *cx; 4724 4725 cx = CX_CUR(); 4726 CX_LEAVE_SCOPE(cx); 4727 cx_popeval(cx); 4728 cx_popblock(cx); 4729 CX_POP(cx); 4730 } 4731 4732 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was 4733 also needed by Perl_fold_constants. */ 4734 void 4735 Perl_create_eval_scope(pTHX_ OP *retop, U32 flags) 4736 { 4737 PERL_CONTEXT *cx; 4738 const U8 gimme = GIMME_V; 4739 4740 cx = cx_pushblock((CXt_EVAL|CXp_EVALBLOCK), gimme, 4741 PL_stack_sp, PL_savestack_ix); 4742 cx_pusheval(cx, retop, NULL); 4743 4744 PL_in_eval = EVAL_INEVAL; 4745 if (flags & G_KEEPERR) 4746 PL_in_eval |= EVAL_KEEPERR; 4747 else 4748 CLEAR_ERRSV(); 4749 if (flags & G_FAKINGEVAL) { 4750 PL_eval_root = PL_op; /* Only needed so that goto works right. */ 4751 } 4752 } 4753 4754 PP(pp_entertry) 4755 { 4756 OP *retop = cLOGOP->op_other->op_next; 4757 4758 RUN_PP_CATCHABLY(Perl_pp_entertry); 4759 4760 assert(!CATCH_GET); 4761 4762 create_eval_scope(retop, 0); 4763 4764 return PL_op->op_next; 4765 } 4766 4767 4768 /* also tail-called by pp_return */ 4769 4770 PP(pp_leavetry) 4771 { 4772 SV **oldsp; 4773 U8 gimme; 4774 PERL_CONTEXT *cx; 4775 OP *retop; 4776 4777 PERL_ASYNC_CHECK(); 4778 4779 cx = CX_CUR(); 4780 assert(CxTYPE(cx) == CXt_EVAL); 4781 oldsp = PL_stack_base + cx->blk_oldsp; 4782 gimme = cx->blk_gimme; 4783 4784 if (gimme == G_VOID) { 4785 PL_stack_sp = oldsp; 4786 /* free now to avoid late-called destructors clobbering $@ */ 4787 FREETMPS; 4788 } 4789 else 4790 leave_adjust_stacks(oldsp, oldsp, gimme, 1); 4791 CX_LEAVE_SCOPE(cx); 4792 cx_popeval(cx); 4793 cx_popblock(cx); 4794 retop = CxTRY(cx) ? PL_op->op_next : cx->blk_eval.retop; 4795 CX_POP(cx); 4796 4797 CLEAR_ERRSV(); 4798 return retop; 4799 } 4800 4801 PP(pp_entergiven) 4802 { 4803 dSP; 4804 PERL_CONTEXT *cx; 4805 const U8 gimme = GIMME_V; 4806 SV *origsv = DEFSV; 4807 SV *newsv = POPs; 4808 4809 assert(!PL_op->op_targ); /* used to be set for lexical $_ */ 4810 GvSV(PL_defgv) = SvREFCNT_inc(newsv); 4811 4812 cx = cx_pushblock(CXt_GIVEN, gimme, SP, PL_savestack_ix); 4813 cx_pushgiven(cx, origsv); 4814 4815 RETURN; 4816 } 4817 4818 PP(pp_leavegiven) 4819 { 4820 PERL_CONTEXT *cx; 4821 U8 gimme; 4822 SV **oldsp; 4823 PERL_UNUSED_CONTEXT; 4824 4825 cx = CX_CUR(); 4826 assert(CxTYPE(cx) == CXt_GIVEN); 4827 oldsp = PL_stack_base + cx->blk_oldsp; 4828 gimme = cx->blk_gimme; 4829 4830 if (gimme == G_VOID) 4831 PL_stack_sp = oldsp; 4832 else 4833 leave_adjust_stacks(oldsp, oldsp, gimme, 1); 4834 4835 CX_LEAVE_SCOPE(cx); 4836 cx_popgiven(cx); 4837 cx_popblock(cx); 4838 CX_POP(cx); 4839 4840 return NORMAL; 4841 } 4842 4843 /* Helper routines used by pp_smartmatch */ 4844 STATIC PMOP * 4845 S_make_matcher(pTHX_ REGEXP *re) 4846 { 4847 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED); 4848 4849 PERL_ARGS_ASSERT_MAKE_MATCHER; 4850 4851 PM_SETRE(matcher, ReREFCNT_inc(re)); 4852 4853 SAVEFREEOP((OP *) matcher); 4854 ENTER_with_name("matcher"); SAVETMPS; 4855 SAVEOP(); 4856 return matcher; 4857 } 4858 4859 STATIC bool 4860 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv) 4861 { 4862 dSP; 4863 bool result; 4864 4865 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV; 4866 4867 PL_op = (OP *) matcher; 4868 XPUSHs(sv); 4869 PUTBACK; 4870 (void) Perl_pp_match(aTHX); 4871 SPAGAIN; 4872 result = SvTRUEx(POPs); 4873 PUTBACK; 4874 4875 return result; 4876 } 4877 4878 STATIC void 4879 S_destroy_matcher(pTHX_ PMOP *matcher) 4880 { 4881 PERL_ARGS_ASSERT_DESTROY_MATCHER; 4882 PERL_UNUSED_ARG(matcher); 4883 4884 FREETMPS; 4885 LEAVE_with_name("matcher"); 4886 } 4887 4888 /* Do a smart match */ 4889 PP(pp_smartmatch) 4890 { 4891 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n")); 4892 return do_smartmatch(NULL, NULL, 0); 4893 } 4894 4895 /* This version of do_smartmatch() implements the 4896 * table of smart matches that is found in perlsyn. 4897 */ 4898 STATIC OP * 4899 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied) 4900 { 4901 dSP; 4902 4903 bool object_on_left = FALSE; 4904 SV *e = TOPs; /* e is for 'expression' */ 4905 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */ 4906 4907 /* Take care only to invoke mg_get() once for each argument. 4908 * Currently we do this by copying the SV if it's magical. */ 4909 if (d) { 4910 if (!copied && SvGMAGICAL(d)) 4911 d = sv_mortalcopy(d); 4912 } 4913 else 4914 d = &PL_sv_undef; 4915 4916 assert(e); 4917 if (SvGMAGICAL(e)) 4918 e = sv_mortalcopy(e); 4919 4920 /* First of all, handle overload magic of the rightmost argument */ 4921 if (SvAMAGIC(e)) { 4922 SV * tmpsv; 4923 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n")); 4924 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n")); 4925 4926 tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft); 4927 if (tmpsv) { 4928 SPAGAIN; 4929 (void)POPs; 4930 SETs(tmpsv); 4931 RETURN; 4932 } 4933 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n")); 4934 } 4935 4936 SP -= 2; /* Pop the values */ 4937 PUTBACK; 4938 4939 /* ~~ undef */ 4940 if (!SvOK(e)) { 4941 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n")); 4942 if (SvOK(d)) 4943 RETPUSHNO; 4944 else 4945 RETPUSHYES; 4946 } 4947 4948 if (SvROK(e) && SvOBJECT(SvRV(e)) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) { 4949 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n")); 4950 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation"); 4951 } 4952 if (SvROK(d) && SvOBJECT(SvRV(d)) && (SvTYPE(SvRV(d)) != SVt_REGEXP)) 4953 object_on_left = TRUE; 4954 4955 /* ~~ sub */ 4956 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) { 4957 I32 c; 4958 if (object_on_left) { 4959 goto sm_any_sub; /* Treat objects like scalars */ 4960 } 4961 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) { 4962 /* Test sub truth for each key */ 4963 HE *he; 4964 bool andedresults = TRUE; 4965 HV *hv = (HV*) SvRV(d); 4966 I32 numkeys = hv_iterinit(hv); 4967 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n")); 4968 if (numkeys == 0) 4969 RETPUSHYES; 4970 while ( (he = hv_iternext(hv)) ) { 4971 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n")); 4972 ENTER_with_name("smartmatch_hash_key_test"); 4973 SAVETMPS; 4974 PUSHMARK(SP); 4975 PUSHs(hv_iterkeysv(he)); 4976 PUTBACK; 4977 c = call_sv(e, G_SCALAR); 4978 SPAGAIN; 4979 if (c == 0) 4980 andedresults = FALSE; 4981 else 4982 andedresults = SvTRUEx(POPs) && andedresults; 4983 FREETMPS; 4984 LEAVE_with_name("smartmatch_hash_key_test"); 4985 } 4986 if (andedresults) 4987 RETPUSHYES; 4988 else 4989 RETPUSHNO; 4990 } 4991 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { 4992 /* Test sub truth for each element */ 4993 Size_t i; 4994 bool andedresults = TRUE; 4995 AV *av = (AV*) SvRV(d); 4996 const Size_t len = av_count(av); 4997 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n")); 4998 if (len == 0) 4999 RETPUSHYES; 5000 for (i = 0; i < len; ++i) { 5001 SV * const * const svp = av_fetch(av, i, FALSE); 5002 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n")); 5003 ENTER_with_name("smartmatch_array_elem_test"); 5004 SAVETMPS; 5005 PUSHMARK(SP); 5006 if (svp) 5007 PUSHs(*svp); 5008 PUTBACK; 5009 c = call_sv(e, G_SCALAR); 5010 SPAGAIN; 5011 if (c == 0) 5012 andedresults = FALSE; 5013 else 5014 andedresults = SvTRUEx(POPs) && andedresults; 5015 FREETMPS; 5016 LEAVE_with_name("smartmatch_array_elem_test"); 5017 } 5018 if (andedresults) 5019 RETPUSHYES; 5020 else 5021 RETPUSHNO; 5022 } 5023 else { 5024 sm_any_sub: 5025 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n")); 5026 ENTER_with_name("smartmatch_coderef"); 5027 SAVETMPS; 5028 PUSHMARK(SP); 5029 PUSHs(d); 5030 PUTBACK; 5031 c = call_sv(e, G_SCALAR); 5032 SPAGAIN; 5033 if (c == 0) 5034 PUSHs(&PL_sv_no); 5035 else if (SvTEMP(TOPs)) 5036 SvREFCNT_inc_void(TOPs); 5037 FREETMPS; 5038 LEAVE_with_name("smartmatch_coderef"); 5039 RETURN; 5040 } 5041 } 5042 /* ~~ %hash */ 5043 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) { 5044 if (object_on_left) { 5045 goto sm_any_hash; /* Treat objects like scalars */ 5046 } 5047 else if (!SvOK(d)) { 5048 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n")); 5049 RETPUSHNO; 5050 } 5051 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) { 5052 /* Check that the key-sets are identical */ 5053 HE *he; 5054 HV *other_hv = MUTABLE_HV(SvRV(d)); 5055 bool tied; 5056 bool other_tied; 5057 U32 this_key_count = 0, 5058 other_key_count = 0; 5059 HV *hv = MUTABLE_HV(SvRV(e)); 5060 5061 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n")); 5062 /* Tied hashes don't know how many keys they have. */ 5063 tied = cBOOL(SvTIED_mg((SV*)hv, PERL_MAGIC_tied)); 5064 other_tied = cBOOL(SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)); 5065 if (!tied ) { 5066 if(other_tied) { 5067 /* swap HV sides */ 5068 HV * const temp = other_hv; 5069 other_hv = hv; 5070 hv = temp; 5071 tied = TRUE; 5072 other_tied = FALSE; 5073 } 5074 else if(HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv)) 5075 RETPUSHNO; 5076 } 5077 5078 /* The hashes have the same number of keys, so it suffices 5079 to check that one is a subset of the other. */ 5080 (void) hv_iterinit(hv); 5081 while ( (he = hv_iternext(hv)) ) { 5082 SV *key = hv_iterkeysv(he); 5083 5084 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n")); 5085 ++ this_key_count; 5086 5087 if(!hv_exists_ent(other_hv, key, 0)) { 5088 (void) hv_iterinit(hv); /* reset iterator */ 5089 RETPUSHNO; 5090 } 5091 } 5092 5093 if (other_tied) { 5094 (void) hv_iterinit(other_hv); 5095 while ( hv_iternext(other_hv) ) 5096 ++other_key_count; 5097 } 5098 else 5099 other_key_count = HvUSEDKEYS(other_hv); 5100 5101 if (this_key_count != other_key_count) 5102 RETPUSHNO; 5103 else 5104 RETPUSHYES; 5105 } 5106 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { 5107 AV * const other_av = MUTABLE_AV(SvRV(d)); 5108 const Size_t other_len = av_count(other_av); 5109 Size_t i; 5110 HV *hv = MUTABLE_HV(SvRV(e)); 5111 5112 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n")); 5113 for (i = 0; i < other_len; ++i) { 5114 SV ** const svp = av_fetch(other_av, i, FALSE); 5115 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n")); 5116 if (svp) { /* ??? When can this not happen? */ 5117 if (hv_exists_ent(hv, *svp, 0)) 5118 RETPUSHYES; 5119 } 5120 } 5121 RETPUSHNO; 5122 } 5123 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) { 5124 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n")); 5125 sm_regex_hash: 5126 { 5127 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d)); 5128 HE *he; 5129 HV *hv = MUTABLE_HV(SvRV(e)); 5130 5131 (void) hv_iterinit(hv); 5132 while ( (he = hv_iternext(hv)) ) { 5133 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n")); 5134 PUTBACK; 5135 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) { 5136 SPAGAIN; 5137 (void) hv_iterinit(hv); 5138 destroy_matcher(matcher); 5139 RETPUSHYES; 5140 } 5141 SPAGAIN; 5142 } 5143 destroy_matcher(matcher); 5144 RETPUSHNO; 5145 } 5146 } 5147 else { 5148 sm_any_hash: 5149 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n")); 5150 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0)) 5151 RETPUSHYES; 5152 else 5153 RETPUSHNO; 5154 } 5155 } 5156 /* ~~ @array */ 5157 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) { 5158 if (object_on_left) { 5159 goto sm_any_array; /* Treat objects like scalars */ 5160 } 5161 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) { 5162 AV * const other_av = MUTABLE_AV(SvRV(e)); 5163 const Size_t other_len = av_count(other_av); 5164 Size_t i; 5165 5166 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n")); 5167 for (i = 0; i < other_len; ++i) { 5168 SV ** const svp = av_fetch(other_av, i, FALSE); 5169 5170 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n")); 5171 if (svp) { /* ??? When can this not happen? */ 5172 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0)) 5173 RETPUSHYES; 5174 } 5175 } 5176 RETPUSHNO; 5177 } 5178 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { 5179 AV *other_av = MUTABLE_AV(SvRV(d)); 5180 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n")); 5181 if (av_count(MUTABLE_AV(SvRV(e))) != av_count(other_av)) 5182 RETPUSHNO; 5183 else { 5184 Size_t i; 5185 const Size_t other_len = av_count(other_av); 5186 5187 if (NULL == seen_this) { 5188 seen_this = (HV*)newSV_type_mortal(SVt_PVHV); 5189 } 5190 if (NULL == seen_other) { 5191 seen_other = (HV*)newSV_type_mortal(SVt_PVHV); 5192 } 5193 for(i = 0; i < other_len; ++i) { 5194 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE); 5195 SV * const * const other_elem = av_fetch(other_av, i, FALSE); 5196 5197 if (!this_elem || !other_elem) { 5198 if ((this_elem && SvOK(*this_elem)) 5199 || (other_elem && SvOK(*other_elem))) 5200 RETPUSHNO; 5201 } 5202 else if (hv_exists_ent(seen_this, 5203 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) || 5204 hv_exists_ent(seen_other, 5205 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0)) 5206 { 5207 if (*this_elem != *other_elem) 5208 RETPUSHNO; 5209 } 5210 else { 5211 (void)hv_store_ent(seen_this, 5212 sv_2mortal(newSViv(PTR2IV(*this_elem))), 5213 &PL_sv_undef, 0); 5214 (void)hv_store_ent(seen_other, 5215 sv_2mortal(newSViv(PTR2IV(*other_elem))), 5216 &PL_sv_undef, 0); 5217 PUSHs(*other_elem); 5218 PUSHs(*this_elem); 5219 5220 PUTBACK; 5221 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n")); 5222 (void) do_smartmatch(seen_this, seen_other, 0); 5223 SPAGAIN; 5224 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n")); 5225 5226 if (!SvTRUEx(POPs)) 5227 RETPUSHNO; 5228 } 5229 } 5230 RETPUSHYES; 5231 } 5232 } 5233 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) { 5234 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n")); 5235 sm_regex_array: 5236 { 5237 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d)); 5238 const Size_t this_len = av_count(MUTABLE_AV(SvRV(e))); 5239 Size_t i; 5240 5241 for(i = 0; i < this_len; ++i) { 5242 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE); 5243 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n")); 5244 PUTBACK; 5245 if (svp && matcher_matches_sv(matcher, *svp)) { 5246 SPAGAIN; 5247 destroy_matcher(matcher); 5248 RETPUSHYES; 5249 } 5250 SPAGAIN; 5251 } 5252 destroy_matcher(matcher); 5253 RETPUSHNO; 5254 } 5255 } 5256 else if (!SvOK(d)) { 5257 /* undef ~~ array */ 5258 const Size_t this_len = av_count(MUTABLE_AV(SvRV(e))); 5259 Size_t i; 5260 5261 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n")); 5262 for (i = 0; i < this_len; ++i) { 5263 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE); 5264 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n")); 5265 if (!svp || !SvOK(*svp)) 5266 RETPUSHYES; 5267 } 5268 RETPUSHNO; 5269 } 5270 else { 5271 sm_any_array: 5272 { 5273 Size_t i; 5274 const Size_t this_len = av_count(MUTABLE_AV(SvRV(e))); 5275 5276 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n")); 5277 for (i = 0; i < this_len; ++i) { 5278 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE); 5279 if (!svp) 5280 continue; 5281 5282 PUSHs(d); 5283 PUSHs(*svp); 5284 PUTBACK; 5285 /* infinite recursion isn't supposed to happen here */ 5286 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n")); 5287 (void) do_smartmatch(NULL, NULL, 1); 5288 SPAGAIN; 5289 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n")); 5290 if (SvTRUEx(POPs)) 5291 RETPUSHYES; 5292 } 5293 RETPUSHNO; 5294 } 5295 } 5296 } 5297 /* ~~ qr// */ 5298 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) { 5299 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) { 5300 SV *t = d; d = e; e = t; 5301 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n")); 5302 goto sm_regex_hash; 5303 } 5304 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { 5305 SV *t = d; d = e; e = t; 5306 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n")); 5307 goto sm_regex_array; 5308 } 5309 else { 5310 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e)); 5311 bool result; 5312 5313 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n")); 5314 PUTBACK; 5315 result = matcher_matches_sv(matcher, d); 5316 SPAGAIN; 5317 PUSHs(result ? &PL_sv_yes : &PL_sv_no); 5318 destroy_matcher(matcher); 5319 RETURN; 5320 } 5321 } 5322 /* ~~ scalar */ 5323 /* See if there is overload magic on left */ 5324 else if (object_on_left && SvAMAGIC(d)) { 5325 SV *tmpsv; 5326 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n")); 5327 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n")); 5328 PUSHs(d); PUSHs(e); 5329 PUTBACK; 5330 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright); 5331 if (tmpsv) { 5332 SPAGAIN; 5333 (void)POPs; 5334 SETs(tmpsv); 5335 RETURN; 5336 } 5337 SP -= 2; 5338 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n")); 5339 goto sm_any_scalar; 5340 } 5341 else if (!SvOK(d)) { 5342 /* undef ~~ scalar ; we already know that the scalar is SvOK */ 5343 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n")); 5344 RETPUSHNO; 5345 } 5346 else 5347 sm_any_scalar: 5348 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) { 5349 DEBUG_M(if (SvNIOK(e)) 5350 Perl_deb(aTHX_ " applying rule Any-Num\n"); 5351 else 5352 Perl_deb(aTHX_ " applying rule Num-numish\n"); 5353 ); 5354 /* numeric comparison */ 5355 PUSHs(d); PUSHs(e); 5356 PUTBACK; 5357 if (CopHINTS_get(PL_curcop) & HINT_INTEGER) 5358 (void) Perl_pp_i_eq(aTHX); 5359 else 5360 (void) Perl_pp_eq(aTHX); 5361 SPAGAIN; 5362 if (SvTRUEx(POPs)) 5363 RETPUSHYES; 5364 else 5365 RETPUSHNO; 5366 } 5367 5368 /* As a last resort, use string comparison */ 5369 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n")); 5370 PUSHs(d); PUSHs(e); 5371 PUTBACK; 5372 return Perl_pp_seq(aTHX); 5373 } 5374 5375 PP(pp_enterwhen) 5376 { 5377 dSP; 5378 PERL_CONTEXT *cx; 5379 const U8 gimme = GIMME_V; 5380 5381 /* This is essentially an optimization: if the match 5382 fails, we don't want to push a context and then 5383 pop it again right away, so we skip straight 5384 to the op that follows the leavewhen. 5385 RETURNOP calls PUTBACK which restores the stack pointer after the POPs. 5386 */ 5387 if (!(PL_op->op_flags & OPf_SPECIAL) && !SvTRUEx(POPs)) { 5388 if (gimme == G_SCALAR) 5389 PUSHs(&PL_sv_undef); 5390 RETURNOP(cLOGOP->op_other->op_next); 5391 } 5392 5393 cx = cx_pushblock(CXt_WHEN, gimme, SP, PL_savestack_ix); 5394 cx_pushwhen(cx); 5395 5396 RETURN; 5397 } 5398 5399 PP(pp_leavewhen) 5400 { 5401 I32 cxix; 5402 PERL_CONTEXT *cx; 5403 U8 gimme; 5404 SV **oldsp; 5405 5406 cx = CX_CUR(); 5407 assert(CxTYPE(cx) == CXt_WHEN); 5408 gimme = cx->blk_gimme; 5409 5410 cxix = dopoptogivenfor(cxstack_ix); 5411 if (cxix < 0) 5412 /* diag_listed_as: Can't "when" outside a topicalizer */ 5413 DIE(aTHX_ "Can't \"%s\" outside a topicalizer", 5414 PL_op->op_flags & OPf_SPECIAL ? "default" : "when"); 5415 5416 oldsp = PL_stack_base + cx->blk_oldsp; 5417 if (gimme == G_VOID) 5418 PL_stack_sp = oldsp; 5419 else 5420 leave_adjust_stacks(oldsp, oldsp, gimme, 1); 5421 5422 /* pop the WHEN, BLOCK and anything else before the GIVEN/FOR */ 5423 assert(cxix < cxstack_ix); 5424 dounwind(cxix); 5425 5426 cx = &cxstack[cxix]; 5427 5428 if (CxFOREACH(cx)) { 5429 /* emulate pp_next. Note that any stack(s) cleanup will be 5430 * done by the pp_unstack which op_nextop should point to */ 5431 cx = CX_CUR(); 5432 cx_topblock(cx); 5433 PL_curcop = cx->blk_oldcop; 5434 return cx->blk_loop.my_op->op_nextop; 5435 } 5436 else { 5437 PERL_ASYNC_CHECK(); 5438 assert(cx->blk_givwhen.leave_op->op_type == OP_LEAVEGIVEN); 5439 return cx->blk_givwhen.leave_op; 5440 } 5441 } 5442 5443 PP(pp_continue) 5444 { 5445 I32 cxix; 5446 PERL_CONTEXT *cx; 5447 OP *nextop; 5448 5449 cxix = dopoptowhen(cxstack_ix); 5450 if (cxix < 0) 5451 DIE(aTHX_ "Can't \"continue\" outside a when block"); 5452 5453 if (cxix < cxstack_ix) 5454 dounwind(cxix); 5455 5456 cx = CX_CUR(); 5457 assert(CxTYPE(cx) == CXt_WHEN); 5458 PL_stack_sp = PL_stack_base + cx->blk_oldsp; 5459 CX_LEAVE_SCOPE(cx); 5460 cx_popwhen(cx); 5461 cx_popblock(cx); 5462 nextop = cx->blk_givwhen.leave_op->op_next; 5463 CX_POP(cx); 5464 5465 return nextop; 5466 } 5467 5468 PP(pp_break) 5469 { 5470 I32 cxix; 5471 PERL_CONTEXT *cx; 5472 5473 cxix = dopoptogivenfor(cxstack_ix); 5474 if (cxix < 0) 5475 DIE(aTHX_ "Can't \"break\" outside a given block"); 5476 5477 cx = &cxstack[cxix]; 5478 if (CxFOREACH(cx)) 5479 DIE(aTHX_ "Can't \"break\" in a loop topicalizer"); 5480 5481 if (cxix < cxstack_ix) 5482 dounwind(cxix); 5483 5484 /* Restore the sp at the time we entered the given block */ 5485 cx = CX_CUR(); 5486 PL_stack_sp = PL_stack_base + cx->blk_oldsp; 5487 5488 return cx->blk_givwhen.leave_op; 5489 } 5490 5491 static void 5492 _invoke_defer_block(pTHX_ U8 type, void *_arg) 5493 { 5494 OP *start = (OP *)_arg; 5495 #ifdef DEBUGGING 5496 I32 was_cxstack_ix = cxstack_ix; 5497 #endif 5498 5499 cx_pushblock(type, G_VOID, PL_stack_sp, PL_savestack_ix); 5500 ENTER; 5501 SAVETMPS; 5502 5503 SAVEOP(); 5504 PL_op = start; 5505 5506 CALLRUNOPS(aTHX); 5507 5508 FREETMPS; 5509 LEAVE; 5510 5511 { 5512 PERL_CONTEXT *cx; 5513 5514 cx = CX_CUR(); 5515 assert(CxTYPE(cx) == CXt_DEFER); 5516 5517 PL_stack_sp = PL_stack_base + cx->blk_oldsp; 5518 5519 CX_LEAVE_SCOPE(cx); 5520 cx_popblock(cx); 5521 CX_POP(cx); 5522 } 5523 5524 assert(cxstack_ix == was_cxstack_ix); 5525 } 5526 5527 static void 5528 invoke_defer_block(pTHX_ void *_arg) 5529 { 5530 _invoke_defer_block(aTHX_ CXt_DEFER, _arg); 5531 } 5532 5533 static void 5534 invoke_finally_block(pTHX_ void *_arg) 5535 { 5536 _invoke_defer_block(aTHX_ CXt_DEFER|CXp_FINALLY, _arg); 5537 } 5538 5539 PP(pp_pushdefer) 5540 { 5541 if(PL_op->op_private & OPpDEFER_FINALLY) 5542 SAVEDESTRUCTOR_X(invoke_finally_block, cLOGOP->op_other); 5543 else 5544 SAVEDESTRUCTOR_X(invoke_defer_block, cLOGOP->op_other); 5545 5546 return NORMAL; 5547 } 5548 5549 static MAGIC * 5550 S_doparseform(pTHX_ SV *sv) 5551 { 5552 STRLEN len; 5553 char *s = SvPV(sv, len); 5554 char *send; 5555 char *base = NULL; /* start of current field */ 5556 I32 skipspaces = 0; /* number of contiguous spaces seen */ 5557 bool noblank = FALSE; /* ~ or ~~ seen on this line */ 5558 bool repeat = FALSE; /* ~~ seen on this line */ 5559 bool postspace = FALSE; /* a text field may need right padding */ 5560 U32 *fops; 5561 U32 *fpc; 5562 U32 *linepc = NULL; /* position of last FF_LINEMARK */ 5563 I32 arg; 5564 bool ischop; /* it's a ^ rather than a @ */ 5565 bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */ 5566 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */ 5567 MAGIC *mg = NULL; 5568 SV *sv_copy; 5569 5570 PERL_ARGS_ASSERT_DOPARSEFORM; 5571 5572 if (len == 0) 5573 Perl_croak(aTHX_ "Null picture in formline"); 5574 5575 if (SvTYPE(sv) >= SVt_PVMG) { 5576 /* This might, of course, still return NULL. */ 5577 mg = mg_find(sv, PERL_MAGIC_fm); 5578 } else { 5579 sv_upgrade(sv, SVt_PVMG); 5580 } 5581 5582 if (mg) { 5583 /* still the same as previously-compiled string? */ 5584 SV *old = mg->mg_obj; 5585 if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv)) 5586 && len == SvCUR(old) 5587 && strnEQ(SvPVX(old), s, len) 5588 ) { 5589 DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n")); 5590 return mg; 5591 } 5592 5593 DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n")); 5594 Safefree(mg->mg_ptr); 5595 mg->mg_ptr = NULL; 5596 SvREFCNT_dec(old); 5597 mg->mg_obj = NULL; 5598 } 5599 else { 5600 DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n")); 5601 mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0); 5602 } 5603 5604 sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv)); 5605 s = SvPV(sv_copy, len); /* work on the copy, not the original */ 5606 send = s + len; 5607 5608 5609 /* estimate the buffer size needed */ 5610 for (base = s; s <= send; s++) { 5611 if (*s == '\n' || *s == '@' || *s == '^') 5612 maxops += 10; 5613 } 5614 s = base; 5615 base = NULL; 5616 5617 Newx(fops, maxops, U32); 5618 fpc = fops; 5619 5620 if (s < send) { 5621 linepc = fpc; 5622 *fpc++ = FF_LINEMARK; 5623 noblank = repeat = FALSE; 5624 base = s; 5625 } 5626 5627 while (s <= send) { 5628 switch (*s++) { 5629 default: 5630 skipspaces = 0; 5631 continue; 5632 5633 case '~': 5634 if (*s == '~') { 5635 repeat = TRUE; 5636 skipspaces++; 5637 s++; 5638 } 5639 noblank = TRUE; 5640 /* FALLTHROUGH */ 5641 case ' ': case '\t': 5642 skipspaces++; 5643 continue; 5644 case 0: 5645 if (s < send) { 5646 skipspaces = 0; 5647 continue; 5648 } 5649 /* FALLTHROUGH */ 5650 case '\n': 5651 arg = s - base; 5652 skipspaces++; 5653 arg -= skipspaces; 5654 if (arg) { 5655 if (postspace) 5656 *fpc++ = FF_SPACE; 5657 *fpc++ = FF_LITERAL; 5658 *fpc++ = (U32)arg; 5659 } 5660 postspace = FALSE; 5661 if (s <= send) 5662 skipspaces--; 5663 if (skipspaces) { 5664 *fpc++ = FF_SKIP; 5665 *fpc++ = (U32)skipspaces; 5666 } 5667 skipspaces = 0; 5668 if (s <= send) 5669 *fpc++ = FF_NEWLINE; 5670 if (noblank) { 5671 *fpc++ = FF_BLANK; 5672 if (repeat) 5673 arg = fpc - linepc + 1; 5674 else 5675 arg = 0; 5676 *fpc++ = (U32)arg; 5677 } 5678 if (s < send) { 5679 linepc = fpc; 5680 *fpc++ = FF_LINEMARK; 5681 noblank = repeat = FALSE; 5682 base = s; 5683 } 5684 else 5685 s++; 5686 continue; 5687 5688 case '@': 5689 case '^': 5690 ischop = s[-1] == '^'; 5691 5692 if (postspace) { 5693 *fpc++ = FF_SPACE; 5694 postspace = FALSE; 5695 } 5696 arg = (s - base) - 1; 5697 if (arg) { 5698 *fpc++ = FF_LITERAL; 5699 *fpc++ = (U32)arg; 5700 } 5701 5702 base = s - 1; 5703 *fpc++ = FF_FETCH; 5704 if (*s == '*') { /* @* or ^* */ 5705 s++; 5706 *fpc++ = 2; /* skip the @* or ^* */ 5707 if (ischop) { 5708 *fpc++ = FF_LINESNGL; 5709 *fpc++ = FF_CHOP; 5710 } else 5711 *fpc++ = FF_LINEGLOB; 5712 } 5713 else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */ 5714 arg = ischop ? FORM_NUM_BLANK : 0; 5715 base = s - 1; 5716 while (*s == '#') 5717 s++; 5718 if (*s == '.') { 5719 const char * const f = ++s; 5720 while (*s == '#') 5721 s++; 5722 arg |= FORM_NUM_POINT + (s - f); 5723 } 5724 *fpc++ = s - base; /* fieldsize for FETCH */ 5725 *fpc++ = FF_DECIMAL; 5726 *fpc++ = (U32)arg; 5727 unchopnum |= ! ischop; 5728 } 5729 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */ 5730 arg = ischop ? FORM_NUM_BLANK : 0; 5731 base = s - 1; 5732 s++; /* skip the '0' first */ 5733 while (*s == '#') 5734 s++; 5735 if (*s == '.') { 5736 const char * const f = ++s; 5737 while (*s == '#') 5738 s++; 5739 arg |= FORM_NUM_POINT + (s - f); 5740 } 5741 *fpc++ = s - base; /* fieldsize for FETCH */ 5742 *fpc++ = FF_0DECIMAL; 5743 *fpc++ = (U32)arg; 5744 unchopnum |= ! ischop; 5745 } 5746 else { /* text field */ 5747 I32 prespace = 0; 5748 bool ismore = FALSE; 5749 5750 if (*s == '>') { 5751 while (*++s == '>') ; 5752 prespace = FF_SPACE; 5753 } 5754 else if (*s == '|') { 5755 while (*++s == '|') ; 5756 prespace = FF_HALFSPACE; 5757 postspace = TRUE; 5758 } 5759 else { 5760 if (*s == '<') 5761 while (*++s == '<') ; 5762 postspace = TRUE; 5763 } 5764 if (*s == '.' && s[1] == '.' && s[2] == '.') { 5765 s += 3; 5766 ismore = TRUE; 5767 } 5768 *fpc++ = s - base; /* fieldsize for FETCH */ 5769 5770 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL; 5771 5772 if (prespace) 5773 *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */ 5774 *fpc++ = FF_ITEM; 5775 if (ismore) 5776 *fpc++ = FF_MORE; 5777 if (ischop) 5778 *fpc++ = FF_CHOP; 5779 } 5780 base = s; 5781 skipspaces = 0; 5782 continue; 5783 } 5784 } 5785 *fpc++ = FF_END; 5786 5787 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */ 5788 arg = fpc - fops; 5789 5790 mg->mg_ptr = (char *) fops; 5791 mg->mg_len = arg * sizeof(U32); 5792 mg->mg_obj = sv_copy; 5793 mg->mg_flags |= MGf_REFCOUNTED; 5794 5795 if (unchopnum && repeat) 5796 Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)"); 5797 5798 return mg; 5799 } 5800 5801 5802 STATIC bool 5803 S_num_overflow(NV value, I32 fldsize, I32 frcsize) 5804 { 5805 /* Can value be printed in fldsize chars, using %*.*f ? */ 5806 NV pwr = 1; 5807 NV eps = 0.5; 5808 bool res = FALSE; 5809 int intsize = fldsize - (value < 0 ? 1 : 0); 5810 5811 if (frcsize & FORM_NUM_POINT) 5812 intsize--; 5813 frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK); 5814 intsize -= frcsize; 5815 5816 while (intsize--) pwr *= 10.0; 5817 while (frcsize--) eps /= 10.0; 5818 5819 if( value >= 0 ){ 5820 if (value + eps >= pwr) 5821 res = TRUE; 5822 } else { 5823 if (value - eps <= -pwr) 5824 res = TRUE; 5825 } 5826 return res; 5827 } 5828 5829 static I32 5830 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) 5831 { 5832 SV * const datasv = FILTER_DATA(idx); 5833 const int filter_has_file = IoLINES(datasv); 5834 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv)); 5835 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv)); 5836 int status = 0; 5837 SV *upstream; 5838 STRLEN got_len; 5839 char *got_p = NULL; 5840 char *prune_from = NULL; 5841 bool read_from_cache = FALSE; 5842 STRLEN umaxlen; 5843 SV *err = NULL; 5844 5845 PERL_ARGS_ASSERT_RUN_USER_FILTER; 5846 5847 assert(maxlen >= 0); 5848 umaxlen = maxlen; 5849 5850 /* I was having segfault trouble under Linux 2.2.5 after a 5851 parse error occurred. (Had to hack around it with a test 5852 for PL_parser->error_count == 0.) Solaris doesn't segfault -- 5853 not sure where the trouble is yet. XXX */ 5854 5855 { 5856 SV *const cache = datasv; 5857 if (SvOK(cache)) { 5858 STRLEN cache_len; 5859 const char *cache_p = SvPV(cache, cache_len); 5860 STRLEN take = 0; 5861 5862 if (umaxlen) { 5863 /* Running in block mode and we have some cached data already. 5864 */ 5865 if (cache_len >= umaxlen) { 5866 /* In fact, so much data we don't even need to call 5867 filter_read. */ 5868 take = umaxlen; 5869 } 5870 } else { 5871 const char *const first_nl = 5872 (const char *)memchr(cache_p, '\n', cache_len); 5873 if (first_nl) { 5874 take = first_nl + 1 - cache_p; 5875 } 5876 } 5877 if (take) { 5878 sv_catpvn(buf_sv, cache_p, take); 5879 sv_chop(cache, cache_p + take); 5880 /* Definitely not EOF */ 5881 return 1; 5882 } 5883 5884 sv_catsv(buf_sv, cache); 5885 if (umaxlen) { 5886 umaxlen -= cache_len; 5887 } 5888 SvOK_off(cache); 5889 read_from_cache = TRUE; 5890 } 5891 } 5892 5893 /* Filter API says that the filter appends to the contents of the buffer. 5894 Usually the buffer is "", so the details don't matter. But if it's not, 5895 then clearly what it contains is already filtered by this filter, so we 5896 don't want to pass it in a second time. 5897 I'm going to use a mortal in case the upstream filter croaks. */ 5898 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv)) 5899 ? newSV_type_mortal(SVt_PV) : buf_sv; 5900 SvUPGRADE(upstream, SVt_PV); 5901 5902 if (filter_has_file) { 5903 status = FILTER_READ(idx+1, upstream, 0); 5904 } 5905 5906 if (filter_sub && status >= 0) { 5907 dSP; 5908 int count; 5909 5910 ENTER_with_name("call_filter_sub"); 5911 SAVE_DEFSV; 5912 SAVETMPS; 5913 EXTEND(SP, 2); 5914 5915 DEFSV_set(upstream); 5916 PUSHMARK(SP); 5917 PUSHs(&PL_sv_zero); 5918 if (filter_state) { 5919 PUSHs(filter_state); 5920 } 5921 PUTBACK; 5922 count = call_sv(filter_sub, G_SCALAR|G_EVAL); 5923 SPAGAIN; 5924 5925 if (count > 0) { 5926 SV *out = POPs; 5927 SvGETMAGIC(out); 5928 if (SvOK(out)) { 5929 status = SvIV(out); 5930 } 5931 else { 5932 SV * const errsv = ERRSV; 5933 if (SvTRUE_NN(errsv)) 5934 err = newSVsv(errsv); 5935 } 5936 } 5937 5938 PUTBACK; 5939 FREETMPS; 5940 LEAVE_with_name("call_filter_sub"); 5941 } 5942 5943 if (SvGMAGICAL(upstream)) { 5944 mg_get(upstream); 5945 if (upstream == buf_sv) mg_free(buf_sv); 5946 } 5947 if (SvIsCOW(upstream)) sv_force_normal(upstream); 5948 if(!err && SvOK(upstream)) { 5949 got_p = SvPV_nomg(upstream, got_len); 5950 if (umaxlen) { 5951 if (got_len > umaxlen) { 5952 prune_from = got_p + umaxlen; 5953 } 5954 } else { 5955 char *const first_nl = (char *)memchr(got_p, '\n', got_len); 5956 if (first_nl && first_nl + 1 < got_p + got_len) { 5957 /* There's a second line here... */ 5958 prune_from = first_nl + 1; 5959 } 5960 } 5961 } 5962 if (!err && prune_from) { 5963 /* Oh. Too long. Stuff some in our cache. */ 5964 STRLEN cached_len = got_p + got_len - prune_from; 5965 SV *const cache = datasv; 5966 5967 if (SvOK(cache)) { 5968 /* Cache should be empty. */ 5969 assert(!SvCUR(cache)); 5970 } 5971 5972 sv_setpvn(cache, prune_from, cached_len); 5973 /* If you ask for block mode, you may well split UTF-8 characters. 5974 "If it breaks, you get to keep both parts" 5975 (Your code is broken if you don't put them back together again 5976 before something notices.) */ 5977 if (SvUTF8(upstream)) { 5978 SvUTF8_on(cache); 5979 } 5980 if (SvPOK(upstream)) SvCUR_set(upstream, got_len - cached_len); 5981 else 5982 /* Cannot just use sv_setpvn, as that could free the buffer 5983 before we have a chance to assign it. */ 5984 sv_usepvn(upstream, savepvn(got_p, got_len - cached_len), 5985 got_len - cached_len); 5986 *prune_from = 0; 5987 /* Can't yet be EOF */ 5988 if (status == 0) 5989 status = 1; 5990 } 5991 5992 /* If they are at EOF but buf_sv has something in it, then they may never 5993 have touched the SV upstream, so it may be undefined. If we naively 5994 concatenate it then we get a warning about use of uninitialised value. 5995 */ 5996 if (!err && upstream != buf_sv && 5997 SvOK(upstream)) { 5998 sv_catsv_nomg(buf_sv, upstream); 5999 } 6000 else if (SvOK(upstream)) (void)SvPV_force_nolen(buf_sv); 6001 6002 if (status <= 0) { 6003 IoLINES(datasv) = 0; 6004 if (filter_state) { 6005 SvREFCNT_dec(filter_state); 6006 IoTOP_GV(datasv) = NULL; 6007 } 6008 if (filter_sub) { 6009 SvREFCNT_dec(filter_sub); 6010 IoBOTTOM_GV(datasv) = NULL; 6011 } 6012 filter_del(S_run_user_filter); 6013 } 6014 6015 if (err) 6016 croak_sv(err); 6017 6018 if (status == 0 && read_from_cache) { 6019 /* If we read some data from the cache (and by getting here it implies 6020 that we emptied the cache) then we aren't yet at EOF, and mustn't 6021 report that to our caller. */ 6022 return 1; 6023 } 6024 return status; 6025 } 6026 6027 /* 6028 * ex: set ts=8 sts=4 sw=4 et: 6029 */ 6030