1 /* pp_ctl.c 2 * 3 * Copyright (c) 1991-2001, Larry Wall 4 * 5 * You may distribute under the terms of either the GNU General Public 6 * License or the Artistic License, as specified in the README file. 7 * 8 */ 9 10 /* 11 * Now far ahead the Road has gone, 12 * And I must follow, if I can, 13 * Pursuing it with eager feet, 14 * Until it joins some larger way 15 * Where many paths and errands meet. 16 * And whither then? I cannot say. 17 */ 18 19 #include "EXTERN.h" 20 #define PERL_IN_PP_CTL_C 21 #include "perl.h" 22 23 #ifndef WORD_ALIGN 24 #define WORD_ALIGN sizeof(U16) 25 #endif 26 27 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o)) 28 29 static I32 sortcv(pTHXo_ SV *a, SV *b); 30 static I32 sortcv_stacked(pTHXo_ SV *a, SV *b); 31 static I32 sortcv_xsub(pTHXo_ SV *a, SV *b); 32 static I32 sv_ncmp(pTHXo_ SV *a, SV *b); 33 static I32 sv_i_ncmp(pTHXo_ SV *a, SV *b); 34 static I32 amagic_ncmp(pTHXo_ SV *a, SV *b); 35 static I32 amagic_i_ncmp(pTHXo_ SV *a, SV *b); 36 static I32 amagic_cmp(pTHXo_ SV *a, SV *b); 37 static I32 amagic_cmp_locale(pTHXo_ SV *a, SV *b); 38 static I32 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen); 39 40 #ifdef PERL_OBJECT 41 static I32 sv_cmp_static(pTHXo_ SV *a, SV *b); 42 static I32 sv_cmp_locale_static(pTHXo_ SV *a, SV *b); 43 #else 44 #define sv_cmp_static Perl_sv_cmp 45 #define sv_cmp_locale_static Perl_sv_cmp_locale 46 #endif 47 48 PP(pp_wantarray) 49 { 50 dSP; 51 I32 cxix; 52 EXTEND(SP, 1); 53 54 cxix = dopoptosub(cxstack_ix); 55 if (cxix < 0) 56 RETPUSHUNDEF; 57 58 switch (cxstack[cxix].blk_gimme) { 59 case G_ARRAY: 60 RETPUSHYES; 61 case G_SCALAR: 62 RETPUSHNO; 63 default: 64 RETPUSHUNDEF; 65 } 66 } 67 68 PP(pp_regcmaybe) 69 { 70 return NORMAL; 71 } 72 73 PP(pp_regcreset) 74 { 75 /* XXXX Should store the old value to allow for tie/overload - and 76 restore in regcomp, where marked with XXXX. */ 77 PL_reginterp_cnt = 0; 78 return NORMAL; 79 } 80 81 PP(pp_regcomp) 82 { 83 dSP; 84 register PMOP *pm = (PMOP*)cLOGOP->op_other; 85 register char *t; 86 SV *tmpstr; 87 STRLEN len; 88 MAGIC *mg = Null(MAGIC*); 89 90 tmpstr = POPs; 91 if (SvROK(tmpstr)) { 92 SV *sv = SvRV(tmpstr); 93 if(SvMAGICAL(sv)) 94 mg = mg_find(sv, 'r'); 95 } 96 if (mg) { 97 regexp *re = (regexp *)mg->mg_obj; 98 ReREFCNT_dec(pm->op_pmregexp); 99 pm->op_pmregexp = ReREFCNT_inc(re); 100 } 101 else { 102 t = SvPV(tmpstr, len); 103 104 /* Check against the last compiled regexp. */ 105 if (!pm->op_pmregexp || !pm->op_pmregexp->precomp || 106 pm->op_pmregexp->prelen != len || 107 memNE(pm->op_pmregexp->precomp, t, len)) 108 { 109 if (pm->op_pmregexp) { 110 ReREFCNT_dec(pm->op_pmregexp); 111 pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */ 112 } 113 if (PL_op->op_flags & OPf_SPECIAL) 114 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */ 115 116 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */ 117 if (DO_UTF8(tmpstr)) 118 pm->op_pmdynflags |= PMdf_UTF8; 119 pm->op_pmregexp = CALLREGCOMP(aTHX_ t, t + len, pm); 120 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed 121 inside tie/overload accessors. */ 122 } 123 } 124 125 #ifndef INCOMPLETE_TAINTS 126 if (PL_tainting) { 127 if (PL_tainted) 128 pm->op_pmdynflags |= PMdf_TAINTED; 129 else 130 pm->op_pmdynflags &= ~PMdf_TAINTED; 131 } 132 #endif 133 134 if (!pm->op_pmregexp->prelen && PL_curpm) 135 pm = PL_curpm; 136 else if (strEQ("\\s+", pm->op_pmregexp->precomp)) 137 pm->op_pmflags |= PMf_WHITE; 138 139 /* XXX runtime compiled output needs to move to the pad */ 140 if (pm->op_pmflags & PMf_KEEP) { 141 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */ 142 #if !defined(USE_ITHREADS) && !defined(USE_THREADS) 143 /* XXX can't change the optree at runtime either */ 144 cLOGOP->op_first->op_next = PL_op->op_next; 145 #endif 146 } 147 RETURN; 148 } 149 150 PP(pp_substcont) 151 { 152 dSP; 153 register PMOP *pm = (PMOP*) cLOGOP->op_other; 154 register PERL_CONTEXT *cx = &cxstack[cxstack_ix]; 155 register SV *dstr = cx->sb_dstr; 156 register char *s = cx->sb_s; 157 register char *m = cx->sb_m; 158 char *orig = cx->sb_orig; 159 register REGEXP *rx = cx->sb_rx; 160 161 rxres_restore(&cx->sb_rxres, rx); 162 163 if (cx->sb_iters++) { 164 if (cx->sb_iters > cx->sb_maxiters) 165 DIE(aTHX_ "Substitution loop"); 166 167 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs)) 168 cx->sb_rxtainted |= 2; 169 sv_catsv(dstr, POPs); 170 171 /* Are we done */ 172 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig, 173 s == m, cx->sb_targ, NULL, 174 ((cx->sb_rflags & REXEC_COPY_STR) 175 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST) 176 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST)))) 177 { 178 SV *targ = cx->sb_targ; 179 bool isutf8; 180 181 sv_catpvn(dstr, s, cx->sb_strend - s); 182 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx); 183 184 (void)SvOOK_off(targ); 185 Safefree(SvPVX(targ)); 186 SvPVX(targ) = SvPVX(dstr); 187 SvCUR_set(targ, SvCUR(dstr)); 188 SvLEN_set(targ, SvLEN(dstr)); 189 isutf8 = DO_UTF8(dstr); 190 SvPVX(dstr) = 0; 191 sv_free(dstr); 192 193 TAINT_IF(cx->sb_rxtainted & 1); 194 PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1))); 195 196 (void)SvPOK_only(targ); 197 if (isutf8) 198 SvUTF8_on(targ); 199 TAINT_IF(cx->sb_rxtainted); 200 SvSETMAGIC(targ); 201 SvTAINT(targ); 202 203 LEAVE_SCOPE(cx->sb_oldsave); 204 POPSUBST(cx); 205 RETURNOP(pm->op_next); 206 } 207 } 208 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) { 209 m = s; 210 s = orig; 211 cx->sb_orig = orig = rx->subbeg; 212 s = orig + (m - s); 213 cx->sb_strend = s + (cx->sb_strend - m); 214 } 215 cx->sb_m = m = rx->startp[0] + orig; 216 sv_catpvn(dstr, s, m-s); 217 cx->sb_s = rx->endp[0] + orig; 218 { /* Update the pos() information. */ 219 SV *sv = cx->sb_targ; 220 MAGIC *mg; 221 I32 i; 222 if (SvTYPE(sv) < SVt_PVMG) 223 SvUPGRADE(sv, SVt_PVMG); 224 if (!(mg = mg_find(sv, 'g'))) { 225 sv_magic(sv, Nullsv, 'g', Nullch, 0); 226 mg = mg_find(sv, 'g'); 227 } 228 i = m - orig; 229 if (DO_UTF8(sv)) 230 sv_pos_b2u(sv, &i); 231 mg->mg_len = i; 232 } 233 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx); 234 rxres_save(&cx->sb_rxres, rx); 235 RETURNOP(pm->op_pmreplstart); 236 } 237 238 void 239 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) 240 { 241 UV *p = (UV*)*rsp; 242 U32 i; 243 244 if (!p || p[1] < rx->nparens) { 245 i = 6 + rx->nparens * 2; 246 if (!p) 247 New(501, p, i, UV); 248 else 249 Renew(p, i, UV); 250 *rsp = (void*)p; 251 } 252 253 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch); 254 RX_MATCH_COPIED_off(rx); 255 256 *p++ = rx->nparens; 257 258 *p++ = PTR2UV(rx->subbeg); 259 *p++ = (UV)rx->sublen; 260 for (i = 0; i <= rx->nparens; ++i) { 261 *p++ = (UV)rx->startp[i]; 262 *p++ = (UV)rx->endp[i]; 263 } 264 } 265 266 void 267 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx) 268 { 269 UV *p = (UV*)*rsp; 270 U32 i; 271 272 if (RX_MATCH_COPIED(rx)) 273 Safefree(rx->subbeg); 274 RX_MATCH_COPIED_set(rx, *p); 275 *p++ = 0; 276 277 rx->nparens = *p++; 278 279 rx->subbeg = INT2PTR(char*,*p++); 280 rx->sublen = (I32)(*p++); 281 for (i = 0; i <= rx->nparens; ++i) { 282 rx->startp[i] = (I32)(*p++); 283 rx->endp[i] = (I32)(*p++); 284 } 285 } 286 287 void 288 Perl_rxres_free(pTHX_ void **rsp) 289 { 290 UV *p = (UV*)*rsp; 291 292 if (p) { 293 Safefree(INT2PTR(char*,*p)); 294 Safefree(p); 295 *rsp = Null(void*); 296 } 297 } 298 299 PP(pp_formline) 300 { 301 dSP; dMARK; dORIGMARK; 302 register SV *tmpForm = *++MARK; 303 register U16 *fpc; 304 register char *t; 305 register char *f; 306 register char *s; 307 register char *send; 308 register I32 arg; 309 register SV *sv; 310 char *item; 311 I32 itemsize; 312 I32 fieldsize; 313 I32 lines = 0; 314 bool chopspace = (strchr(PL_chopset, ' ') != Nullch); 315 char *chophere; 316 char *linemark; 317 NV value; 318 bool gotsome; 319 STRLEN len; 320 STRLEN fudge = SvCUR(tmpForm) * (IN_BYTE ? 1 : 3) + 1; 321 bool item_is_utf = FALSE; 322 323 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) { 324 if (SvREADONLY(tmpForm)) { 325 SvREADONLY_off(tmpForm); 326 doparseform(tmpForm); 327 SvREADONLY_on(tmpForm); 328 } 329 else 330 doparseform(tmpForm); 331 } 332 333 SvPV_force(PL_formtarget, len); 334 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */ 335 t += len; 336 f = SvPV(tmpForm, len); 337 /* need to jump to the next word */ 338 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN; 339 340 fpc = (U16*)s; 341 342 for (;;) { 343 DEBUG_f( { 344 char *name = "???"; 345 arg = -1; 346 switch (*fpc) { 347 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break; 348 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break; 349 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break; 350 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break; 351 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break; 352 353 case FF_CHECKNL: name = "CHECKNL"; break; 354 case FF_CHECKCHOP: name = "CHECKCHOP"; break; 355 case FF_SPACE: name = "SPACE"; break; 356 case FF_HALFSPACE: name = "HALFSPACE"; break; 357 case FF_ITEM: name = "ITEM"; break; 358 case FF_CHOP: name = "CHOP"; break; 359 case FF_LINEGLOB: name = "LINEGLOB"; break; 360 case FF_NEWLINE: name = "NEWLINE"; break; 361 case FF_MORE: name = "MORE"; break; 362 case FF_LINEMARK: name = "LINEMARK"; break; 363 case FF_END: name = "END"; break; 364 } 365 if (arg >= 0) 366 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg); 367 else 368 PerlIO_printf(Perl_debug_log, "%-16s\n", name); 369 } ) 370 switch (*fpc++) { 371 case FF_LINEMARK: 372 linemark = t; 373 lines++; 374 gotsome = FALSE; 375 break; 376 377 case FF_LITERAL: 378 arg = *fpc++; 379 while (arg--) 380 *t++ = *f++; 381 break; 382 383 case FF_SKIP: 384 f += *fpc++; 385 break; 386 387 case FF_FETCH: 388 arg = *fpc++; 389 f += arg; 390 fieldsize = arg; 391 392 if (MARK < SP) 393 sv = *++MARK; 394 else { 395 sv = &PL_sv_no; 396 if (ckWARN(WARN_SYNTAX)) 397 Perl_warner(aTHX_ WARN_SYNTAX, "Not enough format arguments"); 398 } 399 break; 400 401 case FF_CHECKNL: 402 item = s = SvPV(sv, len); 403 itemsize = len; 404 if (DO_UTF8(sv)) { 405 itemsize = sv_len_utf8(sv); 406 if (itemsize != len) { 407 I32 itembytes; 408 if (itemsize > fieldsize) { 409 itemsize = fieldsize; 410 itembytes = itemsize; 411 sv_pos_u2b(sv, &itembytes, 0); 412 } 413 else 414 itembytes = len; 415 send = chophere = s + itembytes; 416 while (s < send) { 417 if (*s & ~31) 418 gotsome = TRUE; 419 else if (*s == '\n') 420 break; 421 s++; 422 } 423 item_is_utf = TRUE; 424 itemsize = s - item; 425 sv_pos_b2u(sv, &itemsize); 426 break; 427 } 428 } 429 item_is_utf = FALSE; 430 if (itemsize > fieldsize) 431 itemsize = fieldsize; 432 send = chophere = s + itemsize; 433 while (s < send) { 434 if (*s & ~31) 435 gotsome = TRUE; 436 else if (*s == '\n') 437 break; 438 s++; 439 } 440 itemsize = s - item; 441 break; 442 443 case FF_CHECKCHOP: 444 item = s = SvPV(sv, len); 445 itemsize = len; 446 if (DO_UTF8(sv)) { 447 itemsize = sv_len_utf8(sv); 448 if (itemsize != len) { 449 I32 itembytes; 450 if (itemsize <= fieldsize) { 451 send = chophere = s + itemsize; 452 while (s < send) { 453 if (*s == '\r') { 454 itemsize = s - item; 455 break; 456 } 457 if (*s++ & ~31) 458 gotsome = TRUE; 459 } 460 } 461 else { 462 itemsize = fieldsize; 463 itembytes = itemsize; 464 sv_pos_u2b(sv, &itembytes, 0); 465 send = chophere = s + itembytes; 466 while (s < send || (s == send && isSPACE(*s))) { 467 if (isSPACE(*s)) { 468 if (chopspace) 469 chophere = s; 470 if (*s == '\r') 471 break; 472 } 473 else { 474 if (*s & ~31) 475 gotsome = TRUE; 476 if (strchr(PL_chopset, *s)) 477 chophere = s + 1; 478 } 479 s++; 480 } 481 itemsize = chophere - item; 482 sv_pos_b2u(sv, &itemsize); 483 } 484 item_is_utf = TRUE; 485 break; 486 } 487 } 488 item_is_utf = FALSE; 489 if (itemsize <= fieldsize) { 490 send = chophere = s + itemsize; 491 while (s < send) { 492 if (*s == '\r') { 493 itemsize = s - item; 494 break; 495 } 496 if (*s++ & ~31) 497 gotsome = TRUE; 498 } 499 } 500 else { 501 itemsize = fieldsize; 502 send = chophere = s + itemsize; 503 while (s < send || (s == send && isSPACE(*s))) { 504 if (isSPACE(*s)) { 505 if (chopspace) 506 chophere = s; 507 if (*s == '\r') 508 break; 509 } 510 else { 511 if (*s & ~31) 512 gotsome = TRUE; 513 if (strchr(PL_chopset, *s)) 514 chophere = s + 1; 515 } 516 s++; 517 } 518 itemsize = chophere - item; 519 } 520 break; 521 522 case FF_SPACE: 523 arg = fieldsize - itemsize; 524 if (arg) { 525 fieldsize -= arg; 526 while (arg-- > 0) 527 *t++ = ' '; 528 } 529 break; 530 531 case FF_HALFSPACE: 532 arg = fieldsize - itemsize; 533 if (arg) { 534 arg /= 2; 535 fieldsize -= arg; 536 while (arg-- > 0) 537 *t++ = ' '; 538 } 539 break; 540 541 case FF_ITEM: 542 arg = itemsize; 543 s = item; 544 if (item_is_utf) { 545 while (arg--) { 546 if (UTF8_IS_CONTINUED(*s)) { 547 switch (UTF8SKIP(s)) { 548 case 7: *t++ = *s++; 549 case 6: *t++ = *s++; 550 case 5: *t++ = *s++; 551 case 4: *t++ = *s++; 552 case 3: *t++ = *s++; 553 case 2: *t++ = *s++; 554 case 1: *t++ = *s++; 555 } 556 } 557 else { 558 if ( !((*t++ = *s++) & ~31) ) 559 t[-1] = ' '; 560 } 561 } 562 break; 563 } 564 while (arg--) { 565 #ifdef EBCDIC 566 int ch = *t++ = *s++; 567 if (iscntrl(ch)) 568 #else 569 if ( !((*t++ = *s++) & ~31) ) 570 #endif 571 t[-1] = ' '; 572 } 573 break; 574 575 case FF_CHOP: 576 s = chophere; 577 if (chopspace) { 578 while (*s && isSPACE(*s)) 579 s++; 580 } 581 sv_chop(sv,s); 582 break; 583 584 case FF_LINEGLOB: 585 item = s = SvPV(sv, len); 586 itemsize = len; 587 item_is_utf = FALSE; /* XXX is this correct? */ 588 if (itemsize) { 589 gotsome = TRUE; 590 send = s + itemsize; 591 while (s < send) { 592 if (*s++ == '\n') { 593 if (s == send) 594 itemsize--; 595 else 596 lines++; 597 } 598 } 599 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget)); 600 sv_catpvn(PL_formtarget, item, itemsize); 601 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1); 602 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget); 603 } 604 break; 605 606 case FF_DECIMAL: 607 /* If the field is marked with ^ and the value is undefined, 608 blank it out. */ 609 arg = *fpc++; 610 if ((arg & 512) && !SvOK(sv)) { 611 arg = fieldsize; 612 while (arg--) 613 *t++ = ' '; 614 break; 615 } 616 gotsome = TRUE; 617 value = SvNV(sv); 618 /* Formats aren't yet marked for locales, so assume "yes". */ 619 { 620 STORE_NUMERIC_STANDARD_SET_LOCAL(); 621 #if defined(USE_LONG_DOUBLE) 622 if (arg & 256) { 623 sprintf(t, "%#*.*" PERL_PRIfldbl, 624 (int) fieldsize, (int) arg & 255, value); 625 } else { 626 sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value); 627 } 628 #else 629 if (arg & 256) { 630 sprintf(t, "%#*.*f", 631 (int) fieldsize, (int) arg & 255, value); 632 } else { 633 sprintf(t, "%*.0f", 634 (int) fieldsize, value); 635 } 636 #endif 637 RESTORE_NUMERIC_STANDARD(); 638 } 639 t += fieldsize; 640 break; 641 642 case FF_NEWLINE: 643 f++; 644 while (t-- > linemark && *t == ' ') ; 645 t++; 646 *t++ = '\n'; 647 break; 648 649 case FF_BLANK: 650 arg = *fpc++; 651 if (gotsome) { 652 if (arg) { /* repeat until fields exhausted? */ 653 *t = '\0'; 654 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget)); 655 lines += FmLINES(PL_formtarget); 656 if (lines == 200) { 657 arg = t - linemark; 658 if (strnEQ(linemark, linemark - arg, arg)) 659 DIE(aTHX_ "Runaway format"); 660 } 661 FmLINES(PL_formtarget) = lines; 662 SP = ORIGMARK; 663 RETURNOP(cLISTOP->op_first); 664 } 665 } 666 else { 667 t = linemark; 668 lines--; 669 } 670 break; 671 672 case FF_MORE: 673 s = chophere; 674 send = item + len; 675 if (chopspace) { 676 while (*s && isSPACE(*s) && s < send) 677 s++; 678 } 679 if (s < send) { 680 arg = fieldsize - itemsize; 681 if (arg) { 682 fieldsize -= arg; 683 while (arg-- > 0) 684 *t++ = ' '; 685 } 686 s = t - 3; 687 if (strnEQ(s," ",3)) { 688 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1])) 689 s--; 690 } 691 *s++ = '.'; 692 *s++ = '.'; 693 *s++ = '.'; 694 } 695 break; 696 697 case FF_END: 698 *t = '\0'; 699 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget)); 700 FmLINES(PL_formtarget) += lines; 701 SP = ORIGMARK; 702 RETPUSHYES; 703 } 704 } 705 } 706 707 PP(pp_grepstart) 708 { 709 dSP; 710 SV *src; 711 712 if (PL_stack_base + *PL_markstack_ptr == SP) { 713 (void)POPMARK; 714 if (GIMME_V == G_SCALAR) 715 XPUSHs(sv_2mortal(newSViv(0))); 716 RETURNOP(PL_op->op_next->op_next); 717 } 718 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1; 719 pp_pushmark(); /* push dst */ 720 pp_pushmark(); /* push src */ 721 ENTER; /* enter outer scope */ 722 723 SAVETMPS; 724 /* SAVE_DEFSV does *not* suffice here for USE_THREADS */ 725 SAVESPTR(DEFSV); 726 ENTER; /* enter inner scope */ 727 SAVEVPTR(PL_curpm); 728 729 src = PL_stack_base[*PL_markstack_ptr]; 730 SvTEMP_off(src); 731 DEFSV = src; 732 733 PUTBACK; 734 if (PL_op->op_type == OP_MAPSTART) 735 pp_pushmark(); /* push top */ 736 return ((LOGOP*)PL_op->op_next)->op_other; 737 } 738 739 PP(pp_mapstart) 740 { 741 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */ 742 } 743 744 PP(pp_mapwhile) 745 { 746 dSP; 747 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */ 748 I32 count; 749 I32 shift; 750 SV** src; 751 SV** dst; 752 753 /* first, move source pointer to the next item in the source list */ 754 ++PL_markstack_ptr[-1]; 755 756 /* if there are new items, push them into the destination list */ 757 if (items) { 758 /* might need to make room back there first */ 759 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) { 760 /* XXX this implementation is very pessimal because the stack 761 * is repeatedly extended for every set of items. Is possible 762 * to do this without any stack extension or copying at all 763 * by maintaining a separate list over which the map iterates 764 * (like foreach does). --gsar */ 765 766 /* everything in the stack after the destination list moves 767 * towards the end the stack by the amount of room needed */ 768 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]); 769 770 /* items to shift up (accounting for the moved source pointer) */ 771 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1); 772 773 /* This optimization is by Ben Tilly and it does 774 * things differently from what Sarathy (gsar) 775 * is describing. The downside of this optimization is 776 * that leaves "holes" (uninitialized and hopefully unused areas) 777 * to the Perl stack, but on the other hand this 778 * shouldn't be a problem. If Sarathy's idea gets 779 * implemented, this optimization should become 780 * irrelevant. --jhi */ 781 if (shift < count) 782 shift = count; /* Avoid shifting too often --Ben Tilly */ 783 784 EXTEND(SP,shift); 785 src = SP; 786 dst = (SP += shift); 787 PL_markstack_ptr[-1] += shift; 788 *PL_markstack_ptr += shift; 789 while (count--) 790 *dst-- = *src--; 791 } 792 /* copy the new items down to the destination list */ 793 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1; 794 while (items--) 795 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs); 796 } 797 LEAVE; /* exit inner scope */ 798 799 /* All done yet? */ 800 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) { 801 I32 gimme = GIMME_V; 802 803 (void)POPMARK; /* pop top */ 804 LEAVE; /* exit outer scope */ 805 (void)POPMARK; /* pop src */ 806 items = --*PL_markstack_ptr - PL_markstack_ptr[-1]; 807 (void)POPMARK; /* pop dst */ 808 SP = PL_stack_base + POPMARK; /* pop original mark */ 809 if (gimme == G_SCALAR) { 810 dTARGET; 811 XPUSHi(items); 812 } 813 else if (gimme == G_ARRAY) 814 SP += items; 815 RETURN; 816 } 817 else { 818 SV *src; 819 820 ENTER; /* enter inner scope */ 821 SAVEVPTR(PL_curpm); 822 823 /* set $_ to the new source item */ 824 src = PL_stack_base[PL_markstack_ptr[-1]]; 825 SvTEMP_off(src); 826 DEFSV = src; 827 828 RETURNOP(cLOGOP->op_other); 829 } 830 } 831 832 PP(pp_sort) 833 { 834 dSP; dMARK; dORIGMARK; 835 register SV **up; 836 SV **myorigmark = ORIGMARK; 837 register I32 max; 838 HV *stash; 839 GV *gv; 840 CV *cv; 841 I32 gimme = GIMME; 842 OP* nextop = PL_op->op_next; 843 I32 overloading = 0; 844 bool hasargs = FALSE; 845 I32 is_xsub = 0; 846 847 if (gimme != G_ARRAY) { 848 SP = MARK; 849 RETPUSHUNDEF; 850 } 851 852 ENTER; 853 SAVEVPTR(PL_sortcop); 854 if (PL_op->op_flags & OPf_STACKED) { 855 if (PL_op->op_flags & OPf_SPECIAL) { 856 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */ 857 kid = kUNOP->op_first; /* pass rv2gv */ 858 kid = kUNOP->op_first; /* pass leave */ 859 PL_sortcop = kid->op_next; 860 stash = CopSTASH(PL_curcop); 861 } 862 else { 863 cv = sv_2cv(*++MARK, &stash, &gv, 0); 864 if (cv && SvPOK(cv)) { 865 STRLEN n_a; 866 char *proto = SvPV((SV*)cv, n_a); 867 if (proto && strEQ(proto, "$$")) { 868 hasargs = TRUE; 869 } 870 } 871 if (!(cv && CvROOT(cv))) { 872 if (cv && CvXSUB(cv)) { 873 is_xsub = 1; 874 } 875 else if (gv) { 876 SV *tmpstr = sv_newmortal(); 877 gv_efullname3(tmpstr, gv, Nullch); 878 DIE(aTHX_ "Undefined sort subroutine \"%s\" called", 879 SvPVX(tmpstr)); 880 } 881 else { 882 DIE(aTHX_ "Undefined subroutine in sort"); 883 } 884 } 885 886 if (is_xsub) 887 PL_sortcop = (OP*)cv; 888 else { 889 PL_sortcop = CvSTART(cv); 890 SAVEVPTR(CvROOT(cv)->op_ppaddr); 891 CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL]; 892 893 SAVEVPTR(PL_curpad); 894 PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]); 895 } 896 } 897 } 898 else { 899 PL_sortcop = Nullop; 900 stash = CopSTASH(PL_curcop); 901 } 902 903 up = myorigmark + 1; 904 while (MARK < SP) { /* This may or may not shift down one here. */ 905 /*SUPPRESS 560*/ 906 if ((*up = *++MARK)) { /* Weed out nulls. */ 907 SvTEMP_off(*up); 908 if (!PL_sortcop && !SvPOK(*up)) { 909 STRLEN n_a; 910 if (SvAMAGIC(*up)) 911 overloading = 1; 912 else 913 (void)sv_2pv(*up, &n_a); 914 } 915 up++; 916 } 917 } 918 max = --up - myorigmark; 919 if (PL_sortcop) { 920 if (max > 1) { 921 PERL_CONTEXT *cx; 922 SV** newsp; 923 bool oldcatch = CATCH_GET; 924 925 SAVETMPS; 926 SAVEOP(); 927 928 CATCH_SET(TRUE); 929 PUSHSTACKi(PERLSI_SORT); 930 if (!hasargs && !is_xsub) { 931 if (PL_sortstash != stash || !PL_firstgv || !PL_secondgv) { 932 SAVESPTR(PL_firstgv); 933 SAVESPTR(PL_secondgv); 934 PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV); 935 PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV); 936 PL_sortstash = stash; 937 } 938 #ifdef USE_THREADS 939 sv_lock((SV *)PL_firstgv); 940 sv_lock((SV *)PL_secondgv); 941 #endif 942 SAVESPTR(GvSV(PL_firstgv)); 943 SAVESPTR(GvSV(PL_secondgv)); 944 } 945 946 PUSHBLOCK(cx, CXt_NULL, PL_stack_base); 947 if (!(PL_op->op_flags & OPf_SPECIAL)) { 948 cx->cx_type = CXt_SUB; 949 cx->blk_gimme = G_SCALAR; 950 PUSHSUB(cx); 951 if (!CvDEPTH(cv)) 952 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */ 953 } 954 PL_sortcxix = cxstack_ix; 955 956 if (hasargs && !is_xsub) { 957 /* This is mostly copied from pp_entersub */ 958 AV *av = (AV*)PL_curpad[0]; 959 960 #ifndef USE_THREADS 961 cx->blk_sub.savearray = GvAV(PL_defgv); 962 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av); 963 #endif /* USE_THREADS */ 964 cx->blk_sub.oldcurpad = PL_curpad; 965 cx->blk_sub.argarray = av; 966 } 967 qsortsv((myorigmark+1), max, 968 is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv); 969 970 POPBLOCK(cx,PL_curpm); 971 PL_stack_sp = newsp; 972 POPSTACK; 973 CATCH_SET(oldcatch); 974 } 975 } 976 else { 977 if (max > 1) { 978 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */ 979 qsortsv(ORIGMARK+1, max, 980 (PL_op->op_private & OPpSORT_NUMERIC) 981 ? ( (PL_op->op_private & OPpSORT_INTEGER) 982 ? ( overloading ? amagic_i_ncmp : sv_i_ncmp) 983 : ( overloading ? amagic_ncmp : sv_ncmp)) 984 : ( (PL_op->op_private & OPpLOCALE) 985 ? ( overloading 986 ? amagic_cmp_locale 987 : sv_cmp_locale_static) 988 : ( overloading ? amagic_cmp : sv_cmp_static))); 989 if (PL_op->op_private & OPpSORT_REVERSE) { 990 SV **p = ORIGMARK+1; 991 SV **q = ORIGMARK+max; 992 while (p < q) { 993 SV *tmp = *p; 994 *p++ = *q; 995 *q-- = tmp; 996 } 997 } 998 } 999 } 1000 LEAVE; 1001 PL_stack_sp = ORIGMARK + max; 1002 return nextop; 1003 } 1004 1005 /* Range stuff. */ 1006 1007 PP(pp_range) 1008 { 1009 if (GIMME == G_ARRAY) 1010 return NORMAL; 1011 if (SvTRUEx(PAD_SV(PL_op->op_targ))) 1012 return cLOGOP->op_other; 1013 else 1014 return NORMAL; 1015 } 1016 1017 PP(pp_flip) 1018 { 1019 dSP; 1020 1021 if (GIMME == G_ARRAY) { 1022 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other); 1023 } 1024 else { 1025 dTOPss; 1026 SV *targ = PAD_SV(PL_op->op_targ); 1027 int flip; 1028 1029 if (PL_op->op_private & OPpFLIP_LINENUM) { 1030 struct io *gp_io; 1031 flip = PL_last_in_gv 1032 && (gp_io = GvIOp(PL_last_in_gv)) 1033 && SvIV(sv) == (IV)IoLINES(gp_io); 1034 } else { 1035 flip = SvTRUE(sv); 1036 } 1037 if (flip) { 1038 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1); 1039 if (PL_op->op_flags & OPf_SPECIAL) { 1040 sv_setiv(targ, 1); 1041 SETs(targ); 1042 RETURN; 1043 } 1044 else { 1045 sv_setiv(targ, 0); 1046 SP--; 1047 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other); 1048 } 1049 } 1050 sv_setpv(TARG, ""); 1051 SETs(targ); 1052 RETURN; 1053 } 1054 } 1055 1056 PP(pp_flop) 1057 { 1058 dSP; 1059 1060 if (GIMME == G_ARRAY) { 1061 dPOPPOPssrl; 1062 register I32 i, j; 1063 register SV *sv; 1064 I32 max; 1065 1066 if (SvGMAGICAL(left)) 1067 mg_get(left); 1068 if (SvGMAGICAL(right)) 1069 mg_get(right); 1070 1071 if (SvNIOKp(left) || !SvPOKp(left) || 1072 SvNIOKp(right) || !SvPOKp(right) || 1073 (looks_like_number(left) && *SvPVX(left) != '0' && 1074 looks_like_number(right) && *SvPVX(right) != '0')) 1075 { 1076 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX) 1077 DIE(aTHX_ "Range iterator outside integer range"); 1078 i = SvIV(left); 1079 max = SvIV(right); 1080 if (max >= i) { 1081 j = max - i + 1; 1082 EXTEND_MORTAL(j); 1083 EXTEND(SP, j); 1084 } 1085 else 1086 j = 0; 1087 while (j--) { 1088 sv = sv_2mortal(newSViv(i++)); 1089 PUSHs(sv); 1090 } 1091 } 1092 else { 1093 SV *final = sv_mortalcopy(right); 1094 STRLEN len, n_a; 1095 char *tmps = SvPV(final, len); 1096 1097 sv = sv_mortalcopy(left); 1098 SvPV_force(sv,n_a); 1099 while (!SvNIOKp(sv) && SvCUR(sv) <= len) { 1100 XPUSHs(sv); 1101 if (strEQ(SvPVX(sv),tmps)) 1102 break; 1103 sv = sv_2mortal(newSVsv(sv)); 1104 sv_inc(sv); 1105 } 1106 } 1107 } 1108 else { 1109 dTOPss; 1110 SV *targ = PAD_SV(cUNOP->op_first->op_targ); 1111 sv_inc(targ); 1112 if ((PL_op->op_private & OPpFLIP_LINENUM) 1113 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv))) 1114 : SvTRUE(sv) ) { 1115 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0); 1116 sv_catpv(targ, "E0"); 1117 } 1118 SETs(targ); 1119 } 1120 1121 RETURN; 1122 } 1123 1124 /* Control. */ 1125 1126 STATIC I32 1127 S_dopoptolabel(pTHX_ char *label) 1128 { 1129 register I32 i; 1130 register PERL_CONTEXT *cx; 1131 1132 for (i = cxstack_ix; i >= 0; i--) { 1133 cx = &cxstack[i]; 1134 switch (CxTYPE(cx)) { 1135 case CXt_SUBST: 1136 if (ckWARN(WARN_EXITING)) 1137 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s", 1138 PL_op_name[PL_op->op_type]); 1139 break; 1140 case CXt_SUB: 1141 if (ckWARN(WARN_EXITING)) 1142 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s", 1143 PL_op_name[PL_op->op_type]); 1144 break; 1145 case CXt_FORMAT: 1146 if (ckWARN(WARN_EXITING)) 1147 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s", 1148 PL_op_name[PL_op->op_type]); 1149 break; 1150 case CXt_EVAL: 1151 if (ckWARN(WARN_EXITING)) 1152 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s", 1153 PL_op_name[PL_op->op_type]); 1154 break; 1155 case CXt_NULL: 1156 if (ckWARN(WARN_EXITING)) 1157 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s", 1158 PL_op_name[PL_op->op_type]); 1159 return -1; 1160 case CXt_LOOP: 1161 if (!cx->blk_loop.label || 1162 strNE(label, cx->blk_loop.label) ) { 1163 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n", 1164 (long)i, cx->blk_loop.label)); 1165 continue; 1166 } 1167 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label)); 1168 return i; 1169 } 1170 } 1171 return i; 1172 } 1173 1174 I32 1175 Perl_dowantarray(pTHX) 1176 { 1177 I32 gimme = block_gimme(); 1178 return (gimme == G_VOID) ? G_SCALAR : gimme; 1179 } 1180 1181 I32 1182 Perl_block_gimme(pTHX) 1183 { 1184 I32 cxix; 1185 1186 cxix = dopoptosub(cxstack_ix); 1187 if (cxix < 0) 1188 return G_VOID; 1189 1190 switch (cxstack[cxix].blk_gimme) { 1191 case G_VOID: 1192 return G_VOID; 1193 case G_SCALAR: 1194 return G_SCALAR; 1195 case G_ARRAY: 1196 return G_ARRAY; 1197 default: 1198 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme); 1199 /* NOTREACHED */ 1200 return 0; 1201 } 1202 } 1203 1204 I32 1205 Perl_is_lvalue_sub(pTHX) 1206 { 1207 I32 cxix; 1208 1209 cxix = dopoptosub(cxstack_ix); 1210 assert(cxix >= 0); /* We should only be called from inside subs */ 1211 1212 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv)) 1213 return cxstack[cxix].blk_sub.lval; 1214 else 1215 return 0; 1216 } 1217 1218 STATIC I32 1219 S_dopoptosub(pTHX_ I32 startingblock) 1220 { 1221 return dopoptosub_at(cxstack, startingblock); 1222 } 1223 1224 STATIC I32 1225 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock) 1226 { 1227 I32 i; 1228 register PERL_CONTEXT *cx; 1229 for (i = startingblock; i >= 0; i--) { 1230 cx = &cxstk[i]; 1231 switch (CxTYPE(cx)) { 1232 default: 1233 continue; 1234 case CXt_EVAL: 1235 case CXt_SUB: 1236 case CXt_FORMAT: 1237 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i)); 1238 return i; 1239 } 1240 } 1241 return i; 1242 } 1243 1244 STATIC I32 1245 S_dopoptoeval(pTHX_ I32 startingblock) 1246 { 1247 I32 i; 1248 register PERL_CONTEXT *cx; 1249 for (i = startingblock; i >= 0; i--) { 1250 cx = &cxstack[i]; 1251 switch (CxTYPE(cx)) { 1252 default: 1253 continue; 1254 case CXt_EVAL: 1255 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i)); 1256 return i; 1257 } 1258 } 1259 return i; 1260 } 1261 1262 STATIC I32 1263 S_dopoptoloop(pTHX_ I32 startingblock) 1264 { 1265 I32 i; 1266 register PERL_CONTEXT *cx; 1267 for (i = startingblock; i >= 0; i--) { 1268 cx = &cxstack[i]; 1269 switch (CxTYPE(cx)) { 1270 case CXt_SUBST: 1271 if (ckWARN(WARN_EXITING)) 1272 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s", 1273 PL_op_name[PL_op->op_type]); 1274 break; 1275 case CXt_SUB: 1276 if (ckWARN(WARN_EXITING)) 1277 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s", 1278 PL_op_name[PL_op->op_type]); 1279 break; 1280 case CXt_FORMAT: 1281 if (ckWARN(WARN_EXITING)) 1282 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s", 1283 PL_op_name[PL_op->op_type]); 1284 break; 1285 case CXt_EVAL: 1286 if (ckWARN(WARN_EXITING)) 1287 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s", 1288 PL_op_name[PL_op->op_type]); 1289 break; 1290 case CXt_NULL: 1291 if (ckWARN(WARN_EXITING)) 1292 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s", 1293 PL_op_name[PL_op->op_type]); 1294 return -1; 1295 case CXt_LOOP: 1296 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i)); 1297 return i; 1298 } 1299 } 1300 return i; 1301 } 1302 1303 void 1304 Perl_dounwind(pTHX_ I32 cxix) 1305 { 1306 register PERL_CONTEXT *cx; 1307 I32 optype; 1308 1309 while (cxstack_ix > cxix) { 1310 SV *sv; 1311 cx = &cxstack[cxstack_ix]; 1312 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n", 1313 (long) cxstack_ix, PL_block_type[CxTYPE(cx)])); 1314 /* Note: we don't need to restore the base context info till the end. */ 1315 switch (CxTYPE(cx)) { 1316 case CXt_SUBST: 1317 POPSUBST(cx); 1318 continue; /* not break */ 1319 case CXt_SUB: 1320 POPSUB(cx,sv); 1321 LEAVESUB(sv); 1322 break; 1323 case CXt_EVAL: 1324 POPEVAL(cx); 1325 break; 1326 case CXt_LOOP: 1327 POPLOOP(cx); 1328 break; 1329 case CXt_NULL: 1330 break; 1331 case CXt_FORMAT: 1332 POPFORMAT(cx); 1333 break; 1334 } 1335 cxstack_ix--; 1336 } 1337 } 1338 1339 void 1340 Perl_qerror(pTHX_ SV *err) 1341 { 1342 if (PL_in_eval) 1343 sv_catsv(ERRSV, err); 1344 else if (PL_errors) 1345 sv_catsv(PL_errors, err); 1346 else 1347 Perl_warn(aTHX_ "%"SVf, err); 1348 ++PL_error_count; 1349 } 1350 1351 OP * 1352 Perl_die_where(pTHX_ char *message, STRLEN msglen) 1353 { 1354 STRLEN n_a; 1355 if (PL_in_eval) { 1356 I32 cxix; 1357 register PERL_CONTEXT *cx; 1358 I32 gimme; 1359 SV **newsp; 1360 1361 if (message) { 1362 if (PL_in_eval & EVAL_KEEPERR) { 1363 static char prefix[] = "\t(in cleanup) "; 1364 SV *err = ERRSV; 1365 char *e = Nullch; 1366 if (!SvPOK(err)) 1367 sv_setpv(err,""); 1368 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) { 1369 e = SvPV(err, n_a); 1370 e += n_a - msglen; 1371 if (*e != *message || strNE(e,message)) 1372 e = Nullch; 1373 } 1374 if (!e) { 1375 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen); 1376 sv_catpvn(err, prefix, sizeof(prefix)-1); 1377 sv_catpvn(err, message, msglen); 1378 if (ckWARN(WARN_MISC)) { 1379 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1; 1380 Perl_warner(aTHX_ WARN_MISC, SvPVX(err)+start); 1381 } 1382 } 1383 } 1384 else 1385 sv_setpvn(ERRSV, message, msglen); 1386 } 1387 else 1388 message = SvPVx(ERRSV, msglen); 1389 1390 while ((cxix = dopoptoeval(cxstack_ix)) < 0 1391 && PL_curstackinfo->si_prev) 1392 { 1393 dounwind(-1); 1394 POPSTACK; 1395 } 1396 1397 if (cxix >= 0) { 1398 I32 optype; 1399 1400 if (cxix < cxstack_ix) 1401 dounwind(cxix); 1402 1403 POPBLOCK(cx,PL_curpm); 1404 if (CxTYPE(cx) != CXt_EVAL) { 1405 PerlIO_write(Perl_error_log, "panic: die ", 11); 1406 PerlIO_write(Perl_error_log, message, msglen); 1407 my_exit(1); 1408 } 1409 POPEVAL(cx); 1410 1411 if (gimme == G_SCALAR) 1412 *++newsp = &PL_sv_undef; 1413 PL_stack_sp = newsp; 1414 1415 LEAVE; 1416 1417 /* LEAVE could clobber PL_curcop (see save_re_context()) 1418 * XXX it might be better to find a way to avoid messing with 1419 * PL_curcop in save_re_context() instead, but this is a more 1420 * minimal fix --GSAR */ 1421 PL_curcop = cx->blk_oldcop; 1422 1423 if (optype == OP_REQUIRE) { 1424 char* msg = SvPVx(ERRSV, n_a); 1425 DIE(aTHX_ "%sCompilation failed in require", 1426 *msg ? msg : "Unknown error\n"); 1427 } 1428 return pop_return(); 1429 } 1430 } 1431 if (!message) 1432 message = SvPVx(ERRSV, msglen); 1433 { 1434 #ifdef USE_SFIO 1435 /* SFIO can really mess with your errno */ 1436 int e = errno; 1437 #endif 1438 PerlIO *serr = Perl_error_log; 1439 1440 PerlIO_write(serr, message, msglen); 1441 (void)PerlIO_flush(serr); 1442 #ifdef USE_SFIO 1443 errno = e; 1444 #endif 1445 } 1446 my_failure_exit(); 1447 /* NOTREACHED */ 1448 return 0; 1449 } 1450 1451 PP(pp_xor) 1452 { 1453 dSP; dPOPTOPssrl; 1454 if (SvTRUE(left) != SvTRUE(right)) 1455 RETSETYES; 1456 else 1457 RETSETNO; 1458 } 1459 1460 PP(pp_andassign) 1461 { 1462 dSP; 1463 if (!SvTRUE(TOPs)) 1464 RETURN; 1465 else 1466 RETURNOP(cLOGOP->op_other); 1467 } 1468 1469 PP(pp_orassign) 1470 { 1471 dSP; 1472 if (SvTRUE(TOPs)) 1473 RETURN; 1474 else 1475 RETURNOP(cLOGOP->op_other); 1476 } 1477 1478 PP(pp_caller) 1479 { 1480 dSP; 1481 register I32 cxix = dopoptosub(cxstack_ix); 1482 register PERL_CONTEXT *cx; 1483 register PERL_CONTEXT *ccstack = cxstack; 1484 PERL_SI *top_si = PL_curstackinfo; 1485 I32 dbcxix; 1486 I32 gimme; 1487 char *stashname; 1488 SV *sv; 1489 I32 count = 0; 1490 1491 if (MAXARG) 1492 count = POPi; 1493 EXTEND(SP, 10); 1494 for (;;) { 1495 /* we may be in a higher stacklevel, so dig down deeper */ 1496 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) { 1497 top_si = top_si->si_prev; 1498 ccstack = top_si->si_cxstack; 1499 cxix = dopoptosub_at(ccstack, top_si->si_cxix); 1500 } 1501 if (cxix < 0) { 1502 if (GIMME != G_ARRAY) 1503 RETPUSHUNDEF; 1504 RETURN; 1505 } 1506 if (PL_DBsub && cxix >= 0 && 1507 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub)) 1508 count++; 1509 if (!count--) 1510 break; 1511 cxix = dopoptosub_at(ccstack, cxix - 1); 1512 } 1513 1514 cx = &ccstack[cxix]; 1515 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { 1516 dbcxix = dopoptosub_at(ccstack, cxix - 1); 1517 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the 1518 field below is defined for any cx. */ 1519 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) 1520 cx = &ccstack[dbcxix]; 1521 } 1522 1523 stashname = CopSTASHPV(cx->blk_oldcop); 1524 if (GIMME != G_ARRAY) { 1525 if (!stashname) 1526 PUSHs(&PL_sv_undef); 1527 else { 1528 dTARGET; 1529 sv_setpv(TARG, stashname); 1530 PUSHs(TARG); 1531 } 1532 RETURN; 1533 } 1534 1535 if (!stashname) 1536 PUSHs(&PL_sv_undef); 1537 else 1538 PUSHs(sv_2mortal(newSVpv(stashname, 0))); 1539 PUSHs(sv_2mortal(newSVpv(CopFILE(cx->blk_oldcop), 0))); 1540 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop)))); 1541 if (!MAXARG) 1542 RETURN; 1543 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { 1544 /* So is ccstack[dbcxix]. */ 1545 sv = NEWSV(49, 0); 1546 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch); 1547 PUSHs(sv_2mortal(sv)); 1548 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs))); 1549 } 1550 else { 1551 PUSHs(sv_2mortal(newSVpvn("(eval)",6))); 1552 PUSHs(sv_2mortal(newSViv(0))); 1553 } 1554 gimme = (I32)cx->blk_gimme; 1555 if (gimme == G_VOID) 1556 PUSHs(&PL_sv_undef); 1557 else 1558 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY))); 1559 if (CxTYPE(cx) == CXt_EVAL) { 1560 /* eval STRING */ 1561 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) { 1562 PUSHs(cx->blk_eval.cur_text); 1563 PUSHs(&PL_sv_no); 1564 } 1565 /* require */ 1566 else if (cx->blk_eval.old_namesv) { 1567 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv))); 1568 PUSHs(&PL_sv_yes); 1569 } 1570 /* eval BLOCK (try blocks have old_namesv == 0) */ 1571 else { 1572 PUSHs(&PL_sv_undef); 1573 PUSHs(&PL_sv_undef); 1574 } 1575 } 1576 else { 1577 PUSHs(&PL_sv_undef); 1578 PUSHs(&PL_sv_undef); 1579 } 1580 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs 1581 && CopSTASH_eq(PL_curcop, PL_debstash)) 1582 { 1583 AV *ary = cx->blk_sub.argarray; 1584 int off = AvARRAY(ary) - AvALLOC(ary); 1585 1586 if (!PL_dbargs) { 1587 GV* tmpgv; 1588 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE, 1589 SVt_PVAV))); 1590 GvMULTI_on(tmpgv); 1591 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */ 1592 } 1593 1594 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off) 1595 av_extend(PL_dbargs, AvFILLp(ary) + off); 1596 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*); 1597 AvFILLp(PL_dbargs) = AvFILLp(ary) + off; 1598 } 1599 /* XXX only hints propagated via op_private are currently 1600 * visible (others are not easily accessible, since they 1601 * use the global PL_hints) */ 1602 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private & 1603 HINT_PRIVATE_MASK))); 1604 { 1605 SV * mask ; 1606 SV * old_warnings = cx->blk_oldcop->cop_warnings ; 1607 1608 if (old_warnings == pWARN_NONE || 1609 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)) 1610 mask = newSVpvn(WARN_NONEstring, WARNsize) ; 1611 else if (old_warnings == pWARN_ALL || 1612 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) 1613 mask = newSVpvn(WARN_ALLstring, WARNsize) ; 1614 else 1615 mask = newSVsv(old_warnings); 1616 PUSHs(sv_2mortal(mask)); 1617 } 1618 RETURN; 1619 } 1620 1621 PP(pp_reset) 1622 { 1623 dSP; 1624 char *tmps; 1625 STRLEN n_a; 1626 1627 if (MAXARG < 1) 1628 tmps = ""; 1629 else 1630 tmps = POPpx; 1631 sv_reset(tmps, CopSTASH(PL_curcop)); 1632 PUSHs(&PL_sv_yes); 1633 RETURN; 1634 } 1635 1636 PP(pp_lineseq) 1637 { 1638 return NORMAL; 1639 } 1640 1641 PP(pp_dbstate) 1642 { 1643 PL_curcop = (COP*)PL_op; 1644 TAINT_NOT; /* Each statement is presumed innocent */ 1645 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp; 1646 FREETMPS; 1647 1648 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace)) 1649 { 1650 dSP; 1651 register CV *cv; 1652 register PERL_CONTEXT *cx; 1653 I32 gimme = G_ARRAY; 1654 I32 hasargs; 1655 GV *gv; 1656 1657 gv = PL_DBgv; 1658 cv = GvCV(gv); 1659 if (!cv) 1660 DIE(aTHX_ "No DB::DB routine defined"); 1661 1662 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */ 1663 return NORMAL; 1664 1665 ENTER; 1666 SAVETMPS; 1667 1668 SAVEI32(PL_debug); 1669 SAVESTACK_POS(); 1670 PL_debug = 0; 1671 hasargs = 0; 1672 SPAGAIN; 1673 1674 push_return(PL_op->op_next); 1675 PUSHBLOCK(cx, CXt_SUB, SP); 1676 PUSHSUB(cx); 1677 CvDEPTH(cv)++; 1678 (void)SvREFCNT_inc(cv); 1679 SAVEVPTR(PL_curpad); 1680 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE)); 1681 RETURNOP(CvSTART(cv)); 1682 } 1683 else 1684 return NORMAL; 1685 } 1686 1687 PP(pp_scope) 1688 { 1689 return NORMAL; 1690 } 1691 1692 PP(pp_enteriter) 1693 { 1694 dSP; dMARK; 1695 register PERL_CONTEXT *cx; 1696 I32 gimme = GIMME_V; 1697 SV **svp; 1698 U32 cxtype = CXt_LOOP; 1699 #ifdef USE_ITHREADS 1700 void *iterdata; 1701 #endif 1702 1703 ENTER; 1704 SAVETMPS; 1705 1706 #ifdef USE_THREADS 1707 if (PL_op->op_flags & OPf_SPECIAL) { 1708 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */ 1709 SAVEGENERICSV(*svp); 1710 *svp = NEWSV(0,0); 1711 } 1712 else 1713 #endif /* USE_THREADS */ 1714 if (PL_op->op_targ) { 1715 #ifndef USE_ITHREADS 1716 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */ 1717 SAVESPTR(*svp); 1718 #else 1719 SAVEPADSV(PL_op->op_targ); 1720 iterdata = (void*)PL_op->op_targ; 1721 cxtype |= CXp_PADVAR; 1722 #endif 1723 } 1724 else { 1725 GV *gv = (GV*)POPs; 1726 svp = &GvSV(gv); /* symbol table variable */ 1727 SAVEGENERICSV(*svp); 1728 *svp = NEWSV(0,0); 1729 #ifdef USE_ITHREADS 1730 iterdata = (void*)gv; 1731 #endif 1732 } 1733 1734 ENTER; 1735 1736 PUSHBLOCK(cx, cxtype, SP); 1737 #ifdef USE_ITHREADS 1738 PUSHLOOP(cx, iterdata, MARK); 1739 #else 1740 PUSHLOOP(cx, svp, MARK); 1741 #endif 1742 if (PL_op->op_flags & OPf_STACKED) { 1743 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs); 1744 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) { 1745 dPOPss; 1746 if (SvNIOKp(sv) || !SvPOKp(sv) || 1747 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) || 1748 (looks_like_number(sv) && *SvPVX(sv) != '0' && 1749 looks_like_number((SV*)cx->blk_loop.iterary) && 1750 *SvPVX(cx->blk_loop.iterary) != '0')) 1751 { 1752 if (SvNV(sv) < IV_MIN || 1753 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX) 1754 DIE(aTHX_ "Range iterator outside integer range"); 1755 cx->blk_loop.iterix = SvIV(sv); 1756 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary); 1757 } 1758 else 1759 cx->blk_loop.iterlval = newSVsv(sv); 1760 } 1761 } 1762 else { 1763 cx->blk_loop.iterary = PL_curstack; 1764 AvFILLp(PL_curstack) = SP - PL_stack_base; 1765 cx->blk_loop.iterix = MARK - PL_stack_base; 1766 } 1767 1768 RETURN; 1769 } 1770 1771 PP(pp_enterloop) 1772 { 1773 dSP; 1774 register PERL_CONTEXT *cx; 1775 I32 gimme = GIMME_V; 1776 1777 ENTER; 1778 SAVETMPS; 1779 ENTER; 1780 1781 PUSHBLOCK(cx, CXt_LOOP, SP); 1782 PUSHLOOP(cx, 0, SP); 1783 1784 RETURN; 1785 } 1786 1787 PP(pp_leaveloop) 1788 { 1789 dSP; 1790 register PERL_CONTEXT *cx; 1791 I32 gimme; 1792 SV **newsp; 1793 PMOP *newpm; 1794 SV **mark; 1795 1796 POPBLOCK(cx,newpm); 1797 mark = newsp; 1798 newsp = PL_stack_base + cx->blk_loop.resetsp; 1799 1800 TAINT_NOT; 1801 if (gimme == G_VOID) 1802 ; /* do nothing */ 1803 else if (gimme == G_SCALAR) { 1804 if (mark < SP) 1805 *++newsp = sv_mortalcopy(*SP); 1806 else 1807 *++newsp = &PL_sv_undef; 1808 } 1809 else { 1810 while (mark < SP) { 1811 *++newsp = sv_mortalcopy(*++mark); 1812 TAINT_NOT; /* Each item is independent */ 1813 } 1814 } 1815 SP = newsp; 1816 PUTBACK; 1817 1818 POPLOOP(cx); /* Stack values are safe: release loop vars ... */ 1819 PL_curpm = newpm; /* ... and pop $1 et al */ 1820 1821 LEAVE; 1822 LEAVE; 1823 1824 return NORMAL; 1825 } 1826 1827 PP(pp_return) 1828 { 1829 dSP; dMARK; 1830 I32 cxix; 1831 register PERL_CONTEXT *cx; 1832 bool popsub2 = FALSE; 1833 bool clear_errsv = FALSE; 1834 I32 gimme; 1835 SV **newsp; 1836 PMOP *newpm; 1837 I32 optype = 0; 1838 SV *sv; 1839 1840 if (PL_curstackinfo->si_type == PERLSI_SORT) { 1841 if (cxstack_ix == PL_sortcxix 1842 || dopoptosub(cxstack_ix) <= PL_sortcxix) 1843 { 1844 if (cxstack_ix > PL_sortcxix) 1845 dounwind(PL_sortcxix); 1846 AvARRAY(PL_curstack)[1] = *SP; 1847 PL_stack_sp = PL_stack_base + 1; 1848 return 0; 1849 } 1850 } 1851 1852 cxix = dopoptosub(cxstack_ix); 1853 if (cxix < 0) 1854 DIE(aTHX_ "Can't return outside a subroutine"); 1855 if (cxix < cxstack_ix) 1856 dounwind(cxix); 1857 1858 POPBLOCK(cx,newpm); 1859 switch (CxTYPE(cx)) { 1860 case CXt_SUB: 1861 popsub2 = TRUE; 1862 break; 1863 case CXt_EVAL: 1864 if (!(PL_in_eval & EVAL_KEEPERR)) 1865 clear_errsv = TRUE; 1866 POPEVAL(cx); 1867 if (CxTRYBLOCK(cx)) 1868 break; 1869 lex_end(); 1870 if (optype == OP_REQUIRE && 1871 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) ) 1872 { 1873 /* Unassume the success we assumed earlier. */ 1874 SV *nsv = cx->blk_eval.old_namesv; 1875 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD); 1876 DIE(aTHX_ "%s did not return a true value", SvPVX(nsv)); 1877 } 1878 break; 1879 case CXt_FORMAT: 1880 POPFORMAT(cx); 1881 break; 1882 default: 1883 DIE(aTHX_ "panic: return"); 1884 } 1885 1886 TAINT_NOT; 1887 if (gimme == G_SCALAR) { 1888 if (MARK < SP) { 1889 if (popsub2) { 1890 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) { 1891 if (SvTEMP(TOPs)) { 1892 *++newsp = SvREFCNT_inc(*SP); 1893 FREETMPS; 1894 sv_2mortal(*newsp); 1895 } 1896 else { 1897 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */ 1898 FREETMPS; 1899 *++newsp = sv_mortalcopy(sv); 1900 SvREFCNT_dec(sv); 1901 } 1902 } 1903 else 1904 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP); 1905 } 1906 else 1907 *++newsp = sv_mortalcopy(*SP); 1908 } 1909 else 1910 *++newsp = &PL_sv_undef; 1911 } 1912 else if (gimme == G_ARRAY) { 1913 while (++MARK <= SP) { 1914 *++newsp = (popsub2 && SvTEMP(*MARK)) 1915 ? *MARK : sv_mortalcopy(*MARK); 1916 TAINT_NOT; /* Each item is independent */ 1917 } 1918 } 1919 PL_stack_sp = newsp; 1920 1921 /* Stack values are safe: */ 1922 if (popsub2) { 1923 POPSUB(cx,sv); /* release CV and @_ ... */ 1924 } 1925 else 1926 sv = Nullsv; 1927 PL_curpm = newpm; /* ... and pop $1 et al */ 1928 1929 LEAVE; 1930 LEAVESUB(sv); 1931 if (clear_errsv) 1932 sv_setpv(ERRSV,""); 1933 return pop_return(); 1934 } 1935 1936 PP(pp_last) 1937 { 1938 dSP; 1939 I32 cxix; 1940 register PERL_CONTEXT *cx; 1941 I32 pop2 = 0; 1942 I32 gimme; 1943 I32 optype; 1944 OP *nextop; 1945 SV **newsp; 1946 PMOP *newpm; 1947 SV **mark; 1948 SV *sv = Nullsv; 1949 1950 if (PL_op->op_flags & OPf_SPECIAL) { 1951 cxix = dopoptoloop(cxstack_ix); 1952 if (cxix < 0) 1953 DIE(aTHX_ "Can't \"last\" outside a loop block"); 1954 } 1955 else { 1956 cxix = dopoptolabel(cPVOP->op_pv); 1957 if (cxix < 0) 1958 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv); 1959 } 1960 if (cxix < cxstack_ix) 1961 dounwind(cxix); 1962 1963 POPBLOCK(cx,newpm); 1964 mark = newsp; 1965 switch (CxTYPE(cx)) { 1966 case CXt_LOOP: 1967 pop2 = CXt_LOOP; 1968 newsp = PL_stack_base + cx->blk_loop.resetsp; 1969 nextop = cx->blk_loop.last_op->op_next; 1970 break; 1971 case CXt_SUB: 1972 pop2 = CXt_SUB; 1973 nextop = pop_return(); 1974 break; 1975 case CXt_EVAL: 1976 POPEVAL(cx); 1977 nextop = pop_return(); 1978 break; 1979 case CXt_FORMAT: 1980 POPFORMAT(cx); 1981 nextop = pop_return(); 1982 break; 1983 default: 1984 DIE(aTHX_ "panic: last"); 1985 } 1986 1987 TAINT_NOT; 1988 if (gimme == G_SCALAR) { 1989 if (MARK < SP) 1990 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP)) 1991 ? *SP : sv_mortalcopy(*SP); 1992 else 1993 *++newsp = &PL_sv_undef; 1994 } 1995 else if (gimme == G_ARRAY) { 1996 while (++MARK <= SP) { 1997 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK)) 1998 ? *MARK : sv_mortalcopy(*MARK); 1999 TAINT_NOT; /* Each item is independent */ 2000 } 2001 } 2002 SP = newsp; 2003 PUTBACK; 2004 2005 /* Stack values are safe: */ 2006 switch (pop2) { 2007 case CXt_LOOP: 2008 POPLOOP(cx); /* release loop vars ... */ 2009 LEAVE; 2010 break; 2011 case CXt_SUB: 2012 POPSUB(cx,sv); /* release CV and @_ ... */ 2013 break; 2014 } 2015 PL_curpm = newpm; /* ... and pop $1 et al */ 2016 2017 LEAVE; 2018 LEAVESUB(sv); 2019 return nextop; 2020 } 2021 2022 PP(pp_next) 2023 { 2024 I32 cxix; 2025 register PERL_CONTEXT *cx; 2026 I32 inner; 2027 2028 if (PL_op->op_flags & OPf_SPECIAL) { 2029 cxix = dopoptoloop(cxstack_ix); 2030 if (cxix < 0) 2031 DIE(aTHX_ "Can't \"next\" outside a loop block"); 2032 } 2033 else { 2034 cxix = dopoptolabel(cPVOP->op_pv); 2035 if (cxix < 0) 2036 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv); 2037 } 2038 if (cxix < cxstack_ix) 2039 dounwind(cxix); 2040 2041 /* clear off anything above the scope we're re-entering, but 2042 * save the rest until after a possible continue block */ 2043 inner = PL_scopestack_ix; 2044 TOPBLOCK(cx); 2045 if (PL_scopestack_ix < inner) 2046 leave_scope(PL_scopestack[PL_scopestack_ix]); 2047 return cx->blk_loop.next_op; 2048 } 2049 2050 PP(pp_redo) 2051 { 2052 I32 cxix; 2053 register PERL_CONTEXT *cx; 2054 I32 oldsave; 2055 2056 if (PL_op->op_flags & OPf_SPECIAL) { 2057 cxix = dopoptoloop(cxstack_ix); 2058 if (cxix < 0) 2059 DIE(aTHX_ "Can't \"redo\" outside a loop block"); 2060 } 2061 else { 2062 cxix = dopoptolabel(cPVOP->op_pv); 2063 if (cxix < 0) 2064 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv); 2065 } 2066 if (cxix < cxstack_ix) 2067 dounwind(cxix); 2068 2069 TOPBLOCK(cx); 2070 oldsave = PL_scopestack[PL_scopestack_ix - 1]; 2071 LEAVE_SCOPE(oldsave); 2072 return cx->blk_loop.redo_op; 2073 } 2074 2075 STATIC OP * 2076 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit) 2077 { 2078 OP *kid; 2079 OP **ops = opstack; 2080 static char too_deep[] = "Target of goto is too deeply nested"; 2081 2082 if (ops >= oplimit) 2083 Perl_croak(aTHX_ too_deep); 2084 if (o->op_type == OP_LEAVE || 2085 o->op_type == OP_SCOPE || 2086 o->op_type == OP_LEAVELOOP || 2087 o->op_type == OP_LEAVETRY) 2088 { 2089 *ops++ = cUNOPo->op_first; 2090 if (ops >= oplimit) 2091 Perl_croak(aTHX_ too_deep); 2092 } 2093 *ops = 0; 2094 if (o->op_flags & OPf_KIDS) { 2095 /* First try all the kids at this level, since that's likeliest. */ 2096 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { 2097 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) && 2098 kCOP->cop_label && strEQ(kCOP->cop_label, label)) 2099 return kid; 2100 } 2101 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { 2102 if (kid == PL_lastgotoprobe) 2103 continue; 2104 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) && 2105 (ops == opstack || 2106 (ops[-1]->op_type != OP_NEXTSTATE && 2107 ops[-1]->op_type != OP_DBSTATE))) 2108 *ops++ = kid; 2109 if ((o = dofindlabel(kid, label, ops, oplimit))) 2110 return o; 2111 } 2112 } 2113 *ops = 0; 2114 return 0; 2115 } 2116 2117 PP(pp_dump) 2118 { 2119 return pp_goto(); 2120 /*NOTREACHED*/ 2121 } 2122 2123 PP(pp_goto) 2124 { 2125 dSP; 2126 OP *retop = 0; 2127 I32 ix; 2128 register PERL_CONTEXT *cx; 2129 #define GOTO_DEPTH 64 2130 OP *enterops[GOTO_DEPTH]; 2131 char *label; 2132 int do_dump = (PL_op->op_type == OP_DUMP); 2133 static char must_have_label[] = "goto must have label"; 2134 2135 label = 0; 2136 if (PL_op->op_flags & OPf_STACKED) { 2137 SV *sv = POPs; 2138 STRLEN n_a; 2139 2140 /* This egregious kludge implements goto &subroutine */ 2141 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) { 2142 I32 cxix; 2143 register PERL_CONTEXT *cx; 2144 CV* cv = (CV*)SvRV(sv); 2145 SV** mark; 2146 I32 items = 0; 2147 I32 oldsave; 2148 2149 retry: 2150 if (!CvROOT(cv) && !CvXSUB(cv)) { 2151 GV *gv = CvGV(cv); 2152 GV *autogv; 2153 if (gv) { 2154 SV *tmpstr; 2155 /* autoloaded stub? */ 2156 if (cv != GvCV(gv) && (cv = GvCV(gv))) 2157 goto retry; 2158 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), 2159 GvNAMELEN(gv), FALSE); 2160 if (autogv && (cv = GvCV(autogv))) 2161 goto retry; 2162 tmpstr = sv_newmortal(); 2163 gv_efullname3(tmpstr, gv, Nullch); 2164 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr)); 2165 } 2166 DIE(aTHX_ "Goto undefined subroutine"); 2167 } 2168 2169 /* First do some returnish stuff. */ 2170 cxix = dopoptosub(cxstack_ix); 2171 if (cxix < 0) 2172 DIE(aTHX_ "Can't goto subroutine outside a subroutine"); 2173 if (cxix < cxstack_ix) 2174 dounwind(cxix); 2175 TOPBLOCK(cx); 2176 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL) 2177 DIE(aTHX_ "Can't goto subroutine from an eval-string"); 2178 mark = PL_stack_sp; 2179 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) { 2180 /* put @_ back onto stack */ 2181 AV* av = cx->blk_sub.argarray; 2182 2183 items = AvFILLp(av) + 1; 2184 PL_stack_sp++; 2185 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */ 2186 Copy(AvARRAY(av), PL_stack_sp, items, SV*); 2187 PL_stack_sp += items; 2188 #ifndef USE_THREADS 2189 SvREFCNT_dec(GvAV(PL_defgv)); 2190 GvAV(PL_defgv) = cx->blk_sub.savearray; 2191 #endif /* USE_THREADS */ 2192 /* abandon @_ if it got reified */ 2193 if (AvREAL(av)) { 2194 (void)sv_2mortal((SV*)av); /* delay until return */ 2195 av = newAV(); 2196 av_extend(av, items-1); 2197 AvFLAGS(av) = AVf_REIFY; 2198 PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av); 2199 } 2200 } 2201 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */ 2202 AV* av; 2203 #ifdef USE_THREADS 2204 av = (AV*)PL_curpad[0]; 2205 #else 2206 av = GvAV(PL_defgv); 2207 #endif 2208 items = AvFILLp(av) + 1; 2209 PL_stack_sp++; 2210 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */ 2211 Copy(AvARRAY(av), PL_stack_sp, items, SV*); 2212 PL_stack_sp += items; 2213 } 2214 if (CxTYPE(cx) == CXt_SUB && 2215 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth)) 2216 SvREFCNT_dec(cx->blk_sub.cv); 2217 oldsave = PL_scopestack[PL_scopestack_ix - 1]; 2218 LEAVE_SCOPE(oldsave); 2219 2220 /* Now do some callish stuff. */ 2221 SAVETMPS; 2222 if (CvXSUB(cv)) { 2223 #ifdef PERL_XSUB_OLDSTYLE 2224 if (CvOLDSTYLE(cv)) { 2225 I32 (*fp3)(int,int,int); 2226 while (SP > mark) { 2227 SP[1] = SP[0]; 2228 SP--; 2229 } 2230 fp3 = (I32(*)(int,int,int))CvXSUB(cv); 2231 items = (*fp3)(CvXSUBANY(cv).any_i32, 2232 mark - PL_stack_base + 1, 2233 items); 2234 SP = PL_stack_base + items; 2235 } 2236 else 2237 #endif /* PERL_XSUB_OLDSTYLE */ 2238 { 2239 SV **newsp; 2240 I32 gimme; 2241 2242 PL_stack_sp--; /* There is no cv arg. */ 2243 /* Push a mark for the start of arglist */ 2244 PUSHMARK(mark); 2245 (void)(*CvXSUB(cv))(aTHXo_ cv); 2246 /* Pop the current context like a decent sub should */ 2247 POPBLOCK(cx, PL_curpm); 2248 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */ 2249 } 2250 LEAVE; 2251 return pop_return(); 2252 } 2253 else { 2254 AV* padlist = CvPADLIST(cv); 2255 SV** svp = AvARRAY(padlist); 2256 if (CxTYPE(cx) == CXt_EVAL) { 2257 PL_in_eval = cx->blk_eval.old_in_eval; 2258 PL_eval_root = cx->blk_eval.old_eval_root; 2259 cx->cx_type = CXt_SUB; 2260 cx->blk_sub.hasargs = 0; 2261 } 2262 cx->blk_sub.cv = cv; 2263 cx->blk_sub.olddepth = CvDEPTH(cv); 2264 CvDEPTH(cv)++; 2265 if (CvDEPTH(cv) < 2) 2266 (void)SvREFCNT_inc(cv); 2267 else { /* save temporaries on recursion? */ 2268 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)) 2269 sub_crush_depth(cv); 2270 if (CvDEPTH(cv) > AvFILLp(padlist)) { 2271 AV *newpad = newAV(); 2272 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]); 2273 I32 ix = AvFILLp((AV*)svp[1]); 2274 I32 names_fill = AvFILLp((AV*)svp[0]); 2275 svp = AvARRAY(svp[0]); 2276 for ( ;ix > 0; ix--) { 2277 if (names_fill >= ix && svp[ix] != &PL_sv_undef) { 2278 char *name = SvPVX(svp[ix]); 2279 if ((SvFLAGS(svp[ix]) & SVf_FAKE) 2280 || *name == '&') 2281 { 2282 /* outer lexical or anon code */ 2283 av_store(newpad, ix, 2284 SvREFCNT_inc(oldpad[ix]) ); 2285 } 2286 else { /* our own lexical */ 2287 if (*name == '@') 2288 av_store(newpad, ix, sv = (SV*)newAV()); 2289 else if (*name == '%') 2290 av_store(newpad, ix, sv = (SV*)newHV()); 2291 else 2292 av_store(newpad, ix, sv = NEWSV(0,0)); 2293 SvPADMY_on(sv); 2294 } 2295 } 2296 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) { 2297 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix])); 2298 } 2299 else { 2300 av_store(newpad, ix, sv = NEWSV(0,0)); 2301 SvPADTMP_on(sv); 2302 } 2303 } 2304 if (cx->blk_sub.hasargs) { 2305 AV* av = newAV(); 2306 av_extend(av, 0); 2307 av_store(newpad, 0, (SV*)av); 2308 AvFLAGS(av) = AVf_REIFY; 2309 } 2310 av_store(padlist, CvDEPTH(cv), (SV*)newpad); 2311 AvFILLp(padlist) = CvDEPTH(cv); 2312 svp = AvARRAY(padlist); 2313 } 2314 } 2315 #ifdef USE_THREADS 2316 if (!cx->blk_sub.hasargs) { 2317 AV* av = (AV*)PL_curpad[0]; 2318 2319 items = AvFILLp(av) + 1; 2320 if (items) { 2321 /* Mark is at the end of the stack. */ 2322 EXTEND(SP, items); 2323 Copy(AvARRAY(av), SP + 1, items, SV*); 2324 SP += items; 2325 PUTBACK ; 2326 } 2327 } 2328 #endif /* USE_THREADS */ 2329 SAVEVPTR(PL_curpad); 2330 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]); 2331 #ifndef USE_THREADS 2332 if (cx->blk_sub.hasargs) 2333 #endif /* USE_THREADS */ 2334 { 2335 AV* av = (AV*)PL_curpad[0]; 2336 SV** ary; 2337 2338 #ifndef USE_THREADS 2339 cx->blk_sub.savearray = GvAV(PL_defgv); 2340 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av); 2341 #endif /* USE_THREADS */ 2342 cx->blk_sub.oldcurpad = PL_curpad; 2343 cx->blk_sub.argarray = av; 2344 ++mark; 2345 2346 if (items >= AvMAX(av) + 1) { 2347 ary = AvALLOC(av); 2348 if (AvARRAY(av) != ary) { 2349 AvMAX(av) += AvARRAY(av) - AvALLOC(av); 2350 SvPVX(av) = (char*)ary; 2351 } 2352 if (items >= AvMAX(av) + 1) { 2353 AvMAX(av) = items - 1; 2354 Renew(ary,items+1,SV*); 2355 AvALLOC(av) = ary; 2356 SvPVX(av) = (char*)ary; 2357 } 2358 } 2359 Copy(mark,AvARRAY(av),items,SV*); 2360 AvFILLp(av) = items - 1; 2361 assert(!AvREAL(av)); 2362 while (items--) { 2363 if (*mark) 2364 SvTEMP_off(*mark); 2365 mark++; 2366 } 2367 } 2368 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */ 2369 /* 2370 * We do not care about using sv to call CV; 2371 * it's for informational purposes only. 2372 */ 2373 SV *sv = GvSV(PL_DBsub); 2374 CV *gotocv; 2375 2376 if (PERLDB_SUB_NN) { 2377 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */ 2378 } else { 2379 save_item(sv); 2380 gv_efullname3(sv, CvGV(cv), Nullch); 2381 } 2382 if ( PERLDB_GOTO 2383 && (gotocv = get_cv("DB::goto", FALSE)) ) { 2384 PUSHMARK( PL_stack_sp ); 2385 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG); 2386 PL_stack_sp--; 2387 } 2388 } 2389 RETURNOP(CvSTART(cv)); 2390 } 2391 } 2392 else { 2393 label = SvPV(sv,n_a); 2394 if (!(do_dump || *label)) 2395 DIE(aTHX_ must_have_label); 2396 } 2397 } 2398 else if (PL_op->op_flags & OPf_SPECIAL) { 2399 if (! do_dump) 2400 DIE(aTHX_ must_have_label); 2401 } 2402 else 2403 label = cPVOP->op_pv; 2404 2405 if (label && *label) { 2406 OP *gotoprobe = 0; 2407 2408 /* find label */ 2409 2410 PL_lastgotoprobe = 0; 2411 *enterops = 0; 2412 for (ix = cxstack_ix; ix >= 0; ix--) { 2413 cx = &cxstack[ix]; 2414 switch (CxTYPE(cx)) { 2415 case CXt_EVAL: 2416 gotoprobe = PL_eval_root; /* XXX not good for nested eval */ 2417 break; 2418 case CXt_LOOP: 2419 gotoprobe = cx->blk_oldcop->op_sibling; 2420 break; 2421 case CXt_SUBST: 2422 continue; 2423 case CXt_BLOCK: 2424 if (ix) 2425 gotoprobe = cx->blk_oldcop->op_sibling; 2426 else 2427 gotoprobe = PL_main_root; 2428 break; 2429 case CXt_SUB: 2430 if (CvDEPTH(cx->blk_sub.cv)) { 2431 gotoprobe = CvROOT(cx->blk_sub.cv); 2432 break; 2433 } 2434 /* FALL THROUGH */ 2435 case CXt_FORMAT: 2436 case CXt_NULL: 2437 DIE(aTHX_ "Can't \"goto\" out of a pseudo block"); 2438 default: 2439 if (ix) 2440 DIE(aTHX_ "panic: goto"); 2441 gotoprobe = PL_main_root; 2442 break; 2443 } 2444 if (gotoprobe) { 2445 retop = dofindlabel(gotoprobe, label, 2446 enterops, enterops + GOTO_DEPTH); 2447 if (retop) 2448 break; 2449 } 2450 PL_lastgotoprobe = gotoprobe; 2451 } 2452 if (!retop) 2453 DIE(aTHX_ "Can't find label %s", label); 2454 2455 /* pop unwanted frames */ 2456 2457 if (ix < cxstack_ix) { 2458 I32 oldsave; 2459 2460 if (ix < 0) 2461 ix = 0; 2462 dounwind(ix); 2463 TOPBLOCK(cx); 2464 oldsave = PL_scopestack[PL_scopestack_ix]; 2465 LEAVE_SCOPE(oldsave); 2466 } 2467 2468 /* push wanted frames */ 2469 2470 if (*enterops && enterops[1]) { 2471 OP *oldop = PL_op; 2472 for (ix = 1; enterops[ix]; ix++) { 2473 PL_op = enterops[ix]; 2474 /* Eventually we may want to stack the needed arguments 2475 * for each op. For now, we punt on the hard ones. */ 2476 if (PL_op->op_type == OP_ENTERITER) 2477 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop"); 2478 CALL_FPTR(PL_op->op_ppaddr)(aTHX); 2479 } 2480 PL_op = oldop; 2481 } 2482 } 2483 2484 if (do_dump) { 2485 #ifdef VMS 2486 if (!retop) retop = PL_main_start; 2487 #endif 2488 PL_restartop = retop; 2489 PL_do_undump = TRUE; 2490 2491 my_unexec(); 2492 2493 PL_restartop = 0; /* hmm, must be GNU unexec().. */ 2494 PL_do_undump = FALSE; 2495 } 2496 2497 RETURNOP(retop); 2498 } 2499 2500 PP(pp_exit) 2501 { 2502 dSP; 2503 I32 anum; 2504 2505 if (MAXARG < 1) 2506 anum = 0; 2507 else { 2508 anum = SvIVx(POPs); 2509 #ifdef VMS 2510 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH)) 2511 anum = 0; 2512 #endif 2513 } 2514 PL_exit_flags |= PERL_EXIT_EXPECTED; 2515 my_exit(anum); 2516 PUSHs(&PL_sv_undef); 2517 RETURN; 2518 } 2519 2520 #ifdef NOTYET 2521 PP(pp_nswitch) 2522 { 2523 dSP; 2524 NV value = SvNVx(GvSV(cCOP->cop_gv)); 2525 register I32 match = I_32(value); 2526 2527 if (value < 0.0) { 2528 if (((NV)match) > value) 2529 --match; /* was fractional--truncate other way */ 2530 } 2531 match -= cCOP->uop.scop.scop_offset; 2532 if (match < 0) 2533 match = 0; 2534 else if (match > cCOP->uop.scop.scop_max) 2535 match = cCOP->uop.scop.scop_max; 2536 PL_op = cCOP->uop.scop.scop_next[match]; 2537 RETURNOP(PL_op); 2538 } 2539 2540 PP(pp_cswitch) 2541 { 2542 dSP; 2543 register I32 match; 2544 2545 if (PL_multiline) 2546 PL_op = PL_op->op_next; /* can't assume anything */ 2547 else { 2548 STRLEN n_a; 2549 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255; 2550 match -= cCOP->uop.scop.scop_offset; 2551 if (match < 0) 2552 match = 0; 2553 else if (match > cCOP->uop.scop.scop_max) 2554 match = cCOP->uop.scop.scop_max; 2555 PL_op = cCOP->uop.scop.scop_next[match]; 2556 } 2557 RETURNOP(PL_op); 2558 } 2559 #endif 2560 2561 /* Eval. */ 2562 2563 STATIC void 2564 S_save_lines(pTHX_ AV *array, SV *sv) 2565 { 2566 register char *s = SvPVX(sv); 2567 register char *send = SvPVX(sv) + SvCUR(sv); 2568 register char *t; 2569 register I32 line = 1; 2570 2571 while (s && s < send) { 2572 SV *tmpstr = NEWSV(85,0); 2573 2574 sv_upgrade(tmpstr, SVt_PVMG); 2575 t = strchr(s, '\n'); 2576 if (t) 2577 t++; 2578 else 2579 t = send; 2580 2581 sv_setpvn(tmpstr, s, t - s); 2582 av_store(array, line++, tmpstr); 2583 s = t; 2584 } 2585 } 2586 2587 #ifdef PERL_FLEXIBLE_EXCEPTIONS 2588 STATIC void * 2589 S_docatch_body(pTHX_ va_list args) 2590 { 2591 return docatch_body(); 2592 } 2593 #endif 2594 2595 STATIC void * 2596 S_docatch_body(pTHX) 2597 { 2598 CALLRUNOPS(aTHX); 2599 return NULL; 2600 } 2601 2602 STATIC OP * 2603 S_docatch(pTHX_ OP *o) 2604 { 2605 int ret; 2606 OP *oldop = PL_op; 2607 volatile PERL_SI *cursi = PL_curstackinfo; 2608 dJMPENV; 2609 2610 #ifdef DEBUGGING 2611 assert(CATCH_GET == TRUE); 2612 #endif 2613 PL_op = o; 2614 #ifdef PERL_FLEXIBLE_EXCEPTIONS 2615 redo_body: 2616 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body)); 2617 #else 2618 JMPENV_PUSH(ret); 2619 #endif 2620 switch (ret) { 2621 case 0: 2622 #ifndef PERL_FLEXIBLE_EXCEPTIONS 2623 redo_body: 2624 docatch_body(); 2625 #endif 2626 break; 2627 case 3: 2628 if (PL_restartop && cursi == PL_curstackinfo) { 2629 PL_op = PL_restartop; 2630 PL_restartop = 0; 2631 goto redo_body; 2632 } 2633 /* FALL THROUGH */ 2634 default: 2635 JMPENV_POP; 2636 PL_op = oldop; 2637 JMPENV_JUMP(ret); 2638 /* NOTREACHED */ 2639 } 2640 JMPENV_POP; 2641 PL_op = oldop; 2642 return Nullop; 2643 } 2644 2645 OP * 2646 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp) 2647 /* sv Text to convert to OP tree. */ 2648 /* startop op_free() this to undo. */ 2649 /* code Short string id of the caller. */ 2650 { 2651 dSP; /* Make POPBLOCK work. */ 2652 PERL_CONTEXT *cx; 2653 SV **newsp; 2654 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */ 2655 I32 optype; 2656 OP dummy; 2657 OP *rop; 2658 char tbuf[TYPE_DIGITS(long) + 12 + 10]; 2659 char *tmpbuf = tbuf; 2660 char *safestr; 2661 2662 ENTER; 2663 lex_start(sv); 2664 SAVETMPS; 2665 /* switch to eval mode */ 2666 2667 if (PL_curcop == &PL_compiling) { 2668 SAVECOPSTASH_FREE(&PL_compiling); 2669 CopSTASH_set(&PL_compiling, PL_curstash); 2670 } 2671 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) { 2672 SV *sv = sv_newmortal(); 2673 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]", 2674 code, (unsigned long)++PL_evalseq, 2675 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); 2676 tmpbuf = SvPVX(sv); 2677 } 2678 else 2679 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq); 2680 SAVECOPFILE_FREE(&PL_compiling); 2681 CopFILE_set(&PL_compiling, tmpbuf+2); 2682 SAVECOPLINE(&PL_compiling); 2683 CopLINE_set(&PL_compiling, 1); 2684 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up 2685 deleting the eval's FILEGV from the stash before gv_check() runs 2686 (i.e. before run-time proper). To work around the coredump that 2687 ensues, we always turn GvMULTI_on for any globals that were 2688 introduced within evals. See force_ident(). GSAR 96-10-12 */ 2689 safestr = savepv(tmpbuf); 2690 SAVEDELETE(PL_defstash, safestr, strlen(safestr)); 2691 SAVEHINTS(); 2692 #ifdef OP_IN_REGISTER 2693 PL_opsave = op; 2694 #else 2695 SAVEVPTR(PL_op); 2696 #endif 2697 PL_hints = 0; 2698 2699 PL_op = &dummy; 2700 PL_op->op_type = OP_ENTEREVAL; 2701 PL_op->op_flags = 0; /* Avoid uninit warning. */ 2702 PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP); 2703 PUSHEVAL(cx, 0, Nullgv); 2704 rop = doeval(G_SCALAR, startop); 2705 POPBLOCK(cx,PL_curpm); 2706 POPEVAL(cx); 2707 2708 (*startop)->op_type = OP_NULL; 2709 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL]; 2710 lex_end(); 2711 *avp = (AV*)SvREFCNT_inc(PL_comppad); 2712 LEAVE; 2713 if (PL_curcop == &PL_compiling) 2714 PL_compiling.op_private = PL_hints; 2715 #ifdef OP_IN_REGISTER 2716 op = PL_opsave; 2717 #endif 2718 return rop; 2719 } 2720 2721 /* With USE_THREADS, eval_owner must be held on entry to doeval */ 2722 STATIC OP * 2723 S_doeval(pTHX_ int gimme, OP** startop) 2724 { 2725 dSP; 2726 OP *saveop = PL_op; 2727 CV *caller; 2728 AV* comppadlist; 2729 I32 i; 2730 2731 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE) 2732 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL)) 2733 : EVAL_INEVAL); 2734 2735 PUSHMARK(SP); 2736 2737 /* set up a scratch pad */ 2738 2739 SAVEI32(PL_padix); 2740 SAVEVPTR(PL_curpad); 2741 SAVESPTR(PL_comppad); 2742 SAVESPTR(PL_comppad_name); 2743 SAVEI32(PL_comppad_name_fill); 2744 SAVEI32(PL_min_intro_pending); 2745 SAVEI32(PL_max_intro_pending); 2746 2747 caller = PL_compcv; 2748 for (i = cxstack_ix - 1; i >= 0; i--) { 2749 PERL_CONTEXT *cx = &cxstack[i]; 2750 if (CxTYPE(cx) == CXt_EVAL) 2751 break; 2752 else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { 2753 caller = cx->blk_sub.cv; 2754 break; 2755 } 2756 } 2757 2758 SAVESPTR(PL_compcv); 2759 PL_compcv = (CV*)NEWSV(1104,0); 2760 sv_upgrade((SV *)PL_compcv, SVt_PVCV); 2761 CvEVAL_on(PL_compcv); 2762 #ifdef USE_THREADS 2763 CvOWNER(PL_compcv) = 0; 2764 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex); 2765 MUTEX_INIT(CvMUTEXP(PL_compcv)); 2766 #endif /* USE_THREADS */ 2767 2768 PL_comppad = newAV(); 2769 av_push(PL_comppad, Nullsv); 2770 PL_curpad = AvARRAY(PL_comppad); 2771 PL_comppad_name = newAV(); 2772 PL_comppad_name_fill = 0; 2773 PL_min_intro_pending = 0; 2774 PL_padix = 0; 2775 #ifdef USE_THREADS 2776 av_store(PL_comppad_name, 0, newSVpvn("@_", 2)); 2777 PL_curpad[0] = (SV*)newAV(); 2778 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */ 2779 #endif /* USE_THREADS */ 2780 2781 comppadlist = newAV(); 2782 AvREAL_off(comppadlist); 2783 av_store(comppadlist, 0, (SV*)PL_comppad_name); 2784 av_store(comppadlist, 1, (SV*)PL_comppad); 2785 CvPADLIST(PL_compcv) = comppadlist; 2786 2787 if (!saveop || 2788 (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE)) 2789 { 2790 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller); 2791 } 2792 2793 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */ 2794 2795 /* make sure we compile in the right package */ 2796 2797 if (CopSTASH_ne(PL_curcop, PL_curstash)) { 2798 SAVESPTR(PL_curstash); 2799 PL_curstash = CopSTASH(PL_curcop); 2800 } 2801 SAVESPTR(PL_beginav); 2802 PL_beginav = newAV(); 2803 SAVEFREESV(PL_beginav); 2804 SAVEI32(PL_error_count); 2805 2806 /* try to compile it */ 2807 2808 PL_eval_root = Nullop; 2809 PL_error_count = 0; 2810 PL_curcop = &PL_compiling; 2811 PL_curcop->cop_arybase = 0; 2812 SvREFCNT_dec(PL_rs); 2813 PL_rs = newSVpvn("\n", 1); 2814 if (saveop && saveop->op_flags & OPf_SPECIAL) 2815 PL_in_eval |= EVAL_KEEPERR; 2816 else 2817 sv_setpv(ERRSV,""); 2818 if (yyparse() || PL_error_count || !PL_eval_root) { 2819 SV **newsp; 2820 I32 gimme; 2821 PERL_CONTEXT *cx; 2822 I32 optype = 0; /* Might be reset by POPEVAL. */ 2823 STRLEN n_a; 2824 2825 PL_op = saveop; 2826 if (PL_eval_root) { 2827 op_free(PL_eval_root); 2828 PL_eval_root = Nullop; 2829 } 2830 SP = PL_stack_base + POPMARK; /* pop original mark */ 2831 if (!startop) { 2832 POPBLOCK(cx,PL_curpm); 2833 POPEVAL(cx); 2834 pop_return(); 2835 } 2836 lex_end(); 2837 LEAVE; 2838 if (optype == OP_REQUIRE) { 2839 char* msg = SvPVx(ERRSV, n_a); 2840 DIE(aTHX_ "%sCompilation failed in require", 2841 *msg ? msg : "Unknown error\n"); 2842 } 2843 else if (startop) { 2844 char* msg = SvPVx(ERRSV, n_a); 2845 2846 POPBLOCK(cx,PL_curpm); 2847 POPEVAL(cx); 2848 Perl_croak(aTHX_ "%sCompilation failed in regexp", 2849 (*msg ? msg : "Unknown error\n")); 2850 } 2851 SvREFCNT_dec(PL_rs); 2852 PL_rs = SvREFCNT_inc(PL_nrs); 2853 #ifdef USE_THREADS 2854 MUTEX_LOCK(&PL_eval_mutex); 2855 PL_eval_owner = 0; 2856 COND_SIGNAL(&PL_eval_cond); 2857 MUTEX_UNLOCK(&PL_eval_mutex); 2858 #endif /* USE_THREADS */ 2859 RETPUSHUNDEF; 2860 } 2861 SvREFCNT_dec(PL_rs); 2862 PL_rs = SvREFCNT_inc(PL_nrs); 2863 CopLINE_set(&PL_compiling, 0); 2864 if (startop) { 2865 *startop = PL_eval_root; 2866 SvREFCNT_dec(CvOUTSIDE(PL_compcv)); 2867 CvOUTSIDE(PL_compcv) = Nullcv; 2868 } else 2869 SAVEFREEOP(PL_eval_root); 2870 if (gimme & G_VOID) 2871 scalarvoid(PL_eval_root); 2872 else if (gimme & G_ARRAY) 2873 list(PL_eval_root); 2874 else 2875 scalar(PL_eval_root); 2876 2877 DEBUG_x(dump_eval()); 2878 2879 /* Register with debugger: */ 2880 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) { 2881 CV *cv = get_cv("DB::postponed", FALSE); 2882 if (cv) { 2883 dSP; 2884 PUSHMARK(SP); 2885 XPUSHs((SV*)CopFILEGV(&PL_compiling)); 2886 PUTBACK; 2887 call_sv((SV*)cv, G_DISCARD); 2888 } 2889 } 2890 2891 /* compiled okay, so do it */ 2892 2893 CvDEPTH(PL_compcv) = 1; 2894 SP = PL_stack_base + POPMARK; /* pop original mark */ 2895 PL_op = saveop; /* The caller may need it. */ 2896 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */ 2897 #ifdef USE_THREADS 2898 MUTEX_LOCK(&PL_eval_mutex); 2899 PL_eval_owner = 0; 2900 COND_SIGNAL(&PL_eval_cond); 2901 MUTEX_UNLOCK(&PL_eval_mutex); 2902 #endif /* USE_THREADS */ 2903 2904 RETURNOP(PL_eval_start); 2905 } 2906 2907 STATIC PerlIO * 2908 S_doopen_pmc(pTHX_ const char *name, const char *mode) 2909 { 2910 STRLEN namelen = strlen(name); 2911 PerlIO *fp; 2912 2913 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) { 2914 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c'); 2915 char *pmc = SvPV_nolen(pmcsv); 2916 Stat_t pmstat; 2917 Stat_t pmcstat; 2918 if (PerlLIO_stat(pmc, &pmcstat) < 0) { 2919 fp = PerlIO_open(name, mode); 2920 } 2921 else { 2922 if (PerlLIO_stat(name, &pmstat) < 0 || 2923 pmstat.st_mtime < pmcstat.st_mtime) 2924 { 2925 fp = PerlIO_open(pmc, mode); 2926 } 2927 else { 2928 fp = PerlIO_open(name, mode); 2929 } 2930 } 2931 SvREFCNT_dec(pmcsv); 2932 } 2933 else { 2934 fp = PerlIO_open(name, mode); 2935 } 2936 return fp; 2937 } 2938 2939 PP(pp_require) 2940 { 2941 dSP; 2942 register PERL_CONTEXT *cx; 2943 SV *sv; 2944 char *name; 2945 STRLEN len; 2946 char *tryname; 2947 SV *namesv = Nullsv; 2948 SV** svp; 2949 I32 gimme = G_SCALAR; 2950 PerlIO *tryrsfp = 0; 2951 STRLEN n_a; 2952 int filter_has_file = 0; 2953 GV *filter_child_proc = 0; 2954 SV *filter_state = 0; 2955 SV *filter_sub = 0; 2956 2957 sv = POPs; 2958 if (SvNIOKp(sv)) { 2959 if (SvPOK(sv) && SvNOK(sv)) { /* require v5.6.1 */ 2960 UV rev = 0, ver = 0, sver = 0; 2961 STRLEN len; 2962 U8 *s = (U8*)SvPVX(sv); 2963 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv); 2964 if (s < end) { 2965 rev = utf8_to_uv(s, end - s, &len, 0); 2966 s += len; 2967 if (s < end) { 2968 ver = utf8_to_uv(s, end - s, &len, 0); 2969 s += len; 2970 if (s < end) 2971 sver = utf8_to_uv(s, end - s, &len, 0); 2972 } 2973 } 2974 if (PERL_REVISION < rev 2975 || (PERL_REVISION == rev 2976 && (PERL_VERSION < ver 2977 || (PERL_VERSION == ver 2978 && PERL_SUBVERSION < sver)))) 2979 { 2980 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only " 2981 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION, 2982 PERL_VERSION, PERL_SUBVERSION); 2983 } 2984 RETPUSHYES; 2985 } 2986 else if (!SvPOKp(sv)) { /* require 5.005_03 */ 2987 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000) 2988 + ((NV)PERL_SUBVERSION/(NV)1000000) 2989 + 0.00000099 < SvNV(sv)) 2990 { 2991 NV nrev = SvNV(sv); 2992 UV rev = (UV)nrev; 2993 NV nver = (nrev - rev) * 1000; 2994 UV ver = (UV)(nver + 0.0009); 2995 NV nsver = (nver - ver) * 1000; 2996 UV sver = (UV)(nsver + 0.0009); 2997 2998 /* help out with the "use 5.6" confusion */ 2999 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) { 3000 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--" 3001 "this is only v%d.%d.%d, stopped" 3002 " (did you mean v%"UVuf".%"UVuf".0?)", 3003 rev, ver, sver, PERL_REVISION, PERL_VERSION, 3004 PERL_SUBVERSION, rev, ver/100); 3005 } 3006 else { 3007 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--" 3008 "this is only v%d.%d.%d, stopped", 3009 rev, ver, sver, PERL_REVISION, PERL_VERSION, 3010 PERL_SUBVERSION); 3011 } 3012 } 3013 RETPUSHYES; 3014 } 3015 } 3016 name = SvPV(sv, len); 3017 if (!(name && len > 0 && *name)) 3018 DIE(aTHX_ "Null filename used"); 3019 TAINT_PROPER("require"); 3020 if (PL_op->op_type == OP_REQUIRE && 3021 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) && 3022 *svp != &PL_sv_undef) 3023 RETPUSHYES; 3024 3025 /* prepare to compile file */ 3026 3027 #ifdef MACOS_TRADITIONAL 3028 if (PERL_FILE_IS_ABSOLUTE(name) 3029 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))) 3030 { 3031 tryname = name; 3032 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE); 3033 /* We consider paths of the form :a:b ambiguous and interpret them first 3034 as global then as local 3035 */ 3036 if (!tryrsfp && *name == ':' && name[1] != ':' && strchr(name+2, ':')) 3037 goto trylocal; 3038 } 3039 else 3040 trylocal: { 3041 #else 3042 if (PERL_FILE_IS_ABSOLUTE(name) 3043 || (*name == '.' && (name[1] == '/' || 3044 (name[1] == '.' && name[2] == '/')))) 3045 { 3046 tryname = name; 3047 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE); 3048 } 3049 else { 3050 #endif 3051 AV *ar = GvAVn(PL_incgv); 3052 I32 i; 3053 #ifdef VMS 3054 char *unixname; 3055 if ((unixname = tounixspec(name, Nullch)) != Nullch) 3056 #endif 3057 { 3058 namesv = NEWSV(806, 0); 3059 for (i = 0; i <= AvFILL(ar); i++) { 3060 SV *dirsv = *av_fetch(ar, i, TRUE); 3061 3062 if (SvROK(dirsv)) { 3063 int count; 3064 SV *loader = dirsv; 3065 3066 if (SvTYPE(SvRV(loader)) == SVt_PVAV) { 3067 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE); 3068 } 3069 3070 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s", 3071 PTR2UV(SvANY(loader)), name); 3072 tryname = SvPVX(namesv); 3073 tryrsfp = 0; 3074 3075 ENTER; 3076 SAVETMPS; 3077 EXTEND(SP, 2); 3078 3079 PUSHMARK(SP); 3080 PUSHs(dirsv); 3081 PUSHs(sv); 3082 PUTBACK; 3083 if (sv_isobject(loader)) 3084 count = call_method("INC", G_ARRAY); 3085 else 3086 count = call_sv(loader, G_ARRAY); 3087 SPAGAIN; 3088 3089 if (count > 0) { 3090 int i = 0; 3091 SV *arg; 3092 3093 SP -= count - 1; 3094 arg = SP[i++]; 3095 3096 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) { 3097 arg = SvRV(arg); 3098 } 3099 3100 if (SvTYPE(arg) == SVt_PVGV) { 3101 IO *io = GvIO((GV *)arg); 3102 3103 ++filter_has_file; 3104 3105 if (io) { 3106 tryrsfp = IoIFP(io); 3107 if (IoTYPE(io) == IoTYPE_PIPE) { 3108 /* reading from a child process doesn't 3109 nest -- when returning from reading 3110 the inner module, the outer one is 3111 unreadable (closed?) I've tried to 3112 save the gv to manage the lifespan of 3113 the pipe, but this didn't help. XXX */ 3114 filter_child_proc = (GV *)arg; 3115 (void)SvREFCNT_inc(filter_child_proc); 3116 } 3117 else { 3118 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { 3119 PerlIO_close(IoOFP(io)); 3120 } 3121 IoIFP(io) = Nullfp; 3122 IoOFP(io) = Nullfp; 3123 } 3124 } 3125 3126 if (i < count) { 3127 arg = SP[i++]; 3128 } 3129 } 3130 3131 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) { 3132 filter_sub = arg; 3133 (void)SvREFCNT_inc(filter_sub); 3134 3135 if (i < count) { 3136 filter_state = SP[i]; 3137 (void)SvREFCNT_inc(filter_state); 3138 } 3139 3140 if (tryrsfp == 0) { 3141 tryrsfp = PerlIO_open("/dev/null", 3142 PERL_SCRIPT_MODE); 3143 } 3144 } 3145 } 3146 3147 PUTBACK; 3148 FREETMPS; 3149 LEAVE; 3150 3151 if (tryrsfp) { 3152 break; 3153 } 3154 3155 filter_has_file = 0; 3156 if (filter_child_proc) { 3157 SvREFCNT_dec(filter_child_proc); 3158 filter_child_proc = 0; 3159 } 3160 if (filter_state) { 3161 SvREFCNT_dec(filter_state); 3162 filter_state = 0; 3163 } 3164 if (filter_sub) { 3165 SvREFCNT_dec(filter_sub); 3166 filter_sub = 0; 3167 } 3168 } 3169 else { 3170 char *dir = SvPVx(dirsv, n_a); 3171 #ifdef MACOS_TRADITIONAL 3172 char buf[256]; 3173 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf), name+(name[0] == ':')); 3174 #else 3175 #ifdef VMS 3176 char *unixdir; 3177 if ((unixdir = tounixpath(dir, Nullch)) == Nullch) 3178 continue; 3179 sv_setpv(namesv, unixdir); 3180 sv_catpv(namesv, unixname); 3181 #else 3182 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name); 3183 #endif 3184 #endif 3185 TAINT_PROPER("require"); 3186 tryname = SvPVX(namesv); 3187 #ifdef MACOS_TRADITIONAL 3188 { 3189 /* Convert slashes in the name part, but not the directory part, to colons */ 3190 char * colon; 3191 for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); ) 3192 *colon++ = ':'; 3193 } 3194 #endif 3195 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE); 3196 if (tryrsfp) { 3197 if (tryname[0] == '.' && tryname[1] == '/') 3198 tryname += 2; 3199 break; 3200 } 3201 } 3202 } 3203 } 3204 } 3205 SAVECOPFILE_FREE(&PL_compiling); 3206 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name); 3207 SvREFCNT_dec(namesv); 3208 if (!tryrsfp) { 3209 if (PL_op->op_type == OP_REQUIRE) { 3210 char *msgstr = name; 3211 if (namesv) { /* did we lookup @INC? */ 3212 SV *msg = sv_2mortal(newSVpv(msgstr,0)); 3213 SV *dirmsgsv = NEWSV(0, 0); 3214 AV *ar = GvAVn(PL_incgv); 3215 I32 i; 3216 sv_catpvn(msg, " in @INC", 8); 3217 if (instr(SvPVX(msg), ".h ")) 3218 sv_catpv(msg, " (change .h to .ph maybe?)"); 3219 if (instr(SvPVX(msg), ".ph ")) 3220 sv_catpv(msg, " (did you run h2ph?)"); 3221 sv_catpv(msg, " (@INC contains:"); 3222 for (i = 0; i <= AvFILL(ar); i++) { 3223 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a); 3224 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir); 3225 sv_catsv(msg, dirmsgsv); 3226 } 3227 sv_catpvn(msg, ")", 1); 3228 SvREFCNT_dec(dirmsgsv); 3229 msgstr = SvPV_nolen(msg); 3230 } 3231 DIE(aTHX_ "Can't locate %s", msgstr); 3232 } 3233 3234 RETPUSHUNDEF; 3235 } 3236 else 3237 SETERRNO(0, SS$_NORMAL); 3238 3239 /* Assume success here to prevent recursive requirement. */ 3240 (void)hv_store(GvHVn(PL_incgv), name, strlen(name), 3241 newSVpv(CopFILE(&PL_compiling), 0), 0 ); 3242 3243 ENTER; 3244 SAVETMPS; 3245 lex_start(sv_2mortal(newSVpvn("",0))); 3246 SAVEGENERICSV(PL_rsfp_filters); 3247 PL_rsfp_filters = Nullav; 3248 3249 PL_rsfp = tryrsfp; 3250 SAVEHINTS(); 3251 PL_hints = 0; 3252 SAVESPTR(PL_compiling.cop_warnings); 3253 if (PL_dowarn & G_WARN_ALL_ON) 3254 PL_compiling.cop_warnings = pWARN_ALL ; 3255 else if (PL_dowarn & G_WARN_ALL_OFF) 3256 PL_compiling.cop_warnings = pWARN_NONE ; 3257 else 3258 PL_compiling.cop_warnings = pWARN_STD ; 3259 3260 if (filter_sub || filter_child_proc) { 3261 SV *datasv = filter_add(run_user_filter, Nullsv); 3262 IoLINES(datasv) = filter_has_file; 3263 IoFMT_GV(datasv) = (GV *)filter_child_proc; 3264 IoTOP_GV(datasv) = (GV *)filter_state; 3265 IoBOTTOM_GV(datasv) = (GV *)filter_sub; 3266 } 3267 3268 /* switch to eval mode */ 3269 push_return(PL_op->op_next); 3270 PUSHBLOCK(cx, CXt_EVAL, SP); 3271 PUSHEVAL(cx, name, Nullgv); 3272 3273 SAVECOPLINE(&PL_compiling); 3274 CopLINE_set(&PL_compiling, 0); 3275 3276 PUTBACK; 3277 #ifdef USE_THREADS 3278 MUTEX_LOCK(&PL_eval_mutex); 3279 if (PL_eval_owner && PL_eval_owner != thr) 3280 while (PL_eval_owner) 3281 COND_WAIT(&PL_eval_cond, &PL_eval_mutex); 3282 PL_eval_owner = thr; 3283 MUTEX_UNLOCK(&PL_eval_mutex); 3284 #endif /* USE_THREADS */ 3285 return DOCATCH(doeval(G_SCALAR, NULL)); 3286 } 3287 3288 PP(pp_dofile) 3289 { 3290 return pp_require(); 3291 } 3292 3293 PP(pp_entereval) 3294 { 3295 dSP; 3296 register PERL_CONTEXT *cx; 3297 dPOPss; 3298 I32 gimme = GIMME_V, was = PL_sub_generation; 3299 char tbuf[TYPE_DIGITS(long) + 12]; 3300 char *tmpbuf = tbuf; 3301 char *safestr; 3302 STRLEN len; 3303 OP *ret; 3304 3305 if (!SvPV(sv,len) || !len) 3306 RETPUSHUNDEF; 3307 TAINT_PROPER("eval"); 3308 3309 ENTER; 3310 lex_start(sv); 3311 SAVETMPS; 3312 3313 /* switch to eval mode */ 3314 3315 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) { 3316 SV *sv = sv_newmortal(); 3317 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]", 3318 (unsigned long)++PL_evalseq, 3319 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); 3320 tmpbuf = SvPVX(sv); 3321 } 3322 else 3323 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq); 3324 SAVECOPFILE_FREE(&PL_compiling); 3325 CopFILE_set(&PL_compiling, tmpbuf+2); 3326 SAVECOPLINE(&PL_compiling); 3327 CopLINE_set(&PL_compiling, 1); 3328 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up 3329 deleting the eval's FILEGV from the stash before gv_check() runs 3330 (i.e. before run-time proper). To work around the coredump that 3331 ensues, we always turn GvMULTI_on for any globals that were 3332 introduced within evals. See force_ident(). GSAR 96-10-12 */ 3333 safestr = savepv(tmpbuf); 3334 SAVEDELETE(PL_defstash, safestr, strlen(safestr)); 3335 SAVEHINTS(); 3336 PL_hints = PL_op->op_targ; 3337 SAVESPTR(PL_compiling.cop_warnings); 3338 if (specialWARN(PL_curcop->cop_warnings)) 3339 PL_compiling.cop_warnings = PL_curcop->cop_warnings; 3340 else { 3341 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings); 3342 SAVEFREESV(PL_compiling.cop_warnings); 3343 } 3344 3345 push_return(PL_op->op_next); 3346 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP); 3347 PUSHEVAL(cx, 0, Nullgv); 3348 3349 /* prepare to compile string */ 3350 3351 if (PERLDB_LINE && PL_curstash != PL_debstash) 3352 save_lines(CopFILEAV(&PL_compiling), PL_linestr); 3353 PUTBACK; 3354 #ifdef USE_THREADS 3355 MUTEX_LOCK(&PL_eval_mutex); 3356 if (PL_eval_owner && PL_eval_owner != thr) 3357 while (PL_eval_owner) 3358 COND_WAIT(&PL_eval_cond, &PL_eval_mutex); 3359 PL_eval_owner = thr; 3360 MUTEX_UNLOCK(&PL_eval_mutex); 3361 #endif /* USE_THREADS */ 3362 ret = doeval(gimme, NULL); 3363 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */ 3364 && ret != PL_op->op_next) { /* Successive compilation. */ 3365 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */ 3366 } 3367 return DOCATCH(ret); 3368 } 3369 3370 PP(pp_leaveeval) 3371 { 3372 dSP; 3373 register SV **mark; 3374 SV **newsp; 3375 PMOP *newpm; 3376 I32 gimme; 3377 register PERL_CONTEXT *cx; 3378 OP *retop; 3379 U8 save_flags = PL_op -> op_flags; 3380 I32 optype; 3381 3382 POPBLOCK(cx,newpm); 3383 POPEVAL(cx); 3384 retop = pop_return(); 3385 3386 TAINT_NOT; 3387 if (gimme == G_VOID) 3388 MARK = newsp; 3389 else if (gimme == G_SCALAR) { 3390 MARK = newsp + 1; 3391 if (MARK <= SP) { 3392 if (SvFLAGS(TOPs) & SVs_TEMP) 3393 *MARK = TOPs; 3394 else 3395 *MARK = sv_mortalcopy(TOPs); 3396 } 3397 else { 3398 MEXTEND(mark,0); 3399 *MARK = &PL_sv_undef; 3400 } 3401 SP = MARK; 3402 } 3403 else { 3404 /* in case LEAVE wipes old return values */ 3405 for (mark = newsp + 1; mark <= SP; mark++) { 3406 if (!(SvFLAGS(*mark) & SVs_TEMP)) { 3407 *mark = sv_mortalcopy(*mark); 3408 TAINT_NOT; /* Each item is independent */ 3409 } 3410 } 3411 } 3412 PL_curpm = newpm; /* Don't pop $1 et al till now */ 3413 3414 #ifdef DEBUGGING 3415 assert(CvDEPTH(PL_compcv) == 1); 3416 #endif 3417 CvDEPTH(PL_compcv) = 0; 3418 lex_end(); 3419 3420 if (optype == OP_REQUIRE && 3421 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp)) 3422 { 3423 /* Unassume the success we assumed earlier. */ 3424 SV *nsv = cx->blk_eval.old_namesv; 3425 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD); 3426 retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv)); 3427 /* die_where() did LEAVE, or we won't be here */ 3428 } 3429 else { 3430 LEAVE; 3431 if (!(save_flags & OPf_SPECIAL)) 3432 sv_setpv(ERRSV,""); 3433 } 3434 3435 RETURNOP(retop); 3436 } 3437 3438 PP(pp_entertry) 3439 { 3440 dSP; 3441 register PERL_CONTEXT *cx; 3442 I32 gimme = GIMME_V; 3443 3444 ENTER; 3445 SAVETMPS; 3446 3447 push_return(cLOGOP->op_other->op_next); 3448 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP); 3449 PUSHEVAL(cx, 0, 0); 3450 PL_eval_root = PL_op; /* Only needed so that goto works right. */ 3451 3452 PL_in_eval = EVAL_INEVAL; 3453 sv_setpv(ERRSV,""); 3454 PUTBACK; 3455 return DOCATCH(PL_op->op_next); 3456 } 3457 3458 PP(pp_leavetry) 3459 { 3460 dSP; 3461 register SV **mark; 3462 SV **newsp; 3463 PMOP *newpm; 3464 I32 gimme; 3465 register PERL_CONTEXT *cx; 3466 I32 optype; 3467 3468 POPBLOCK(cx,newpm); 3469 POPEVAL(cx); 3470 pop_return(); 3471 3472 TAINT_NOT; 3473 if (gimme == G_VOID) 3474 SP = newsp; 3475 else if (gimme == G_SCALAR) { 3476 MARK = newsp + 1; 3477 if (MARK <= SP) { 3478 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP)) 3479 *MARK = TOPs; 3480 else 3481 *MARK = sv_mortalcopy(TOPs); 3482 } 3483 else { 3484 MEXTEND(mark,0); 3485 *MARK = &PL_sv_undef; 3486 } 3487 SP = MARK; 3488 } 3489 else { 3490 /* in case LEAVE wipes old return values */ 3491 for (mark = newsp + 1; mark <= SP; mark++) { 3492 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) { 3493 *mark = sv_mortalcopy(*mark); 3494 TAINT_NOT; /* Each item is independent */ 3495 } 3496 } 3497 } 3498 PL_curpm = newpm; /* Don't pop $1 et al till now */ 3499 3500 LEAVE; 3501 sv_setpv(ERRSV,""); 3502 RETURN; 3503 } 3504 3505 STATIC void 3506 S_doparseform(pTHX_ SV *sv) 3507 { 3508 STRLEN len; 3509 register char *s = SvPV_force(sv, len); 3510 register char *send = s + len; 3511 register char *base; 3512 register I32 skipspaces = 0; 3513 bool noblank; 3514 bool repeat; 3515 bool postspace = FALSE; 3516 U16 *fops; 3517 register U16 *fpc; 3518 U16 *linepc; 3519 register I32 arg; 3520 bool ischop; 3521 3522 if (len == 0) 3523 Perl_croak(aTHX_ "Null picture in formline"); 3524 3525 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */ 3526 fpc = fops; 3527 3528 if (s < send) { 3529 linepc = fpc; 3530 *fpc++ = FF_LINEMARK; 3531 noblank = repeat = FALSE; 3532 base = s; 3533 } 3534 3535 while (s <= send) { 3536 switch (*s++) { 3537 default: 3538 skipspaces = 0; 3539 continue; 3540 3541 case '~': 3542 if (*s == '~') { 3543 repeat = TRUE; 3544 *s = ' '; 3545 } 3546 noblank = TRUE; 3547 s[-1] = ' '; 3548 /* FALL THROUGH */ 3549 case ' ': case '\t': 3550 skipspaces++; 3551 continue; 3552 3553 case '\n': case 0: 3554 arg = s - base; 3555 skipspaces++; 3556 arg -= skipspaces; 3557 if (arg) { 3558 if (postspace) 3559 *fpc++ = FF_SPACE; 3560 *fpc++ = FF_LITERAL; 3561 *fpc++ = arg; 3562 } 3563 postspace = FALSE; 3564 if (s <= send) 3565 skipspaces--; 3566 if (skipspaces) { 3567 *fpc++ = FF_SKIP; 3568 *fpc++ = skipspaces; 3569 } 3570 skipspaces = 0; 3571 if (s <= send) 3572 *fpc++ = FF_NEWLINE; 3573 if (noblank) { 3574 *fpc++ = FF_BLANK; 3575 if (repeat) 3576 arg = fpc - linepc + 1; 3577 else 3578 arg = 0; 3579 *fpc++ = arg; 3580 } 3581 if (s < send) { 3582 linepc = fpc; 3583 *fpc++ = FF_LINEMARK; 3584 noblank = repeat = FALSE; 3585 base = s; 3586 } 3587 else 3588 s++; 3589 continue; 3590 3591 case '@': 3592 case '^': 3593 ischop = s[-1] == '^'; 3594 3595 if (postspace) { 3596 *fpc++ = FF_SPACE; 3597 postspace = FALSE; 3598 } 3599 arg = (s - base) - 1; 3600 if (arg) { 3601 *fpc++ = FF_LITERAL; 3602 *fpc++ = arg; 3603 } 3604 3605 base = s - 1; 3606 *fpc++ = FF_FETCH; 3607 if (*s == '*') { 3608 s++; 3609 *fpc++ = 0; 3610 *fpc++ = FF_LINEGLOB; 3611 } 3612 else if (*s == '#' || (*s == '.' && s[1] == '#')) { 3613 arg = ischop ? 512 : 0; 3614 base = s - 1; 3615 while (*s == '#') 3616 s++; 3617 if (*s == '.') { 3618 char *f; 3619 s++; 3620 f = s; 3621 while (*s == '#') 3622 s++; 3623 arg |= 256 + (s - f); 3624 } 3625 *fpc++ = s - base; /* fieldsize for FETCH */ 3626 *fpc++ = FF_DECIMAL; 3627 *fpc++ = arg; 3628 } 3629 else { 3630 I32 prespace = 0; 3631 bool ismore = FALSE; 3632 3633 if (*s == '>') { 3634 while (*++s == '>') ; 3635 prespace = FF_SPACE; 3636 } 3637 else if (*s == '|') { 3638 while (*++s == '|') ; 3639 prespace = FF_HALFSPACE; 3640 postspace = TRUE; 3641 } 3642 else { 3643 if (*s == '<') 3644 while (*++s == '<') ; 3645 postspace = TRUE; 3646 } 3647 if (*s == '.' && s[1] == '.' && s[2] == '.') { 3648 s += 3; 3649 ismore = TRUE; 3650 } 3651 *fpc++ = s - base; /* fieldsize for FETCH */ 3652 3653 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL; 3654 3655 if (prespace) 3656 *fpc++ = prespace; 3657 *fpc++ = FF_ITEM; 3658 if (ismore) 3659 *fpc++ = FF_MORE; 3660 if (ischop) 3661 *fpc++ = FF_CHOP; 3662 } 3663 base = s; 3664 skipspaces = 0; 3665 continue; 3666 } 3667 } 3668 *fpc++ = FF_END; 3669 3670 arg = fpc - fops; 3671 { /* need to jump to the next word */ 3672 int z; 3673 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN; 3674 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4); 3675 s = SvPVX(sv) + SvCUR(sv) + z; 3676 } 3677 Copy(fops, s, arg, U16); 3678 Safefree(fops); 3679 sv_magic(sv, Nullsv, 'f', Nullch, 0); 3680 SvCOMPILED_on(sv); 3681 } 3682 3683 /* 3684 * The rest of this file was derived from source code contributed 3685 * by Tom Horsley. 3686 * 3687 * NOTE: this code was derived from Tom Horsley's qsort replacement 3688 * and should not be confused with the original code. 3689 */ 3690 3691 /* Copyright (C) Tom Horsley, 1997. All rights reserved. 3692 3693 Permission granted to distribute under the same terms as perl which are 3694 (briefly): 3695 3696 This program is free software; you can redistribute it and/or modify 3697 it under the terms of either: 3698 3699 a) the GNU General Public License as published by the Free 3700 Software Foundation; either version 1, or (at your option) any 3701 later version, or 3702 3703 b) the "Artistic License" which comes with this Kit. 3704 3705 Details on the perl license can be found in the perl source code which 3706 may be located via the www.perl.com web page. 3707 3708 This is the most wonderfulest possible qsort I can come up with (and 3709 still be mostly portable) My (limited) tests indicate it consistently 3710 does about 20% fewer calls to compare than does the qsort in the Visual 3711 C++ library, other vendors may vary. 3712 3713 Some of the ideas in here can be found in "Algorithms" by Sedgewick, 3714 others I invented myself (or more likely re-invented since they seemed 3715 pretty obvious once I watched the algorithm operate for a while). 3716 3717 Most of this code was written while watching the Marlins sweep the Giants 3718 in the 1997 National League Playoffs - no Braves fans allowed to use this 3719 code (just kidding :-). 3720 3721 I realize that if I wanted to be true to the perl tradition, the only 3722 comment in this file would be something like: 3723 3724 ...they shuffled back towards the rear of the line. 'No, not at the 3725 rear!' the slave-driver shouted. 'Three files up. And stay there... 3726 3727 However, I really needed to violate that tradition just so I could keep 3728 track of what happens myself, not to mention some poor fool trying to 3729 understand this years from now :-). 3730 */ 3731 3732 /* ********************************************************** Configuration */ 3733 3734 #ifndef QSORT_ORDER_GUESS 3735 #define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */ 3736 #endif 3737 3738 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for 3739 future processing - a good max upper bound is log base 2 of memory size 3740 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can 3741 safely be smaller than that since the program is taking up some space and 3742 most operating systems only let you grab some subset of contiguous 3743 memory (not to mention that you are normally sorting data larger than 3744 1 byte element size :-). 3745 */ 3746 #ifndef QSORT_MAX_STACK 3747 #define QSORT_MAX_STACK 32 3748 #endif 3749 3750 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort. 3751 Anything bigger and we use qsort. If you make this too small, the qsort 3752 will probably break (or become less efficient), because it doesn't expect 3753 the middle element of a partition to be the same as the right or left - 3754 you have been warned). 3755 */ 3756 #ifndef QSORT_BREAK_EVEN 3757 #define QSORT_BREAK_EVEN 6 3758 #endif 3759 3760 /* ************************************************************* Data Types */ 3761 3762 /* hold left and right index values of a partition waiting to be sorted (the 3763 partition includes both left and right - right is NOT one past the end or 3764 anything like that). 3765 */ 3766 struct partition_stack_entry { 3767 int left; 3768 int right; 3769 #ifdef QSORT_ORDER_GUESS 3770 int qsort_break_even; 3771 #endif 3772 }; 3773 3774 /* ******************************************************* Shorthand Macros */ 3775 3776 /* Note that these macros will be used from inside the qsort function where 3777 we happen to know that the variable 'elt_size' contains the size of an 3778 array element and the variable 'temp' points to enough space to hold a 3779 temp element and the variable 'array' points to the array being sorted 3780 and 'compare' is the pointer to the compare routine. 3781 3782 Also note that there are very many highly architecture specific ways 3783 these might be sped up, but this is simply the most generally portable 3784 code I could think of. 3785 */ 3786 3787 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2 3788 */ 3789 #define qsort_cmp(elt1, elt2) \ 3790 ((*compare)(aTHXo_ array[elt1], array[elt2])) 3791 3792 #ifdef QSORT_ORDER_GUESS 3793 #define QSORT_NOTICE_SWAP swapped++; 3794 #else 3795 #define QSORT_NOTICE_SWAP 3796 #endif 3797 3798 /* swaps contents of array elements elt1, elt2. 3799 */ 3800 #define qsort_swap(elt1, elt2) \ 3801 STMT_START { \ 3802 QSORT_NOTICE_SWAP \ 3803 temp = array[elt1]; \ 3804 array[elt1] = array[elt2]; \ 3805 array[elt2] = temp; \ 3806 } STMT_END 3807 3808 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets 3809 elt3 and elt3 gets elt1. 3810 */ 3811 #define qsort_rotate(elt1, elt2, elt3) \ 3812 STMT_START { \ 3813 QSORT_NOTICE_SWAP \ 3814 temp = array[elt1]; \ 3815 array[elt1] = array[elt2]; \ 3816 array[elt2] = array[elt3]; \ 3817 array[elt3] = temp; \ 3818 } STMT_END 3819 3820 /* ************************************************************ Debug stuff */ 3821 3822 #ifdef QSORT_DEBUG 3823 3824 static void 3825 break_here() 3826 { 3827 return; /* good place to set a breakpoint */ 3828 } 3829 3830 #define qsort_assert(t) (void)( (t) || (break_here(), 0) ) 3831 3832 static void 3833 doqsort_all_asserts( 3834 void * array, 3835 size_t num_elts, 3836 size_t elt_size, 3837 int (*compare)(const void * elt1, const void * elt2), 3838 int pc_left, int pc_right, int u_left, int u_right) 3839 { 3840 int i; 3841 3842 qsort_assert(pc_left <= pc_right); 3843 qsort_assert(u_right < pc_left); 3844 qsort_assert(pc_right < u_left); 3845 for (i = u_right + 1; i < pc_left; ++i) { 3846 qsort_assert(qsort_cmp(i, pc_left) < 0); 3847 } 3848 for (i = pc_left; i < pc_right; ++i) { 3849 qsort_assert(qsort_cmp(i, pc_right) == 0); 3850 } 3851 for (i = pc_right + 1; i < u_left; ++i) { 3852 qsort_assert(qsort_cmp(pc_right, i) < 0); 3853 } 3854 } 3855 3856 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \ 3857 doqsort_all_asserts(array, num_elts, elt_size, compare, \ 3858 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) 3859 3860 #else 3861 3862 #define qsort_assert(t) ((void)0) 3863 3864 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0) 3865 3866 #endif 3867 3868 /* ****************************************************************** qsort */ 3869 3870 STATIC void 3871 S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare) 3872 { 3873 register SV * temp; 3874 3875 struct partition_stack_entry partition_stack[QSORT_MAX_STACK]; 3876 int next_stack_entry = 0; 3877 3878 int part_left; 3879 int part_right; 3880 #ifdef QSORT_ORDER_GUESS 3881 int qsort_break_even; 3882 int swapped; 3883 #endif 3884 3885 /* Make sure we actually have work to do. 3886 */ 3887 if (num_elts <= 1) { 3888 return; 3889 } 3890 3891 /* Setup the initial partition definition and fall into the sorting loop 3892 */ 3893 part_left = 0; 3894 part_right = (int)(num_elts - 1); 3895 #ifdef QSORT_ORDER_GUESS 3896 qsort_break_even = QSORT_BREAK_EVEN; 3897 #else 3898 #define qsort_break_even QSORT_BREAK_EVEN 3899 #endif 3900 for ( ; ; ) { 3901 if ((part_right - part_left) >= qsort_break_even) { 3902 /* OK, this is gonna get hairy, so lets try to document all the 3903 concepts and abbreviations and variables and what they keep 3904 track of: 3905 3906 pc: pivot chunk - the set of array elements we accumulate in the 3907 middle of the partition, all equal in value to the original 3908 pivot element selected. The pc is defined by: 3909 3910 pc_left - the leftmost array index of the pc 3911 pc_right - the rightmost array index of the pc 3912 3913 we start with pc_left == pc_right and only one element 3914 in the pivot chunk (but it can grow during the scan). 3915 3916 u: uncompared elements - the set of elements in the partition 3917 we have not yet compared to the pivot value. There are two 3918 uncompared sets during the scan - one to the left of the pc 3919 and one to the right. 3920 3921 u_right - the rightmost index of the left side's uncompared set 3922 u_left - the leftmost index of the right side's uncompared set 3923 3924 The leftmost index of the left sides's uncompared set 3925 doesn't need its own variable because it is always defined 3926 by the leftmost edge of the whole partition (part_left). The 3927 same goes for the rightmost edge of the right partition 3928 (part_right). 3929 3930 We know there are no uncompared elements on the left once we 3931 get u_right < part_left and no uncompared elements on the 3932 right once u_left > part_right. When both these conditions 3933 are met, we have completed the scan of the partition. 3934 3935 Any elements which are between the pivot chunk and the 3936 uncompared elements should be less than the pivot value on 3937 the left side and greater than the pivot value on the right 3938 side (in fact, the goal of the whole algorithm is to arrange 3939 for that to be true and make the groups of less-than and 3940 greater-then elements into new partitions to sort again). 3941 3942 As you marvel at the complexity of the code and wonder why it 3943 has to be so confusing. Consider some of the things this level 3944 of confusion brings: 3945 3946 Once I do a compare, I squeeze every ounce of juice out of it. I 3947 never do compare calls I don't have to do, and I certainly never 3948 do redundant calls. 3949 3950 I also never swap any elements unless I can prove there is a 3951 good reason. Many sort algorithms will swap a known value with 3952 an uncompared value just to get things in the right place (or 3953 avoid complexity :-), but that uncompared value, once it gets 3954 compared, may then have to be swapped again. A lot of the 3955 complexity of this code is due to the fact that it never swaps 3956 anything except compared values, and it only swaps them when the 3957 compare shows they are out of position. 3958 */ 3959 int pc_left, pc_right; 3960 int u_right, u_left; 3961 3962 int s; 3963 3964 pc_left = ((part_left + part_right) / 2); 3965 pc_right = pc_left; 3966 u_right = pc_left - 1; 3967 u_left = pc_right + 1; 3968 3969 /* Qsort works best when the pivot value is also the median value 3970 in the partition (unfortunately you can't find the median value 3971 without first sorting :-), so to give the algorithm a helping 3972 hand, we pick 3 elements and sort them and use the median value 3973 of that tiny set as the pivot value. 3974 3975 Some versions of qsort like to use the left middle and right as 3976 the 3 elements to sort so they can insure the ends of the 3977 partition will contain values which will stop the scan in the 3978 compare loop, but when you have to call an arbitrarily complex 3979 routine to do a compare, its really better to just keep track of 3980 array index values to know when you hit the edge of the 3981 partition and avoid the extra compare. An even better reason to 3982 avoid using a compare call is the fact that you can drop off the 3983 edge of the array if someone foolishly provides you with an 3984 unstable compare function that doesn't always provide consistent 3985 results. 3986 3987 So, since it is simpler for us to compare the three adjacent 3988 elements in the middle of the partition, those are the ones we 3989 pick here (conveniently pointed at by u_right, pc_left, and 3990 u_left). The values of the left, center, and right elements 3991 are refered to as l c and r in the following comments. 3992 */ 3993 3994 #ifdef QSORT_ORDER_GUESS 3995 swapped = 0; 3996 #endif 3997 s = qsort_cmp(u_right, pc_left); 3998 if (s < 0) { 3999 /* l < c */ 4000 s = qsort_cmp(pc_left, u_left); 4001 /* if l < c, c < r - already in order - nothing to do */ 4002 if (s == 0) { 4003 /* l < c, c == r - already in order, pc grows */ 4004 ++pc_right; 4005 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); 4006 } else if (s > 0) { 4007 /* l < c, c > r - need to know more */ 4008 s = qsort_cmp(u_right, u_left); 4009 if (s < 0) { 4010 /* l < c, c > r, l < r - swap c & r to get ordered */ 4011 qsort_swap(pc_left, u_left); 4012 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); 4013 } else if (s == 0) { 4014 /* l < c, c > r, l == r - swap c&r, grow pc */ 4015 qsort_swap(pc_left, u_left); 4016 --pc_left; 4017 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); 4018 } else { 4019 /* l < c, c > r, l > r - make lcr into rlc to get ordered */ 4020 qsort_rotate(pc_left, u_right, u_left); 4021 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); 4022 } 4023 } 4024 } else if (s == 0) { 4025 /* l == c */ 4026 s = qsort_cmp(pc_left, u_left); 4027 if (s < 0) { 4028 /* l == c, c < r - already in order, grow pc */ 4029 --pc_left; 4030 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); 4031 } else if (s == 0) { 4032 /* l == c, c == r - already in order, grow pc both ways */ 4033 --pc_left; 4034 ++pc_right; 4035 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); 4036 } else { 4037 /* l == c, c > r - swap l & r, grow pc */ 4038 qsort_swap(u_right, u_left); 4039 ++pc_right; 4040 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); 4041 } 4042 } else { 4043 /* l > c */ 4044 s = qsort_cmp(pc_left, u_left); 4045 if (s < 0) { 4046 /* l > c, c < r - need to know more */ 4047 s = qsort_cmp(u_right, u_left); 4048 if (s < 0) { 4049 /* l > c, c < r, l < r - swap l & c to get ordered */ 4050 qsort_swap(u_right, pc_left); 4051 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); 4052 } else if (s == 0) { 4053 /* l > c, c < r, l == r - swap l & c, grow pc */ 4054 qsort_swap(u_right, pc_left); 4055 ++pc_right; 4056 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); 4057 } else { 4058 /* l > c, c < r, l > r - rotate lcr into crl to order */ 4059 qsort_rotate(u_right, pc_left, u_left); 4060 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); 4061 } 4062 } else if (s == 0) { 4063 /* l > c, c == r - swap ends, grow pc */ 4064 qsort_swap(u_right, u_left); 4065 --pc_left; 4066 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); 4067 } else { 4068 /* l > c, c > r - swap ends to get in order */ 4069 qsort_swap(u_right, u_left); 4070 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); 4071 } 4072 } 4073 /* We now know the 3 middle elements have been compared and 4074 arranged in the desired order, so we can shrink the uncompared 4075 sets on both sides 4076 */ 4077 --u_right; 4078 ++u_left; 4079 qsort_all_asserts(pc_left, pc_right, u_left, u_right); 4080 4081 /* The above massive nested if was the simple part :-). We now have 4082 the middle 3 elements ordered and we need to scan through the 4083 uncompared sets on either side, swapping elements that are on 4084 the wrong side or simply shuffling equal elements around to get 4085 all equal elements into the pivot chunk. 4086 */ 4087 4088 for ( ; ; ) { 4089 int still_work_on_left; 4090 int still_work_on_right; 4091 4092 /* Scan the uncompared values on the left. If I find a value 4093 equal to the pivot value, move it over so it is adjacent to 4094 the pivot chunk and expand the pivot chunk. If I find a value 4095 less than the pivot value, then just leave it - its already 4096 on the correct side of the partition. If I find a greater 4097 value, then stop the scan. 4098 */ 4099 while ((still_work_on_left = (u_right >= part_left))) { 4100 s = qsort_cmp(u_right, pc_left); 4101 if (s < 0) { 4102 --u_right; 4103 } else if (s == 0) { 4104 --pc_left; 4105 if (pc_left != u_right) { 4106 qsort_swap(u_right, pc_left); 4107 } 4108 --u_right; 4109 } else { 4110 break; 4111 } 4112 qsort_assert(u_right < pc_left); 4113 qsort_assert(pc_left <= pc_right); 4114 qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0); 4115 qsort_assert(qsort_cmp(pc_left, pc_right) == 0); 4116 } 4117 4118 /* Do a mirror image scan of uncompared values on the right 4119 */ 4120 while ((still_work_on_right = (u_left <= part_right))) { 4121 s = qsort_cmp(pc_right, u_left); 4122 if (s < 0) { 4123 ++u_left; 4124 } else if (s == 0) { 4125 ++pc_right; 4126 if (pc_right != u_left) { 4127 qsort_swap(pc_right, u_left); 4128 } 4129 ++u_left; 4130 } else { 4131 break; 4132 } 4133 qsort_assert(u_left > pc_right); 4134 qsort_assert(pc_left <= pc_right); 4135 qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0); 4136 qsort_assert(qsort_cmp(pc_left, pc_right) == 0); 4137 } 4138 4139 if (still_work_on_left) { 4140 /* I know I have a value on the left side which needs to be 4141 on the right side, but I need to know more to decide 4142 exactly the best thing to do with it. 4143 */ 4144 if (still_work_on_right) { 4145 /* I know I have values on both side which are out of 4146 position. This is a big win because I kill two birds 4147 with one swap (so to speak). I can advance the 4148 uncompared pointers on both sides after swapping both 4149 of them into the right place. 4150 */ 4151 qsort_swap(u_right, u_left); 4152 --u_right; 4153 ++u_left; 4154 qsort_all_asserts(pc_left, pc_right, u_left, u_right); 4155 } else { 4156 /* I have an out of position value on the left, but the 4157 right is fully scanned, so I "slide" the pivot chunk 4158 and any less-than values left one to make room for the 4159 greater value over on the right. If the out of position 4160 value is immediately adjacent to the pivot chunk (there 4161 are no less-than values), I can do that with a swap, 4162 otherwise, I have to rotate one of the less than values 4163 into the former position of the out of position value 4164 and the right end of the pivot chunk into the left end 4165 (got all that?). 4166 */ 4167 --pc_left; 4168 if (pc_left == u_right) { 4169 qsort_swap(u_right, pc_right); 4170 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1); 4171 } else { 4172 qsort_rotate(u_right, pc_left, pc_right); 4173 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1); 4174 } 4175 --pc_right; 4176 --u_right; 4177 } 4178 } else if (still_work_on_right) { 4179 /* Mirror image of complex case above: I have an out of 4180 position value on the right, but the left is fully 4181 scanned, so I need to shuffle things around to make room 4182 for the right value on the left. 4183 */ 4184 ++pc_right; 4185 if (pc_right == u_left) { 4186 qsort_swap(u_left, pc_left); 4187 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right); 4188 } else { 4189 qsort_rotate(pc_right, pc_left, u_left); 4190 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right); 4191 } 4192 ++pc_left; 4193 ++u_left; 4194 } else { 4195 /* No more scanning required on either side of partition, 4196 break out of loop and figure out next set of partitions 4197 */ 4198 break; 4199 } 4200 } 4201 4202 /* The elements in the pivot chunk are now in the right place. They 4203 will never move or be compared again. All I have to do is decide 4204 what to do with the stuff to the left and right of the pivot 4205 chunk. 4206 4207 Notes on the QSORT_ORDER_GUESS ifdef code: 4208 4209 1. If I just built these partitions without swapping any (or 4210 very many) elements, there is a chance that the elements are 4211 already ordered properly (being properly ordered will 4212 certainly result in no swapping, but the converse can't be 4213 proved :-). 4214 4215 2. A (properly written) insertion sort will run faster on 4216 already ordered data than qsort will. 4217 4218 3. Perhaps there is some way to make a good guess about 4219 switching to an insertion sort earlier than partition size 6 4220 (for instance - we could save the partition size on the stack 4221 and increase the size each time we find we didn't swap, thus 4222 switching to insertion sort earlier for partitions with a 4223 history of not swapping). 4224 4225 4. Naturally, if I just switch right away, it will make 4226 artificial benchmarks with pure ascending (or descending) 4227 data look really good, but is that a good reason in general? 4228 Hard to say... 4229 */ 4230 4231 #ifdef QSORT_ORDER_GUESS 4232 if (swapped < 3) { 4233 #if QSORT_ORDER_GUESS == 1 4234 qsort_break_even = (part_right - part_left) + 1; 4235 #endif 4236 #if QSORT_ORDER_GUESS == 2 4237 qsort_break_even *= 2; 4238 #endif 4239 #if QSORT_ORDER_GUESS == 3 4240 int prev_break = qsort_break_even; 4241 qsort_break_even *= qsort_break_even; 4242 if (qsort_break_even < prev_break) { 4243 qsort_break_even = (part_right - part_left) + 1; 4244 } 4245 #endif 4246 } else { 4247 qsort_break_even = QSORT_BREAK_EVEN; 4248 } 4249 #endif 4250 4251 if (part_left < pc_left) { 4252 /* There are elements on the left which need more processing. 4253 Check the right as well before deciding what to do. 4254 */ 4255 if (pc_right < part_right) { 4256 /* We have two partitions to be sorted. Stack the biggest one 4257 and process the smallest one on the next iteration. This 4258 minimizes the stack height by insuring that any additional 4259 stack entries must come from the smallest partition which 4260 (because it is smallest) will have the fewest 4261 opportunities to generate additional stack entries. 4262 */ 4263 if ((part_right - pc_right) > (pc_left - part_left)) { 4264 /* stack the right partition, process the left */ 4265 partition_stack[next_stack_entry].left = pc_right + 1; 4266 partition_stack[next_stack_entry].right = part_right; 4267 #ifdef QSORT_ORDER_GUESS 4268 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even; 4269 #endif 4270 part_right = pc_left - 1; 4271 } else { 4272 /* stack the left partition, process the right */ 4273 partition_stack[next_stack_entry].left = part_left; 4274 partition_stack[next_stack_entry].right = pc_left - 1; 4275 #ifdef QSORT_ORDER_GUESS 4276 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even; 4277 #endif 4278 part_left = pc_right + 1; 4279 } 4280 qsort_assert(next_stack_entry < QSORT_MAX_STACK); 4281 ++next_stack_entry; 4282 } else { 4283 /* The elements on the left are the only remaining elements 4284 that need sorting, arrange for them to be processed as the 4285 next partition. 4286 */ 4287 part_right = pc_left - 1; 4288 } 4289 } else if (pc_right < part_right) { 4290 /* There is only one chunk on the right to be sorted, make it 4291 the new partition and loop back around. 4292 */ 4293 part_left = pc_right + 1; 4294 } else { 4295 /* This whole partition wound up in the pivot chunk, so 4296 we need to get a new partition off the stack. 4297 */ 4298 if (next_stack_entry == 0) { 4299 /* the stack is empty - we are done */ 4300 break; 4301 } 4302 --next_stack_entry; 4303 part_left = partition_stack[next_stack_entry].left; 4304 part_right = partition_stack[next_stack_entry].right; 4305 #ifdef QSORT_ORDER_GUESS 4306 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even; 4307 #endif 4308 } 4309 } else { 4310 /* This partition is too small to fool with qsort complexity, just 4311 do an ordinary insertion sort to minimize overhead. 4312 */ 4313 int i; 4314 /* Assume 1st element is in right place already, and start checking 4315 at 2nd element to see where it should be inserted. 4316 */ 4317 for (i = part_left + 1; i <= part_right; ++i) { 4318 int j; 4319 /* Scan (backwards - just in case 'i' is already in right place) 4320 through the elements already sorted to see if the ith element 4321 belongs ahead of one of them. 4322 */ 4323 for (j = i - 1; j >= part_left; --j) { 4324 if (qsort_cmp(i, j) >= 0) { 4325 /* i belongs right after j 4326 */ 4327 break; 4328 } 4329 } 4330 ++j; 4331 if (j != i) { 4332 /* Looks like we really need to move some things 4333 */ 4334 int k; 4335 temp = array[i]; 4336 for (k = i - 1; k >= j; --k) 4337 array[k + 1] = array[k]; 4338 array[j] = temp; 4339 } 4340 } 4341 4342 /* That partition is now sorted, grab the next one, or get out 4343 of the loop if there aren't any more. 4344 */ 4345 4346 if (next_stack_entry == 0) { 4347 /* the stack is empty - we are done */ 4348 break; 4349 } 4350 --next_stack_entry; 4351 part_left = partition_stack[next_stack_entry].left; 4352 part_right = partition_stack[next_stack_entry].right; 4353 #ifdef QSORT_ORDER_GUESS 4354 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even; 4355 #endif 4356 } 4357 } 4358 4359 /* Believe it or not, the array is sorted at this point! */ 4360 } 4361 4362 4363 #ifdef PERL_OBJECT 4364 #undef this 4365 #define this pPerl 4366 #include "XSUB.h" 4367 #endif 4368 4369 4370 static I32 4371 sortcv(pTHXo_ SV *a, SV *b) 4372 { 4373 I32 oldsaveix = PL_savestack_ix; 4374 I32 oldscopeix = PL_scopestack_ix; 4375 I32 result; 4376 GvSV(PL_firstgv) = a; 4377 GvSV(PL_secondgv) = b; 4378 PL_stack_sp = PL_stack_base; 4379 PL_op = PL_sortcop; 4380 CALLRUNOPS(aTHX); 4381 if (PL_stack_sp != PL_stack_base + 1) 4382 Perl_croak(aTHX_ "Sort subroutine didn't return single value"); 4383 if (!SvNIOKp(*PL_stack_sp)) 4384 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value"); 4385 result = SvIV(*PL_stack_sp); 4386 while (PL_scopestack_ix > oldscopeix) { 4387 LEAVE; 4388 } 4389 leave_scope(oldsaveix); 4390 return result; 4391 } 4392 4393 static I32 4394 sortcv_stacked(pTHXo_ SV *a, SV *b) 4395 { 4396 I32 oldsaveix = PL_savestack_ix; 4397 I32 oldscopeix = PL_scopestack_ix; 4398 I32 result; 4399 AV *av; 4400 4401 #ifdef USE_THREADS 4402 av = (AV*)PL_curpad[0]; 4403 #else 4404 av = GvAV(PL_defgv); 4405 #endif 4406 4407 if (AvMAX(av) < 1) { 4408 SV** ary = AvALLOC(av); 4409 if (AvARRAY(av) != ary) { 4410 AvMAX(av) += AvARRAY(av) - AvALLOC(av); 4411 SvPVX(av) = (char*)ary; 4412 } 4413 if (AvMAX(av) < 1) { 4414 AvMAX(av) = 1; 4415 Renew(ary,2,SV*); 4416 SvPVX(av) = (char*)ary; 4417 } 4418 } 4419 AvFILLp(av) = 1; 4420 4421 AvARRAY(av)[0] = a; 4422 AvARRAY(av)[1] = b; 4423 PL_stack_sp = PL_stack_base; 4424 PL_op = PL_sortcop; 4425 CALLRUNOPS(aTHX); 4426 if (PL_stack_sp != PL_stack_base + 1) 4427 Perl_croak(aTHX_ "Sort subroutine didn't return single value"); 4428 if (!SvNIOKp(*PL_stack_sp)) 4429 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value"); 4430 result = SvIV(*PL_stack_sp); 4431 while (PL_scopestack_ix > oldscopeix) { 4432 LEAVE; 4433 } 4434 leave_scope(oldsaveix); 4435 return result; 4436 } 4437 4438 static I32 4439 sortcv_xsub(pTHXo_ SV *a, SV *b) 4440 { 4441 dSP; 4442 I32 oldsaveix = PL_savestack_ix; 4443 I32 oldscopeix = PL_scopestack_ix; 4444 I32 result; 4445 CV *cv=(CV*)PL_sortcop; 4446 4447 SP = PL_stack_base; 4448 PUSHMARK(SP); 4449 EXTEND(SP, 2); 4450 *++SP = a; 4451 *++SP = b; 4452 PUTBACK; 4453 (void)(*CvXSUB(cv))(aTHXo_ cv); 4454 if (PL_stack_sp != PL_stack_base + 1) 4455 Perl_croak(aTHX_ "Sort subroutine didn't return single value"); 4456 if (!SvNIOKp(*PL_stack_sp)) 4457 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value"); 4458 result = SvIV(*PL_stack_sp); 4459 while (PL_scopestack_ix > oldscopeix) { 4460 LEAVE; 4461 } 4462 leave_scope(oldsaveix); 4463 return result; 4464 } 4465 4466 4467 static I32 4468 sv_ncmp(pTHXo_ SV *a, SV *b) 4469 { 4470 NV nv1 = SvNV(a); 4471 NV nv2 = SvNV(b); 4472 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0; 4473 } 4474 4475 static I32 4476 sv_i_ncmp(pTHXo_ SV *a, SV *b) 4477 { 4478 IV iv1 = SvIV(a); 4479 IV iv2 = SvIV(b); 4480 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0; 4481 } 4482 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \ 4483 *svp = Nullsv; \ 4484 if (PL_amagic_generation) { \ 4485 if (SvAMAGIC(left)||SvAMAGIC(right))\ 4486 *svp = amagic_call(left, \ 4487 right, \ 4488 CAT2(meth,_amg), \ 4489 0); \ 4490 } \ 4491 } STMT_END 4492 4493 static I32 4494 amagic_ncmp(pTHXo_ register SV *a, register SV *b) 4495 { 4496 SV *tmpsv; 4497 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv); 4498 if (tmpsv) { 4499 NV d; 4500 4501 if (SvIOK(tmpsv)) { 4502 I32 i = SvIVX(tmpsv); 4503 if (i > 0) 4504 return 1; 4505 return i? -1 : 0; 4506 } 4507 d = SvNV(tmpsv); 4508 if (d > 0) 4509 return 1; 4510 return d? -1 : 0; 4511 } 4512 return sv_ncmp(aTHXo_ a, b); 4513 } 4514 4515 static I32 4516 amagic_i_ncmp(pTHXo_ register SV *a, register SV *b) 4517 { 4518 SV *tmpsv; 4519 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv); 4520 if (tmpsv) { 4521 NV d; 4522 4523 if (SvIOK(tmpsv)) { 4524 I32 i = SvIVX(tmpsv); 4525 if (i > 0) 4526 return 1; 4527 return i? -1 : 0; 4528 } 4529 d = SvNV(tmpsv); 4530 if (d > 0) 4531 return 1; 4532 return d? -1 : 0; 4533 } 4534 return sv_i_ncmp(aTHXo_ a, b); 4535 } 4536 4537 static I32 4538 amagic_cmp(pTHXo_ register SV *str1, register SV *str2) 4539 { 4540 SV *tmpsv; 4541 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv); 4542 if (tmpsv) { 4543 NV d; 4544 4545 if (SvIOK(tmpsv)) { 4546 I32 i = SvIVX(tmpsv); 4547 if (i > 0) 4548 return 1; 4549 return i? -1 : 0; 4550 } 4551 d = SvNV(tmpsv); 4552 if (d > 0) 4553 return 1; 4554 return d? -1 : 0; 4555 } 4556 return sv_cmp(str1, str2); 4557 } 4558 4559 static I32 4560 amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2) 4561 { 4562 SV *tmpsv; 4563 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv); 4564 if (tmpsv) { 4565 NV d; 4566 4567 if (SvIOK(tmpsv)) { 4568 I32 i = SvIVX(tmpsv); 4569 if (i > 0) 4570 return 1; 4571 return i? -1 : 0; 4572 } 4573 d = SvNV(tmpsv); 4574 if (d > 0) 4575 return 1; 4576 return d? -1 : 0; 4577 } 4578 return sv_cmp_locale(str1, str2); 4579 } 4580 4581 static I32 4582 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen) 4583 { 4584 SV *datasv = FILTER_DATA(idx); 4585 int filter_has_file = IoLINES(datasv); 4586 GV *filter_child_proc = (GV *)IoFMT_GV(datasv); 4587 SV *filter_state = (SV *)IoTOP_GV(datasv); 4588 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv); 4589 int len = 0; 4590 4591 /* I was having segfault trouble under Linux 2.2.5 after a 4592 parse error occured. (Had to hack around it with a test 4593 for PL_error_count == 0.) Solaris doesn't segfault -- 4594 not sure where the trouble is yet. XXX */ 4595 4596 if (filter_has_file) { 4597 len = FILTER_READ(idx+1, buf_sv, maxlen); 4598 } 4599 4600 if (filter_sub && len >= 0) { 4601 dSP; 4602 int count; 4603 4604 ENTER; 4605 SAVE_DEFSV; 4606 SAVETMPS; 4607 EXTEND(SP, 2); 4608 4609 DEFSV = buf_sv; 4610 PUSHMARK(SP); 4611 PUSHs(sv_2mortal(newSViv(maxlen))); 4612 if (filter_state) { 4613 PUSHs(filter_state); 4614 } 4615 PUTBACK; 4616 count = call_sv(filter_sub, G_SCALAR); 4617 SPAGAIN; 4618 4619 if (count > 0) { 4620 SV *out = POPs; 4621 if (SvOK(out)) { 4622 len = SvIV(out); 4623 } 4624 } 4625 4626 PUTBACK; 4627 FREETMPS; 4628 LEAVE; 4629 } 4630 4631 if (len <= 0) { 4632 IoLINES(datasv) = 0; 4633 if (filter_child_proc) { 4634 SvREFCNT_dec(filter_child_proc); 4635 IoFMT_GV(datasv) = Nullgv; 4636 } 4637 if (filter_state) { 4638 SvREFCNT_dec(filter_state); 4639 IoTOP_GV(datasv) = Nullgv; 4640 } 4641 if (filter_sub) { 4642 SvREFCNT_dec(filter_sub); 4643 IoBOTTOM_GV(datasv) = Nullgv; 4644 } 4645 filter_del(run_user_filter); 4646 } 4647 4648 return len; 4649 } 4650 4651 #ifdef PERL_OBJECT 4652 4653 static I32 4654 sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2) 4655 { 4656 return sv_cmp_locale(str1, str2); 4657 } 4658 4659 static I32 4660 sv_cmp_static(pTHXo_ register SV *str1, register SV *str2) 4661 { 4662 return sv_cmp(str1, str2); 4663 } 4664 4665 #endif /* PERL_OBJECT */ 4666