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