1 /* pp.c 2 * 3 * Copyright (c) 1991-2002, 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 * "It's a big house this, and very peculiar. Always a bit more to discover, 12 * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise 13 */ 14 15 #include "EXTERN.h" 16 #define PERL_IN_PP_C 17 #include "perl.h" 18 #include "keywords.h" 19 20 #include "reentr.h" 21 22 /* variations on pp_null */ 23 24 /* XXX I can't imagine anyone who doesn't have this actually _needs_ 25 it, since pid_t is an integral type. 26 --AD 2/20/1998 27 */ 28 #ifdef NEED_GETPID_PROTO 29 extern Pid_t getpid (void); 30 #endif 31 32 PP(pp_stub) 33 { 34 dSP; 35 if (GIMME_V == G_SCALAR) 36 XPUSHs(&PL_sv_undef); 37 RETURN; 38 } 39 40 PP(pp_scalar) 41 { 42 return NORMAL; 43 } 44 45 /* Pushy stuff. */ 46 47 PP(pp_padav) 48 { 49 dSP; dTARGET; 50 if (PL_op->op_private & OPpLVAL_INTRO) 51 SAVECLEARSV(PL_curpad[PL_op->op_targ]); 52 EXTEND(SP, 1); 53 if (PL_op->op_flags & OPf_REF) { 54 PUSHs(TARG); 55 RETURN; 56 } else if (LVRET) { 57 if (GIMME == G_SCALAR) 58 Perl_croak(aTHX_ "Can't return array to lvalue scalar context"); 59 PUSHs(TARG); 60 RETURN; 61 } 62 if (GIMME == G_ARRAY) { 63 I32 maxarg = AvFILL((AV*)TARG) + 1; 64 EXTEND(SP, maxarg); 65 if (SvMAGICAL(TARG)) { 66 U32 i; 67 for (i=0; i < (U32)maxarg; i++) { 68 SV **svp = av_fetch((AV*)TARG, i, FALSE); 69 SP[i+1] = (svp) ? *svp : &PL_sv_undef; 70 } 71 } 72 else { 73 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*); 74 } 75 SP += maxarg; 76 } 77 else { 78 SV* sv = sv_newmortal(); 79 I32 maxarg = AvFILL((AV*)TARG) + 1; 80 sv_setiv(sv, maxarg); 81 PUSHs(sv); 82 } 83 RETURN; 84 } 85 86 PP(pp_padhv) 87 { 88 dSP; dTARGET; 89 I32 gimme; 90 91 XPUSHs(TARG); 92 if (PL_op->op_private & OPpLVAL_INTRO) 93 SAVECLEARSV(PL_curpad[PL_op->op_targ]); 94 if (PL_op->op_flags & OPf_REF) 95 RETURN; 96 else if (LVRET) { 97 if (GIMME == G_SCALAR) 98 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context"); 99 RETURN; 100 } 101 gimme = GIMME_V; 102 if (gimme == G_ARRAY) { 103 RETURNOP(do_kv()); 104 } 105 else if (gimme == G_SCALAR) { 106 SV* sv = sv_newmortal(); 107 if (HvFILL((HV*)TARG)) 108 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld", 109 (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1); 110 else 111 sv_setiv(sv, 0); 112 SETs(sv); 113 } 114 RETURN; 115 } 116 117 PP(pp_padany) 118 { 119 DIE(aTHX_ "NOT IMPL LINE %d",__LINE__); 120 } 121 122 /* Translations. */ 123 124 PP(pp_rv2gv) 125 { 126 dSP; dTOPss; 127 128 if (SvROK(sv)) { 129 wasref: 130 tryAMAGICunDEREF(to_gv); 131 132 sv = SvRV(sv); 133 if (SvTYPE(sv) == SVt_PVIO) { 134 GV *gv = (GV*) sv_newmortal(); 135 gv_init(gv, 0, "", 0, 0); 136 GvIOp(gv) = (IO *)sv; 137 (void)SvREFCNT_inc(sv); 138 sv = (SV*) gv; 139 } 140 else if (SvTYPE(sv) != SVt_PVGV) 141 DIE(aTHX_ "Not a GLOB reference"); 142 } 143 else { 144 if (SvTYPE(sv) != SVt_PVGV) { 145 char *sym; 146 STRLEN len; 147 148 if (SvGMAGICAL(sv)) { 149 mg_get(sv); 150 if (SvROK(sv)) 151 goto wasref; 152 } 153 if (!SvOK(sv) && sv != &PL_sv_undef) { 154 /* If this is a 'my' scalar and flag is set then vivify 155 * NI-S 1999/05/07 156 */ 157 if (PL_op->op_private & OPpDEREF) { 158 char *name; 159 GV *gv; 160 if (cUNOP->op_targ) { 161 STRLEN len; 162 SV *namesv = PL_curpad[cUNOP->op_targ]; 163 name = SvPV(namesv, len); 164 gv = (GV*)NEWSV(0,0); 165 gv_init(gv, CopSTASH(PL_curcop), name, len, 0); 166 } 167 else { 168 name = CopSTASHPV(PL_curcop); 169 gv = newGVgen(name); 170 } 171 if (SvTYPE(sv) < SVt_RV) 172 sv_upgrade(sv, SVt_RV); 173 SvRV(sv) = (SV*)gv; 174 SvROK_on(sv); 175 SvSETMAGIC(sv); 176 goto wasref; 177 } 178 if (PL_op->op_flags & OPf_REF || 179 PL_op->op_private & HINT_STRICT_REFS) 180 DIE(aTHX_ PL_no_usym, "a symbol"); 181 if (ckWARN(WARN_UNINITIALIZED)) 182 report_uninit(); 183 RETSETUNDEF; 184 } 185 sym = SvPV(sv,len); 186 if ((PL_op->op_flags & OPf_SPECIAL) && 187 !(PL_op->op_flags & OPf_MOD)) 188 { 189 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV); 190 if (!sv 191 && (!is_gv_magical(sym,len,0) 192 || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV)))) 193 { 194 RETSETUNDEF; 195 } 196 } 197 else { 198 if (PL_op->op_private & HINT_STRICT_REFS) 199 DIE(aTHX_ PL_no_symref, sym, "a symbol"); 200 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV); 201 } 202 } 203 } 204 if (PL_op->op_private & OPpLVAL_INTRO) 205 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL)); 206 SETs(sv); 207 RETURN; 208 } 209 210 PP(pp_rv2sv) 211 { 212 dSP; dTOPss; 213 214 if (SvROK(sv)) { 215 wasref: 216 tryAMAGICunDEREF(to_sv); 217 218 sv = SvRV(sv); 219 switch (SvTYPE(sv)) { 220 case SVt_PVAV: 221 case SVt_PVHV: 222 case SVt_PVCV: 223 DIE(aTHX_ "Not a SCALAR reference"); 224 } 225 } 226 else { 227 GV *gv = (GV*)sv; 228 char *sym; 229 STRLEN len; 230 231 if (SvTYPE(gv) != SVt_PVGV) { 232 if (SvGMAGICAL(sv)) { 233 mg_get(sv); 234 if (SvROK(sv)) 235 goto wasref; 236 } 237 if (!SvOK(sv)) { 238 if (PL_op->op_flags & OPf_REF || 239 PL_op->op_private & HINT_STRICT_REFS) 240 DIE(aTHX_ PL_no_usym, "a SCALAR"); 241 if (ckWARN(WARN_UNINITIALIZED)) 242 report_uninit(); 243 RETSETUNDEF; 244 } 245 sym = SvPV(sv, len); 246 if ((PL_op->op_flags & OPf_SPECIAL) && 247 !(PL_op->op_flags & OPf_MOD)) 248 { 249 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV); 250 if (!gv 251 && (!is_gv_magical(sym,len,0) 252 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV)))) 253 { 254 RETSETUNDEF; 255 } 256 } 257 else { 258 if (PL_op->op_private & HINT_STRICT_REFS) 259 DIE(aTHX_ PL_no_symref, sym, "a SCALAR"); 260 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV); 261 } 262 } 263 sv = GvSV(gv); 264 } 265 if (PL_op->op_flags & OPf_MOD) { 266 if (PL_op->op_private & OPpLVAL_INTRO) 267 sv = save_scalar((GV*)TOPs); 268 else if (PL_op->op_private & OPpDEREF) 269 vivify_ref(sv, PL_op->op_private & OPpDEREF); 270 } 271 SETs(sv); 272 RETURN; 273 } 274 275 PP(pp_av2arylen) 276 { 277 dSP; 278 AV *av = (AV*)TOPs; 279 SV *sv = AvARYLEN(av); 280 if (!sv) { 281 AvARYLEN(av) = sv = NEWSV(0,0); 282 sv_upgrade(sv, SVt_IV); 283 sv_magic(sv, (SV*)av, PERL_MAGIC_arylen, Nullch, 0); 284 } 285 SETs(sv); 286 RETURN; 287 } 288 289 PP(pp_pos) 290 { 291 dSP; dTARGET; dPOPss; 292 293 if (PL_op->op_flags & OPf_MOD || LVRET) { 294 if (SvTYPE(TARG) < SVt_PVLV) { 295 sv_upgrade(TARG, SVt_PVLV); 296 sv_magic(TARG, Nullsv, PERL_MAGIC_pos, Nullch, 0); 297 } 298 299 LvTYPE(TARG) = '.'; 300 if (LvTARG(TARG) != sv) { 301 if (LvTARG(TARG)) 302 SvREFCNT_dec(LvTARG(TARG)); 303 LvTARG(TARG) = SvREFCNT_inc(sv); 304 } 305 PUSHs(TARG); /* no SvSETMAGIC */ 306 RETURN; 307 } 308 else { 309 MAGIC* mg; 310 311 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { 312 mg = mg_find(sv, PERL_MAGIC_regex_global); 313 if (mg && mg->mg_len >= 0) { 314 I32 i = mg->mg_len; 315 if (DO_UTF8(sv)) 316 sv_pos_b2u(sv, &i); 317 PUSHi(i + PL_curcop->cop_arybase); 318 RETURN; 319 } 320 } 321 RETPUSHUNDEF; 322 } 323 } 324 325 PP(pp_rv2cv) 326 { 327 dSP; 328 GV *gv; 329 HV *stash; 330 331 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */ 332 /* (But not in defined().) */ 333 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL)); 334 if (cv) { 335 if (CvCLONE(cv)) 336 cv = (CV*)sv_2mortal((SV*)cv_clone(cv)); 337 if ((PL_op->op_private & OPpLVAL_INTRO)) { 338 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE))) 339 cv = GvCV(gv); 340 if (!CvLVALUE(cv)) 341 DIE(aTHX_ "Can't modify non-lvalue subroutine call"); 342 } 343 } 344 else 345 cv = (CV*)&PL_sv_undef; 346 SETs((SV*)cv); 347 RETURN; 348 } 349 350 PP(pp_prototype) 351 { 352 dSP; 353 CV *cv; 354 HV *stash; 355 GV *gv; 356 SV *ret; 357 358 ret = &PL_sv_undef; 359 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) { 360 char *s = SvPVX(TOPs); 361 if (strnEQ(s, "CORE::", 6)) { 362 int code; 363 364 code = keyword(s + 6, SvCUR(TOPs) - 6); 365 if (code < 0) { /* Overridable. */ 366 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2) 367 int i = 0, n = 0, seen_question = 0; 368 I32 oa; 369 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */ 370 371 if (code == -KEY_chop || code == -KEY_chomp) 372 goto set; 373 while (i < MAXO) { /* The slow way. */ 374 if (strEQ(s + 6, PL_op_name[i]) 375 || strEQ(s + 6, PL_op_desc[i])) 376 { 377 goto found; 378 } 379 i++; 380 } 381 goto nonesuch; /* Should not happen... */ 382 found: 383 oa = PL_opargs[i] >> OASHIFT; 384 while (oa) { 385 if (oa & OA_OPTIONAL && !seen_question) { 386 seen_question = 1; 387 str[n++] = ';'; 388 } 389 else if (n && str[0] == ';' && seen_question) 390 goto set; /* XXXX system, exec */ 391 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF 392 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF 393 /* But globs are already references (kinda) */ 394 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF 395 ) { 396 str[n++] = '\\'; 397 } 398 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)]; 399 oa = oa >> 4; 400 } 401 str[n++] = '\0'; 402 ret = sv_2mortal(newSVpvn(str, n - 1)); 403 } 404 else if (code) /* Non-Overridable */ 405 goto set; 406 else { /* None such */ 407 nonesuch: 408 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6); 409 } 410 } 411 } 412 cv = sv_2cv(TOPs, &stash, &gv, FALSE); 413 if (cv && SvPOK(cv)) 414 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv))); 415 set: 416 SETs(ret); 417 RETURN; 418 } 419 420 PP(pp_anoncode) 421 { 422 dSP; 423 CV* cv = (CV*)PL_curpad[PL_op->op_targ]; 424 if (CvCLONE(cv)) 425 cv = (CV*)sv_2mortal((SV*)cv_clone(cv)); 426 EXTEND(SP,1); 427 PUSHs((SV*)cv); 428 RETURN; 429 } 430 431 PP(pp_srefgen) 432 { 433 dSP; 434 *SP = refto(*SP); 435 RETURN; 436 } 437 438 PP(pp_refgen) 439 { 440 dSP; dMARK; 441 if (GIMME != G_ARRAY) { 442 if (++MARK <= SP) 443 *MARK = *SP; 444 else 445 *MARK = &PL_sv_undef; 446 *MARK = refto(*MARK); 447 SP = MARK; 448 RETURN; 449 } 450 EXTEND_MORTAL(SP - MARK); 451 while (++MARK <= SP) 452 *MARK = refto(*MARK); 453 RETURN; 454 } 455 456 STATIC SV* 457 S_refto(pTHX_ SV *sv) 458 { 459 SV* rv; 460 461 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') { 462 if (LvTARGLEN(sv)) 463 vivify_defelem(sv); 464 if (!(sv = LvTARG(sv))) 465 sv = &PL_sv_undef; 466 else 467 (void)SvREFCNT_inc(sv); 468 } 469 else if (SvTYPE(sv) == SVt_PVAV) { 470 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv)) 471 av_reify((AV*)sv); 472 SvTEMP_off(sv); 473 (void)SvREFCNT_inc(sv); 474 } 475 else if (SvPADTMP(sv) && !IS_PADGV(sv)) 476 sv = newSVsv(sv); 477 else { 478 SvTEMP_off(sv); 479 (void)SvREFCNT_inc(sv); 480 } 481 rv = sv_newmortal(); 482 sv_upgrade(rv, SVt_RV); 483 SvRV(rv) = sv; 484 SvROK_on(rv); 485 return rv; 486 } 487 488 PP(pp_ref) 489 { 490 dSP; dTARGET; 491 SV *sv; 492 char *pv; 493 494 sv = POPs; 495 496 if (sv && SvGMAGICAL(sv)) 497 mg_get(sv); 498 499 if (!sv || !SvROK(sv)) 500 RETPUSHNO; 501 502 sv = SvRV(sv); 503 pv = sv_reftype(sv,TRUE); 504 PUSHp(pv, strlen(pv)); 505 RETURN; 506 } 507 508 PP(pp_bless) 509 { 510 dSP; 511 HV *stash; 512 513 if (MAXARG == 1) 514 stash = CopSTASH(PL_curcop); 515 else { 516 SV *ssv = POPs; 517 STRLEN len; 518 char *ptr; 519 520 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv)) 521 Perl_croak(aTHX_ "Attempt to bless into a reference"); 522 ptr = SvPV(ssv,len); 523 if (ckWARN(WARN_MISC) && len == 0) 524 Perl_warner(aTHX_ packWARN(WARN_MISC), 525 "Explicit blessing to '' (assuming package main)"); 526 stash = gv_stashpvn(ptr, len, TRUE); 527 } 528 529 (void)sv_bless(TOPs, stash); 530 RETURN; 531 } 532 533 PP(pp_gelem) 534 { 535 GV *gv; 536 SV *sv; 537 SV *tmpRef; 538 char *elem; 539 dSP; 540 STRLEN n_a; 541 542 sv = POPs; 543 elem = SvPV(sv, n_a); 544 gv = (GV*)POPs; 545 tmpRef = Nullsv; 546 sv = Nullsv; 547 switch (elem ? *elem : '\0') 548 { 549 case 'A': 550 if (strEQ(elem, "ARRAY")) 551 tmpRef = (SV*)GvAV(gv); 552 break; 553 case 'C': 554 if (strEQ(elem, "CODE")) 555 tmpRef = (SV*)GvCVu(gv); 556 break; 557 case 'F': 558 if (strEQ(elem, "FILEHANDLE")) { 559 /* finally deprecated in 5.8.0 */ 560 deprecate("*glob{FILEHANDLE}"); 561 tmpRef = (SV*)GvIOp(gv); 562 } 563 else 564 if (strEQ(elem, "FORMAT")) 565 tmpRef = (SV*)GvFORM(gv); 566 break; 567 case 'G': 568 if (strEQ(elem, "GLOB")) 569 tmpRef = (SV*)gv; 570 break; 571 case 'H': 572 if (strEQ(elem, "HASH")) 573 tmpRef = (SV*)GvHV(gv); 574 break; 575 case 'I': 576 if (strEQ(elem, "IO")) 577 tmpRef = (SV*)GvIOp(gv); 578 break; 579 case 'N': 580 if (strEQ(elem, "NAME")) 581 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv)); 582 break; 583 case 'P': 584 if (strEQ(elem, "PACKAGE")) 585 sv = newSVpv(HvNAME(GvSTASH(gv)), 0); 586 break; 587 case 'S': 588 if (strEQ(elem, "SCALAR")) 589 tmpRef = GvSV(gv); 590 break; 591 } 592 if (tmpRef) 593 sv = newRV(tmpRef); 594 if (sv) 595 sv_2mortal(sv); 596 else 597 sv = &PL_sv_undef; 598 XPUSHs(sv); 599 RETURN; 600 } 601 602 /* Pattern matching */ 603 604 PP(pp_study) 605 { 606 dSP; dPOPss; 607 register unsigned char *s; 608 register I32 pos; 609 register I32 ch; 610 register I32 *sfirst; 611 register I32 *snext; 612 STRLEN len; 613 614 if (sv == PL_lastscream) { 615 if (SvSCREAM(sv)) 616 RETPUSHYES; 617 } 618 else { 619 if (PL_lastscream) { 620 SvSCREAM_off(PL_lastscream); 621 SvREFCNT_dec(PL_lastscream); 622 } 623 PL_lastscream = SvREFCNT_inc(sv); 624 } 625 626 s = (unsigned char*)(SvPV(sv, len)); 627 pos = len; 628 if (pos <= 0) 629 RETPUSHNO; 630 if (pos > PL_maxscream) { 631 if (PL_maxscream < 0) { 632 PL_maxscream = pos + 80; 633 New(301, PL_screamfirst, 256, I32); 634 New(302, PL_screamnext, PL_maxscream, I32); 635 } 636 else { 637 PL_maxscream = pos + pos / 4; 638 Renew(PL_screamnext, PL_maxscream, I32); 639 } 640 } 641 642 sfirst = PL_screamfirst; 643 snext = PL_screamnext; 644 645 if (!sfirst || !snext) 646 DIE(aTHX_ "do_study: out of memory"); 647 648 for (ch = 256; ch; --ch) 649 *sfirst++ = -1; 650 sfirst -= 256; 651 652 while (--pos >= 0) { 653 ch = s[pos]; 654 if (sfirst[ch] >= 0) 655 snext[pos] = sfirst[ch] - pos; 656 else 657 snext[pos] = -pos; 658 sfirst[ch] = pos; 659 } 660 661 SvSCREAM_on(sv); 662 /* piggyback on m//g magic */ 663 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0); 664 RETPUSHYES; 665 } 666 667 PP(pp_trans) 668 { 669 dSP; dTARG; 670 SV *sv; 671 672 if (PL_op->op_flags & OPf_STACKED) 673 sv = POPs; 674 else { 675 sv = DEFSV; 676 EXTEND(SP,1); 677 } 678 TARG = sv_newmortal(); 679 PUSHi(do_trans(sv)); 680 RETURN; 681 } 682 683 /* Lvalue operators. */ 684 685 PP(pp_schop) 686 { 687 dSP; dTARGET; 688 do_chop(TARG, TOPs); 689 SETTARG; 690 RETURN; 691 } 692 693 PP(pp_chop) 694 { 695 dSP; dMARK; dTARGET; dORIGMARK; 696 while (MARK < SP) 697 do_chop(TARG, *++MARK); 698 SP = ORIGMARK; 699 PUSHTARG; 700 RETURN; 701 } 702 703 PP(pp_schomp) 704 { 705 dSP; dTARGET; 706 SETi(do_chomp(TOPs)); 707 RETURN; 708 } 709 710 PP(pp_chomp) 711 { 712 dSP; dMARK; dTARGET; 713 register I32 count = 0; 714 715 while (SP > MARK) 716 count += do_chomp(POPs); 717 PUSHi(count); 718 RETURN; 719 } 720 721 PP(pp_defined) 722 { 723 dSP; 724 register SV* sv; 725 726 sv = POPs; 727 if (!sv || !SvANY(sv)) 728 RETPUSHNO; 729 switch (SvTYPE(sv)) { 730 case SVt_PVAV: 731 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) 732 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied))) 733 RETPUSHYES; 734 break; 735 case SVt_PVHV: 736 if (HvARRAY(sv) || SvGMAGICAL(sv) 737 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied))) 738 RETPUSHYES; 739 break; 740 case SVt_PVCV: 741 if (CvROOT(sv) || CvXSUB(sv)) 742 RETPUSHYES; 743 break; 744 default: 745 if (SvGMAGICAL(sv)) 746 mg_get(sv); 747 if (SvOK(sv)) 748 RETPUSHYES; 749 } 750 RETPUSHNO; 751 } 752 753 PP(pp_undef) 754 { 755 dSP; 756 SV *sv; 757 758 if (!PL_op->op_private) { 759 EXTEND(SP, 1); 760 RETPUSHUNDEF; 761 } 762 763 sv = POPs; 764 if (!sv) 765 RETPUSHUNDEF; 766 767 if (SvTHINKFIRST(sv)) 768 sv_force_normal(sv); 769 770 switch (SvTYPE(sv)) { 771 case SVt_NULL: 772 break; 773 case SVt_PVAV: 774 av_undef((AV*)sv); 775 break; 776 case SVt_PVHV: 777 hv_undef((HV*)sv); 778 break; 779 case SVt_PVCV: 780 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv)) 781 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined", 782 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv))); 783 /* FALL THROUGH */ 784 case SVt_PVFM: 785 { 786 /* let user-undef'd sub keep its identity */ 787 GV* gv = CvGV((CV*)sv); 788 cv_undef((CV*)sv); 789 CvGV((CV*)sv) = gv; 790 } 791 break; 792 case SVt_PVGV: 793 if (SvFAKE(sv)) 794 SvSetMagicSV(sv, &PL_sv_undef); 795 else { 796 GP *gp; 797 gp_free((GV*)sv); 798 Newz(602, gp, 1, GP); 799 GvGP(sv) = gp_ref(gp); 800 GvSV(sv) = NEWSV(72,0); 801 GvLINE(sv) = CopLINE(PL_curcop); 802 GvEGV(sv) = (GV*)sv; 803 GvMULTI_on(sv); 804 } 805 break; 806 default: 807 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) { 808 (void)SvOOK_off(sv); 809 Safefree(SvPVX(sv)); 810 SvPV_set(sv, Nullch); 811 SvLEN_set(sv, 0); 812 } 813 (void)SvOK_off(sv); 814 SvSETMAGIC(sv); 815 } 816 817 RETPUSHUNDEF; 818 } 819 820 PP(pp_predec) 821 { 822 dSP; 823 if (SvTYPE(TOPs) > SVt_PVLV) 824 DIE(aTHX_ PL_no_modify); 825 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) 826 && SvIVX(TOPs) != IV_MIN) 827 { 828 --SvIVX(TOPs); 829 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); 830 } 831 else 832 sv_dec(TOPs); 833 SvSETMAGIC(TOPs); 834 return NORMAL; 835 } 836 837 PP(pp_postinc) 838 { 839 dSP; dTARGET; 840 if (SvTYPE(TOPs) > SVt_PVLV) 841 DIE(aTHX_ PL_no_modify); 842 sv_setsv(TARG, TOPs); 843 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) 844 && SvIVX(TOPs) != IV_MAX) 845 { 846 ++SvIVX(TOPs); 847 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); 848 } 849 else 850 sv_inc(TOPs); 851 SvSETMAGIC(TOPs); 852 if (!SvOK(TARG)) 853 sv_setiv(TARG, 0); 854 SETs(TARG); 855 return NORMAL; 856 } 857 858 PP(pp_postdec) 859 { 860 dSP; dTARGET; 861 if (SvTYPE(TOPs) > SVt_PVLV) 862 DIE(aTHX_ PL_no_modify); 863 sv_setsv(TARG, TOPs); 864 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) 865 && SvIVX(TOPs) != IV_MIN) 866 { 867 --SvIVX(TOPs); 868 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); 869 } 870 else 871 sv_dec(TOPs); 872 SvSETMAGIC(TOPs); 873 SETs(TARG); 874 return NORMAL; 875 } 876 877 /* Ordinary operators. */ 878 879 PP(pp_pow) 880 { 881 dSP; dATARGET; tryAMAGICbin(pow,opASSIGN); 882 #ifdef PERL_PRESERVE_IVUV 883 /* ** is implemented with pow. pow is floating point. Perl programmers 884 write 2 ** 31 and expect it to be 2147483648 885 pow never made any guarantee to deliver a result to 53 (or whatever) 886 bits of accuracy. Which is unfortunate, as perl programmers expect it 887 to, and on some platforms (eg Irix with long doubles) it doesn't in 888 a very visible case. (2 ** 31, which a regression test uses) 889 So we'll implement power-of-2 ** +ve integer with multiplies, to avoid 890 these problems. */ 891 { 892 SvIV_please(TOPm1s); 893 if (SvIOK(TOPm1s)) { 894 bool baseuok = SvUOK(TOPm1s); 895 UV baseuv; 896 897 if (baseuok) { 898 baseuv = SvUVX(TOPm1s); 899 } else { 900 IV iv = SvIVX(TOPm1s); 901 if (iv >= 0) { 902 baseuv = iv; 903 baseuok = TRUE; /* effectively it's a UV now */ 904 } else { 905 baseuv = -iv; /* abs, baseuok == false records sign */ 906 } 907 } 908 SvIV_please(TOPs); 909 if (SvIOK(TOPs)) { 910 UV power; 911 912 if (SvUOK(TOPs)) { 913 power = SvUVX(TOPs); 914 } else { 915 IV iv = SvIVX(TOPs); 916 if (iv >= 0) { 917 power = iv; 918 } else { 919 goto float_it; /* Can't do negative powers this way. */ 920 } 921 } 922 /* now we have integer ** positive integer. 923 foo & (foo - 1) is zero only for a power of 2. */ 924 if (!(baseuv & (baseuv - 1))) { 925 /* We are raising power-of-2 to postive integer. 926 The logic here will work for any base (even non-integer 927 bases) but it can be less accurate than 928 pow (base,power) or exp (power * log (base)) when the 929 intermediate values start to spill out of the mantissa. 930 With powers of 2 we know this can't happen. 931 And powers of 2 are the favourite thing for perl 932 programmers to notice ** not doing what they mean. */ 933 NV result = 1.0; 934 NV base = baseuok ? baseuv : -(NV)baseuv; 935 int n = 0; 936 937 /* The logic is this. 938 x ** n === x ** m1 * x ** m2 where n = m1 + m2 939 so as 42 is 32 + 8 + 2 940 x ** 42 can be written as 941 x ** 32 * x ** 8 * x ** 2 942 I can calculate x ** 2, x ** 4, x ** 8 etc trivially: 943 x ** 2n is x ** n * x ** n 944 So I loop round, squaring x each time 945 (x, x ** 2, x ** 4, x ** 8) and multiply the result 946 by the x-value whenever that bit is set in the power. 947 To finish as soon as possible I zero bits in the power 948 when I've done them, so that power becomes zero when 949 I clear the last bit (no more to do), and the loop 950 terminates. */ 951 for (; power; base *= base, n++) { 952 /* Do I look like I trust gcc with long longs here? 953 Do I hell. */ 954 UV bit = (UV)1 << (UV)n; 955 if (power & bit) { 956 result *= base; 957 /* Only bother to clear the bit if it is set. */ 958 power &= ~bit; 959 /* Avoid squaring base again if we're done. */ 960 if (power == 0) break; 961 } 962 } 963 SP--; 964 SETn( result ); 965 RETURN; 966 } 967 } 968 } 969 } 970 float_it: 971 #endif 972 { 973 dPOPTOPnnrl; 974 SETn( Perl_pow( left, right) ); 975 RETURN; 976 } 977 } 978 979 PP(pp_multiply) 980 { 981 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN); 982 #ifdef PERL_PRESERVE_IVUV 983 SvIV_please(TOPs); 984 if (SvIOK(TOPs)) { 985 /* Unless the left argument is integer in range we are going to have to 986 use NV maths. Hence only attempt to coerce the right argument if 987 we know the left is integer. */ 988 /* Left operand is defined, so is it IV? */ 989 SvIV_please(TOPm1s); 990 if (SvIOK(TOPm1s)) { 991 bool auvok = SvUOK(TOPm1s); 992 bool buvok = SvUOK(TOPs); 993 const UV topmask = (~ (UV)0) << (4 * sizeof (UV)); 994 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV))); 995 UV alow; 996 UV ahigh; 997 UV blow; 998 UV bhigh; 999 1000 if (auvok) { 1001 alow = SvUVX(TOPm1s); 1002 } else { 1003 IV aiv = SvIVX(TOPm1s); 1004 if (aiv >= 0) { 1005 alow = aiv; 1006 auvok = TRUE; /* effectively it's a UV now */ 1007 } else { 1008 alow = -aiv; /* abs, auvok == false records sign */ 1009 } 1010 } 1011 if (buvok) { 1012 blow = SvUVX(TOPs); 1013 } else { 1014 IV biv = SvIVX(TOPs); 1015 if (biv >= 0) { 1016 blow = biv; 1017 buvok = TRUE; /* effectively it's a UV now */ 1018 } else { 1019 blow = -biv; /* abs, buvok == false records sign */ 1020 } 1021 } 1022 1023 /* If this does sign extension on unsigned it's time for plan B */ 1024 ahigh = alow >> (4 * sizeof (UV)); 1025 alow &= botmask; 1026 bhigh = blow >> (4 * sizeof (UV)); 1027 blow &= botmask; 1028 if (ahigh && bhigh) { 1029 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000 1030 which is overflow. Drop to NVs below. */ 1031 } else if (!ahigh && !bhigh) { 1032 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001 1033 so the unsigned multiply cannot overflow. */ 1034 UV product = alow * blow; 1035 if (auvok == buvok) { 1036 /* -ve * -ve or +ve * +ve gives a +ve result. */ 1037 SP--; 1038 SETu( product ); 1039 RETURN; 1040 } else if (product <= (UV)IV_MIN) { 1041 /* 2s complement assumption that (UV)-IV_MIN is correct. */ 1042 /* -ve result, which could overflow an IV */ 1043 SP--; 1044 SETi( -(IV)product ); 1045 RETURN; 1046 } /* else drop to NVs below. */ 1047 } else { 1048 /* One operand is large, 1 small */ 1049 UV product_middle; 1050 if (bhigh) { 1051 /* swap the operands */ 1052 ahigh = bhigh; 1053 bhigh = blow; /* bhigh now the temp var for the swap */ 1054 blow = alow; 1055 alow = bhigh; 1056 } 1057 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow) 1058 multiplies can't overflow. shift can, add can, -ve can. */ 1059 product_middle = ahigh * blow; 1060 if (!(product_middle & topmask)) { 1061 /* OK, (ahigh * blow) won't lose bits when we shift it. */ 1062 UV product_low; 1063 product_middle <<= (4 * sizeof (UV)); 1064 product_low = alow * blow; 1065 1066 /* as for pp_add, UV + something mustn't get smaller. 1067 IIRC ANSI mandates this wrapping *behaviour* for 1068 unsigned whatever the actual representation*/ 1069 product_low += product_middle; 1070 if (product_low >= product_middle) { 1071 /* didn't overflow */ 1072 if (auvok == buvok) { 1073 /* -ve * -ve or +ve * +ve gives a +ve result. */ 1074 SP--; 1075 SETu( product_low ); 1076 RETURN; 1077 } else if (product_low <= (UV)IV_MIN) { 1078 /* 2s complement assumption again */ 1079 /* -ve result, which could overflow an IV */ 1080 SP--; 1081 SETi( -(IV)product_low ); 1082 RETURN; 1083 } /* else drop to NVs below. */ 1084 } 1085 } /* product_middle too large */ 1086 } /* ahigh && bhigh */ 1087 } /* SvIOK(TOPm1s) */ 1088 } /* SvIOK(TOPs) */ 1089 #endif 1090 { 1091 dPOPTOPnnrl; 1092 SETn( left * right ); 1093 RETURN; 1094 } 1095 } 1096 1097 PP(pp_divide) 1098 { 1099 dSP; dATARGET; tryAMAGICbin(div,opASSIGN); 1100 /* Only try to do UV divide first 1101 if ((SLOPPYDIVIDE is true) or 1102 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large 1103 to preserve)) 1104 The assumption is that it is better to use floating point divide 1105 whenever possible, only doing integer divide first if we can't be sure. 1106 If NV_PRESERVES_UV is true then we know at compile time that no UV 1107 can be too large to preserve, so don't need to compile the code to 1108 test the size of UVs. */ 1109 1110 #ifdef SLOPPYDIVIDE 1111 # define PERL_TRY_UV_DIVIDE 1112 /* ensure that 20./5. == 4. */ 1113 #else 1114 # ifdef PERL_PRESERVE_IVUV 1115 # ifndef NV_PRESERVES_UV 1116 # define PERL_TRY_UV_DIVIDE 1117 # endif 1118 # endif 1119 #endif 1120 1121 #ifdef PERL_TRY_UV_DIVIDE 1122 SvIV_please(TOPs); 1123 if (SvIOK(TOPs)) { 1124 SvIV_please(TOPm1s); 1125 if (SvIOK(TOPm1s)) { 1126 bool left_non_neg = SvUOK(TOPm1s); 1127 bool right_non_neg = SvUOK(TOPs); 1128 UV left; 1129 UV right; 1130 1131 if (right_non_neg) { 1132 right = SvUVX(TOPs); 1133 } 1134 else { 1135 IV biv = SvIVX(TOPs); 1136 if (biv >= 0) { 1137 right = biv; 1138 right_non_neg = TRUE; /* effectively it's a UV now */ 1139 } 1140 else { 1141 right = -biv; 1142 } 1143 } 1144 /* historically undef()/0 gives a "Use of uninitialized value" 1145 warning before dieing, hence this test goes here. 1146 If it were immediately before the second SvIV_please, then 1147 DIE() would be invoked before left was even inspected, so 1148 no inpsection would give no warning. */ 1149 if (right == 0) 1150 DIE(aTHX_ "Illegal division by zero"); 1151 1152 if (left_non_neg) { 1153 left = SvUVX(TOPm1s); 1154 } 1155 else { 1156 IV aiv = SvIVX(TOPm1s); 1157 if (aiv >= 0) { 1158 left = aiv; 1159 left_non_neg = TRUE; /* effectively it's a UV now */ 1160 } 1161 else { 1162 left = -aiv; 1163 } 1164 } 1165 1166 if (left >= right 1167 #ifdef SLOPPYDIVIDE 1168 /* For sloppy divide we always attempt integer division. */ 1169 #else 1170 /* Otherwise we only attempt it if either or both operands 1171 would not be preserved by an NV. If both fit in NVs 1172 we fall through to the NV divide code below. However, 1173 as left >= right to ensure integer result here, we know that 1174 we can skip the test on the right operand - right big 1175 enough not to be preserved can't get here unless left is 1176 also too big. */ 1177 1178 && (left > ((UV)1 << NV_PRESERVES_UV_BITS)) 1179 #endif 1180 ) { 1181 /* Integer division can't overflow, but it can be imprecise. */ 1182 UV result = left / right; 1183 if (result * right == left) { 1184 SP--; /* result is valid */ 1185 if (left_non_neg == right_non_neg) { 1186 /* signs identical, result is positive. */ 1187 SETu( result ); 1188 RETURN; 1189 } 1190 /* 2s complement assumption */ 1191 if (result <= (UV)IV_MIN) 1192 SETi( -(IV)result ); 1193 else { 1194 /* It's exact but too negative for IV. */ 1195 SETn( -(NV)result ); 1196 } 1197 RETURN; 1198 } /* tried integer divide but it was not an integer result */ 1199 } /* else (abs(result) < 1.0) or (both UVs in range for NV) */ 1200 } /* left wasn't SvIOK */ 1201 } /* right wasn't SvIOK */ 1202 #endif /* PERL_TRY_UV_DIVIDE */ 1203 { 1204 dPOPPOPnnrl; 1205 if (right == 0.0) 1206 DIE(aTHX_ "Illegal division by zero"); 1207 PUSHn( left / right ); 1208 RETURN; 1209 } 1210 } 1211 1212 PP(pp_modulo) 1213 { 1214 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); 1215 { 1216 UV left = 0; 1217 UV right = 0; 1218 bool left_neg = FALSE; 1219 bool right_neg = FALSE; 1220 bool use_double = FALSE; 1221 bool dright_valid = FALSE; 1222 NV dright = 0.0; 1223 NV dleft = 0.0; 1224 1225 SvIV_please(TOPs); 1226 if (SvIOK(TOPs)) { 1227 right_neg = !SvUOK(TOPs); 1228 if (!right_neg) { 1229 right = SvUVX(POPs); 1230 } else { 1231 IV biv = SvIVX(POPs); 1232 if (biv >= 0) { 1233 right = biv; 1234 right_neg = FALSE; /* effectively it's a UV now */ 1235 } else { 1236 right = -biv; 1237 } 1238 } 1239 } 1240 else { 1241 dright = POPn; 1242 right_neg = dright < 0; 1243 if (right_neg) 1244 dright = -dright; 1245 if (dright < UV_MAX_P1) { 1246 right = U_V(dright); 1247 dright_valid = TRUE; /* In case we need to use double below. */ 1248 } else { 1249 use_double = TRUE; 1250 } 1251 } 1252 1253 /* At this point use_double is only true if right is out of range for 1254 a UV. In range NV has been rounded down to nearest UV and 1255 use_double false. */ 1256 SvIV_please(TOPs); 1257 if (!use_double && SvIOK(TOPs)) { 1258 if (SvIOK(TOPs)) { 1259 left_neg = !SvUOK(TOPs); 1260 if (!left_neg) { 1261 left = SvUVX(POPs); 1262 } else { 1263 IV aiv = SvIVX(POPs); 1264 if (aiv >= 0) { 1265 left = aiv; 1266 left_neg = FALSE; /* effectively it's a UV now */ 1267 } else { 1268 left = -aiv; 1269 } 1270 } 1271 } 1272 } 1273 else { 1274 dleft = POPn; 1275 left_neg = dleft < 0; 1276 if (left_neg) 1277 dleft = -dleft; 1278 1279 /* This should be exactly the 5.6 behaviour - if left and right are 1280 both in range for UV then use U_V() rather than floor. */ 1281 if (!use_double) { 1282 if (dleft < UV_MAX_P1) { 1283 /* right was in range, so is dleft, so use UVs not double. 1284 */ 1285 left = U_V(dleft); 1286 } 1287 /* left is out of range for UV, right was in range, so promote 1288 right (back) to double. */ 1289 else { 1290 /* The +0.5 is used in 5.6 even though it is not strictly 1291 consistent with the implicit +0 floor in the U_V() 1292 inside the #if 1. */ 1293 dleft = Perl_floor(dleft + 0.5); 1294 use_double = TRUE; 1295 if (dright_valid) 1296 dright = Perl_floor(dright + 0.5); 1297 else 1298 dright = right; 1299 } 1300 } 1301 } 1302 if (use_double) { 1303 NV dans; 1304 1305 if (!dright) 1306 DIE(aTHX_ "Illegal modulus zero"); 1307 1308 dans = Perl_fmod(dleft, dright); 1309 if ((left_neg != right_neg) && dans) 1310 dans = dright - dans; 1311 if (right_neg) 1312 dans = -dans; 1313 sv_setnv(TARG, dans); 1314 } 1315 else { 1316 UV ans; 1317 1318 if (!right) 1319 DIE(aTHX_ "Illegal modulus zero"); 1320 1321 ans = left % right; 1322 if ((left_neg != right_neg) && ans) 1323 ans = right - ans; 1324 if (right_neg) { 1325 /* XXX may warn: unary minus operator applied to unsigned type */ 1326 /* could change -foo to be (~foo)+1 instead */ 1327 if (ans <= ~((UV)IV_MAX)+1) 1328 sv_setiv(TARG, ~ans+1); 1329 else 1330 sv_setnv(TARG, -(NV)ans); 1331 } 1332 else 1333 sv_setuv(TARG, ans); 1334 } 1335 PUSHTARG; 1336 RETURN; 1337 } 1338 } 1339 1340 PP(pp_repeat) 1341 { 1342 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN); 1343 { 1344 register IV count = POPi; 1345 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) { 1346 dMARK; 1347 I32 items = SP - MARK; 1348 I32 max; 1349 1350 max = items * count; 1351 MEXTEND(MARK, max); 1352 if (count > 1) { 1353 while (SP > MARK) { 1354 #if 0 1355 /* This code was intended to fix 20010809.028: 1356 1357 $x = 'abcd'; 1358 for (($x =~ /./g) x 2) { 1359 print chop; # "abcdabcd" expected as output. 1360 } 1361 1362 * but that change (#11635) broke this code: 1363 1364 $x = [("foo")x2]; # only one "foo" ended up in the anonlist. 1365 1366 * I can't think of a better fix that doesn't introduce 1367 * an efficiency hit by copying the SVs. The stack isn't 1368 * refcounted, and mortalisation obviously doesn't 1369 * Do The Right Thing when the stack has more than 1370 * one pointer to the same mortal value. 1371 * .robin. 1372 */ 1373 if (*SP) { 1374 *SP = sv_2mortal(newSVsv(*SP)); 1375 SvREADONLY_on(*SP); 1376 } 1377 #else 1378 if (*SP) 1379 SvTEMP_off((*SP)); 1380 #endif 1381 SP--; 1382 } 1383 MARK++; 1384 repeatcpy((char*)(MARK + items), (char*)MARK, 1385 items * sizeof(SV*), count - 1); 1386 SP += max; 1387 } 1388 else if (count <= 0) 1389 SP -= items; 1390 } 1391 else { /* Note: mark already snarfed by pp_list */ 1392 SV *tmpstr = POPs; 1393 STRLEN len; 1394 bool isutf; 1395 1396 SvSetSV(TARG, tmpstr); 1397 SvPV_force(TARG, len); 1398 isutf = DO_UTF8(TARG); 1399 if (count != 1) { 1400 if (count < 1) 1401 SvCUR_set(TARG, 0); 1402 else { 1403 SvGROW(TARG, (count * len) + 1); 1404 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1); 1405 SvCUR(TARG) *= count; 1406 } 1407 *SvEND(TARG) = '\0'; 1408 } 1409 if (isutf) 1410 (void)SvPOK_only_UTF8(TARG); 1411 else 1412 (void)SvPOK_only(TARG); 1413 1414 if (PL_op->op_private & OPpREPEAT_DOLIST) { 1415 /* The parser saw this as a list repeat, and there 1416 are probably several items on the stack. But we're 1417 in scalar context, and there's no pp_list to save us 1418 now. So drop the rest of the items -- robin@kitsite.com 1419 */ 1420 dMARK; 1421 SP = MARK; 1422 } 1423 PUSHTARG; 1424 } 1425 RETURN; 1426 } 1427 } 1428 1429 PP(pp_subtract) 1430 { 1431 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN); 1432 useleft = USE_LEFT(TOPm1s); 1433 #ifdef PERL_PRESERVE_IVUV 1434 /* See comments in pp_add (in pp_hot.c) about Overflow, and how 1435 "bad things" happen if you rely on signed integers wrapping. */ 1436 SvIV_please(TOPs); 1437 if (SvIOK(TOPs)) { 1438 /* Unless the left argument is integer in range we are going to have to 1439 use NV maths. Hence only attempt to coerce the right argument if 1440 we know the left is integer. */ 1441 register UV auv = 0; 1442 bool auvok = FALSE; 1443 bool a_valid = 0; 1444 1445 if (!useleft) { 1446 auv = 0; 1447 a_valid = auvok = 1; 1448 /* left operand is undef, treat as zero. */ 1449 } else { 1450 /* Left operand is defined, so is it IV? */ 1451 SvIV_please(TOPm1s); 1452 if (SvIOK(TOPm1s)) { 1453 if ((auvok = SvUOK(TOPm1s))) 1454 auv = SvUVX(TOPm1s); 1455 else { 1456 register IV aiv = SvIVX(TOPm1s); 1457 if (aiv >= 0) { 1458 auv = aiv; 1459 auvok = 1; /* Now acting as a sign flag. */ 1460 } else { /* 2s complement assumption for IV_MIN */ 1461 auv = (UV)-aiv; 1462 } 1463 } 1464 a_valid = 1; 1465 } 1466 } 1467 if (a_valid) { 1468 bool result_good = 0; 1469 UV result; 1470 register UV buv; 1471 bool buvok = SvUOK(TOPs); 1472 1473 if (buvok) 1474 buv = SvUVX(TOPs); 1475 else { 1476 register IV biv = SvIVX(TOPs); 1477 if (biv >= 0) { 1478 buv = biv; 1479 buvok = 1; 1480 } else 1481 buv = (UV)-biv; 1482 } 1483 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve, 1484 else "IV" now, independent of how it came in. 1485 if a, b represents positive, A, B negative, a maps to -A etc 1486 a - b => (a - b) 1487 A - b => -(a + b) 1488 a - B => (a + b) 1489 A - B => -(a - b) 1490 all UV maths. negate result if A negative. 1491 subtract if signs same, add if signs differ. */ 1492 1493 if (auvok ^ buvok) { 1494 /* Signs differ. */ 1495 result = auv + buv; 1496 if (result >= auv) 1497 result_good = 1; 1498 } else { 1499 /* Signs same */ 1500 if (auv >= buv) { 1501 result = auv - buv; 1502 /* Must get smaller */ 1503 if (result <= auv) 1504 result_good = 1; 1505 } else { 1506 result = buv - auv; 1507 if (result <= buv) { 1508 /* result really should be -(auv-buv). as its negation 1509 of true value, need to swap our result flag */ 1510 auvok = !auvok; 1511 result_good = 1; 1512 } 1513 } 1514 } 1515 if (result_good) { 1516 SP--; 1517 if (auvok) 1518 SETu( result ); 1519 else { 1520 /* Negate result */ 1521 if (result <= (UV)IV_MIN) 1522 SETi( -(IV)result ); 1523 else { 1524 /* result valid, but out of range for IV. */ 1525 SETn( -(NV)result ); 1526 } 1527 } 1528 RETURN; 1529 } /* Overflow, drop through to NVs. */ 1530 } 1531 } 1532 #endif 1533 useleft = USE_LEFT(TOPm1s); 1534 { 1535 dPOPnv; 1536 if (!useleft) { 1537 /* left operand is undef, treat as zero - value */ 1538 SETn(-value); 1539 RETURN; 1540 } 1541 SETn( TOPn - value ); 1542 RETURN; 1543 } 1544 } 1545 1546 PP(pp_left_shift) 1547 { 1548 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN); 1549 { 1550 IV shift = POPi; 1551 if (PL_op->op_private & HINT_INTEGER) { 1552 IV i = TOPi; 1553 SETi(i << shift); 1554 } 1555 else { 1556 UV u = TOPu; 1557 SETu(u << shift); 1558 } 1559 RETURN; 1560 } 1561 } 1562 1563 PP(pp_right_shift) 1564 { 1565 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN); 1566 { 1567 IV shift = POPi; 1568 if (PL_op->op_private & HINT_INTEGER) { 1569 IV i = TOPi; 1570 SETi(i >> shift); 1571 } 1572 else { 1573 UV u = TOPu; 1574 SETu(u >> shift); 1575 } 1576 RETURN; 1577 } 1578 } 1579 1580 PP(pp_lt) 1581 { 1582 dSP; tryAMAGICbinSET(lt,0); 1583 #ifdef PERL_PRESERVE_IVUV 1584 SvIV_please(TOPs); 1585 if (SvIOK(TOPs)) { 1586 SvIV_please(TOPm1s); 1587 if (SvIOK(TOPm1s)) { 1588 bool auvok = SvUOK(TOPm1s); 1589 bool buvok = SvUOK(TOPs); 1590 1591 if (!auvok && !buvok) { /* ## IV < IV ## */ 1592 IV aiv = SvIVX(TOPm1s); 1593 IV biv = SvIVX(TOPs); 1594 1595 SP--; 1596 SETs(boolSV(aiv < biv)); 1597 RETURN; 1598 } 1599 if (auvok && buvok) { /* ## UV < UV ## */ 1600 UV auv = SvUVX(TOPm1s); 1601 UV buv = SvUVX(TOPs); 1602 1603 SP--; 1604 SETs(boolSV(auv < buv)); 1605 RETURN; 1606 } 1607 if (auvok) { /* ## UV < IV ## */ 1608 UV auv; 1609 IV biv; 1610 1611 biv = SvIVX(TOPs); 1612 SP--; 1613 if (biv < 0) { 1614 /* As (a) is a UV, it's >=0, so it cannot be < */ 1615 SETs(&PL_sv_no); 1616 RETURN; 1617 } 1618 auv = SvUVX(TOPs); 1619 SETs(boolSV(auv < (UV)biv)); 1620 RETURN; 1621 } 1622 { /* ## IV < UV ## */ 1623 IV aiv; 1624 UV buv; 1625 1626 aiv = SvIVX(TOPm1s); 1627 if (aiv < 0) { 1628 /* As (b) is a UV, it's >=0, so it must be < */ 1629 SP--; 1630 SETs(&PL_sv_yes); 1631 RETURN; 1632 } 1633 buv = SvUVX(TOPs); 1634 SP--; 1635 SETs(boolSV((UV)aiv < buv)); 1636 RETURN; 1637 } 1638 } 1639 } 1640 #endif 1641 #ifndef NV_PRESERVES_UV 1642 #ifdef PERL_PRESERVE_IVUV 1643 else 1644 #endif 1645 if (SvROK(TOPs) && SvROK(TOPm1s)) { 1646 SP--; 1647 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s))); 1648 RETURN; 1649 } 1650 #endif 1651 { 1652 dPOPnv; 1653 SETs(boolSV(TOPn < value)); 1654 RETURN; 1655 } 1656 } 1657 1658 PP(pp_gt) 1659 { 1660 dSP; tryAMAGICbinSET(gt,0); 1661 #ifdef PERL_PRESERVE_IVUV 1662 SvIV_please(TOPs); 1663 if (SvIOK(TOPs)) { 1664 SvIV_please(TOPm1s); 1665 if (SvIOK(TOPm1s)) { 1666 bool auvok = SvUOK(TOPm1s); 1667 bool buvok = SvUOK(TOPs); 1668 1669 if (!auvok && !buvok) { /* ## IV > IV ## */ 1670 IV aiv = SvIVX(TOPm1s); 1671 IV biv = SvIVX(TOPs); 1672 1673 SP--; 1674 SETs(boolSV(aiv > biv)); 1675 RETURN; 1676 } 1677 if (auvok && buvok) { /* ## UV > UV ## */ 1678 UV auv = SvUVX(TOPm1s); 1679 UV buv = SvUVX(TOPs); 1680 1681 SP--; 1682 SETs(boolSV(auv > buv)); 1683 RETURN; 1684 } 1685 if (auvok) { /* ## UV > IV ## */ 1686 UV auv; 1687 IV biv; 1688 1689 biv = SvIVX(TOPs); 1690 SP--; 1691 if (biv < 0) { 1692 /* As (a) is a UV, it's >=0, so it must be > */ 1693 SETs(&PL_sv_yes); 1694 RETURN; 1695 } 1696 auv = SvUVX(TOPs); 1697 SETs(boolSV(auv > (UV)biv)); 1698 RETURN; 1699 } 1700 { /* ## IV > UV ## */ 1701 IV aiv; 1702 UV buv; 1703 1704 aiv = SvIVX(TOPm1s); 1705 if (aiv < 0) { 1706 /* As (b) is a UV, it's >=0, so it cannot be > */ 1707 SP--; 1708 SETs(&PL_sv_no); 1709 RETURN; 1710 } 1711 buv = SvUVX(TOPs); 1712 SP--; 1713 SETs(boolSV((UV)aiv > buv)); 1714 RETURN; 1715 } 1716 } 1717 } 1718 #endif 1719 #ifndef NV_PRESERVES_UV 1720 #ifdef PERL_PRESERVE_IVUV 1721 else 1722 #endif 1723 if (SvROK(TOPs) && SvROK(TOPm1s)) { 1724 SP--; 1725 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s))); 1726 RETURN; 1727 } 1728 #endif 1729 { 1730 dPOPnv; 1731 SETs(boolSV(TOPn > value)); 1732 RETURN; 1733 } 1734 } 1735 1736 PP(pp_le) 1737 { 1738 dSP; tryAMAGICbinSET(le,0); 1739 #ifdef PERL_PRESERVE_IVUV 1740 SvIV_please(TOPs); 1741 if (SvIOK(TOPs)) { 1742 SvIV_please(TOPm1s); 1743 if (SvIOK(TOPm1s)) { 1744 bool auvok = SvUOK(TOPm1s); 1745 bool buvok = SvUOK(TOPs); 1746 1747 if (!auvok && !buvok) { /* ## IV <= IV ## */ 1748 IV aiv = SvIVX(TOPm1s); 1749 IV biv = SvIVX(TOPs); 1750 1751 SP--; 1752 SETs(boolSV(aiv <= biv)); 1753 RETURN; 1754 } 1755 if (auvok && buvok) { /* ## UV <= UV ## */ 1756 UV auv = SvUVX(TOPm1s); 1757 UV buv = SvUVX(TOPs); 1758 1759 SP--; 1760 SETs(boolSV(auv <= buv)); 1761 RETURN; 1762 } 1763 if (auvok) { /* ## UV <= IV ## */ 1764 UV auv; 1765 IV biv; 1766 1767 biv = SvIVX(TOPs); 1768 SP--; 1769 if (biv < 0) { 1770 /* As (a) is a UV, it's >=0, so a cannot be <= */ 1771 SETs(&PL_sv_no); 1772 RETURN; 1773 } 1774 auv = SvUVX(TOPs); 1775 SETs(boolSV(auv <= (UV)biv)); 1776 RETURN; 1777 } 1778 { /* ## IV <= UV ## */ 1779 IV aiv; 1780 UV buv; 1781 1782 aiv = SvIVX(TOPm1s); 1783 if (aiv < 0) { 1784 /* As (b) is a UV, it's >=0, so a must be <= */ 1785 SP--; 1786 SETs(&PL_sv_yes); 1787 RETURN; 1788 } 1789 buv = SvUVX(TOPs); 1790 SP--; 1791 SETs(boolSV((UV)aiv <= buv)); 1792 RETURN; 1793 } 1794 } 1795 } 1796 #endif 1797 #ifndef NV_PRESERVES_UV 1798 #ifdef PERL_PRESERVE_IVUV 1799 else 1800 #endif 1801 if (SvROK(TOPs) && SvROK(TOPm1s)) { 1802 SP--; 1803 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s))); 1804 RETURN; 1805 } 1806 #endif 1807 { 1808 dPOPnv; 1809 SETs(boolSV(TOPn <= value)); 1810 RETURN; 1811 } 1812 } 1813 1814 PP(pp_ge) 1815 { 1816 dSP; tryAMAGICbinSET(ge,0); 1817 #ifdef PERL_PRESERVE_IVUV 1818 SvIV_please(TOPs); 1819 if (SvIOK(TOPs)) { 1820 SvIV_please(TOPm1s); 1821 if (SvIOK(TOPm1s)) { 1822 bool auvok = SvUOK(TOPm1s); 1823 bool buvok = SvUOK(TOPs); 1824 1825 if (!auvok && !buvok) { /* ## IV >= IV ## */ 1826 IV aiv = SvIVX(TOPm1s); 1827 IV biv = SvIVX(TOPs); 1828 1829 SP--; 1830 SETs(boolSV(aiv >= biv)); 1831 RETURN; 1832 } 1833 if (auvok && buvok) { /* ## UV >= UV ## */ 1834 UV auv = SvUVX(TOPm1s); 1835 UV buv = SvUVX(TOPs); 1836 1837 SP--; 1838 SETs(boolSV(auv >= buv)); 1839 RETURN; 1840 } 1841 if (auvok) { /* ## UV >= IV ## */ 1842 UV auv; 1843 IV biv; 1844 1845 biv = SvIVX(TOPs); 1846 SP--; 1847 if (biv < 0) { 1848 /* As (a) is a UV, it's >=0, so it must be >= */ 1849 SETs(&PL_sv_yes); 1850 RETURN; 1851 } 1852 auv = SvUVX(TOPs); 1853 SETs(boolSV(auv >= (UV)biv)); 1854 RETURN; 1855 } 1856 { /* ## IV >= UV ## */ 1857 IV aiv; 1858 UV buv; 1859 1860 aiv = SvIVX(TOPm1s); 1861 if (aiv < 0) { 1862 /* As (b) is a UV, it's >=0, so a cannot be >= */ 1863 SP--; 1864 SETs(&PL_sv_no); 1865 RETURN; 1866 } 1867 buv = SvUVX(TOPs); 1868 SP--; 1869 SETs(boolSV((UV)aiv >= buv)); 1870 RETURN; 1871 } 1872 } 1873 } 1874 #endif 1875 #ifndef NV_PRESERVES_UV 1876 #ifdef PERL_PRESERVE_IVUV 1877 else 1878 #endif 1879 if (SvROK(TOPs) && SvROK(TOPm1s)) { 1880 SP--; 1881 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s))); 1882 RETURN; 1883 } 1884 #endif 1885 { 1886 dPOPnv; 1887 SETs(boolSV(TOPn >= value)); 1888 RETURN; 1889 } 1890 } 1891 1892 PP(pp_ne) 1893 { 1894 dSP; tryAMAGICbinSET(ne,0); 1895 #ifndef NV_PRESERVES_UV 1896 if (SvROK(TOPs) && SvROK(TOPm1s)) { 1897 SP--; 1898 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s))); 1899 RETURN; 1900 } 1901 #endif 1902 #ifdef PERL_PRESERVE_IVUV 1903 SvIV_please(TOPs); 1904 if (SvIOK(TOPs)) { 1905 SvIV_please(TOPm1s); 1906 if (SvIOK(TOPm1s)) { 1907 bool auvok = SvUOK(TOPm1s); 1908 bool buvok = SvUOK(TOPs); 1909 1910 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */ 1911 /* Casting IV to UV before comparison isn't going to matter 1912 on 2s complement. On 1s complement or sign&magnitude 1913 (if we have any of them) it could make negative zero 1914 differ from normal zero. As I understand it. (Need to 1915 check - is negative zero implementation defined behaviour 1916 anyway?). NWC */ 1917 UV buv = SvUVX(POPs); 1918 UV auv = SvUVX(TOPs); 1919 1920 SETs(boolSV(auv != buv)); 1921 RETURN; 1922 } 1923 { /* ## Mixed IV,UV ## */ 1924 IV iv; 1925 UV uv; 1926 1927 /* != is commutative so swap if needed (save code) */ 1928 if (auvok) { 1929 /* swap. top of stack (b) is the iv */ 1930 iv = SvIVX(TOPs); 1931 SP--; 1932 if (iv < 0) { 1933 /* As (a) is a UV, it's >0, so it cannot be == */ 1934 SETs(&PL_sv_yes); 1935 RETURN; 1936 } 1937 uv = SvUVX(TOPs); 1938 } else { 1939 iv = SvIVX(TOPm1s); 1940 SP--; 1941 if (iv < 0) { 1942 /* As (b) is a UV, it's >0, so it cannot be == */ 1943 SETs(&PL_sv_yes); 1944 RETURN; 1945 } 1946 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */ 1947 } 1948 SETs(boolSV((UV)iv != uv)); 1949 RETURN; 1950 } 1951 } 1952 } 1953 #endif 1954 { 1955 dPOPnv; 1956 SETs(boolSV(TOPn != value)); 1957 RETURN; 1958 } 1959 } 1960 1961 PP(pp_ncmp) 1962 { 1963 dSP; dTARGET; tryAMAGICbin(ncmp,0); 1964 #ifndef NV_PRESERVES_UV 1965 if (SvROK(TOPs) && SvROK(TOPm1s)) { 1966 UV right = PTR2UV(SvRV(POPs)); 1967 UV left = PTR2UV(SvRV(TOPs)); 1968 SETi((left > right) - (left < right)); 1969 RETURN; 1970 } 1971 #endif 1972 #ifdef PERL_PRESERVE_IVUV 1973 /* Fortunately it seems NaN isn't IOK */ 1974 SvIV_please(TOPs); 1975 if (SvIOK(TOPs)) { 1976 SvIV_please(TOPm1s); 1977 if (SvIOK(TOPm1s)) { 1978 bool leftuvok = SvUOK(TOPm1s); 1979 bool rightuvok = SvUOK(TOPs); 1980 I32 value; 1981 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */ 1982 IV leftiv = SvIVX(TOPm1s); 1983 IV rightiv = SvIVX(TOPs); 1984 1985 if (leftiv > rightiv) 1986 value = 1; 1987 else if (leftiv < rightiv) 1988 value = -1; 1989 else 1990 value = 0; 1991 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */ 1992 UV leftuv = SvUVX(TOPm1s); 1993 UV rightuv = SvUVX(TOPs); 1994 1995 if (leftuv > rightuv) 1996 value = 1; 1997 else if (leftuv < rightuv) 1998 value = -1; 1999 else 2000 value = 0; 2001 } else if (leftuvok) { /* ## UV <=> IV ## */ 2002 UV leftuv; 2003 IV rightiv; 2004 2005 rightiv = SvIVX(TOPs); 2006 if (rightiv < 0) { 2007 /* As (a) is a UV, it's >=0, so it cannot be < */ 2008 value = 1; 2009 } else { 2010 leftuv = SvUVX(TOPm1s); 2011 if (leftuv > (UV)rightiv) { 2012 value = 1; 2013 } else if (leftuv < (UV)rightiv) { 2014 value = -1; 2015 } else { 2016 value = 0; 2017 } 2018 } 2019 } else { /* ## IV <=> UV ## */ 2020 IV leftiv; 2021 UV rightuv; 2022 2023 leftiv = SvIVX(TOPm1s); 2024 if (leftiv < 0) { 2025 /* As (b) is a UV, it's >=0, so it must be < */ 2026 value = -1; 2027 } else { 2028 rightuv = SvUVX(TOPs); 2029 if ((UV)leftiv > rightuv) { 2030 value = 1; 2031 } else if ((UV)leftiv < rightuv) { 2032 value = -1; 2033 } else { 2034 value = 0; 2035 } 2036 } 2037 } 2038 SP--; 2039 SETi(value); 2040 RETURN; 2041 } 2042 } 2043 #endif 2044 { 2045 dPOPTOPnnrl; 2046 I32 value; 2047 2048 #ifdef Perl_isnan 2049 if (Perl_isnan(left) || Perl_isnan(right)) { 2050 SETs(&PL_sv_undef); 2051 RETURN; 2052 } 2053 value = (left > right) - (left < right); 2054 #else 2055 if (left == right) 2056 value = 0; 2057 else if (left < right) 2058 value = -1; 2059 else if (left > right) 2060 value = 1; 2061 else { 2062 SETs(&PL_sv_undef); 2063 RETURN; 2064 } 2065 #endif 2066 SETi(value); 2067 RETURN; 2068 } 2069 } 2070 2071 PP(pp_slt) 2072 { 2073 dSP; tryAMAGICbinSET(slt,0); 2074 { 2075 dPOPTOPssrl; 2076 int cmp = (IN_LOCALE_RUNTIME 2077 ? sv_cmp_locale(left, right) 2078 : sv_cmp(left, right)); 2079 SETs(boolSV(cmp < 0)); 2080 RETURN; 2081 } 2082 } 2083 2084 PP(pp_sgt) 2085 { 2086 dSP; tryAMAGICbinSET(sgt,0); 2087 { 2088 dPOPTOPssrl; 2089 int cmp = (IN_LOCALE_RUNTIME 2090 ? sv_cmp_locale(left, right) 2091 : sv_cmp(left, right)); 2092 SETs(boolSV(cmp > 0)); 2093 RETURN; 2094 } 2095 } 2096 2097 PP(pp_sle) 2098 { 2099 dSP; tryAMAGICbinSET(sle,0); 2100 { 2101 dPOPTOPssrl; 2102 int cmp = (IN_LOCALE_RUNTIME 2103 ? sv_cmp_locale(left, right) 2104 : sv_cmp(left, right)); 2105 SETs(boolSV(cmp <= 0)); 2106 RETURN; 2107 } 2108 } 2109 2110 PP(pp_sge) 2111 { 2112 dSP; tryAMAGICbinSET(sge,0); 2113 { 2114 dPOPTOPssrl; 2115 int cmp = (IN_LOCALE_RUNTIME 2116 ? sv_cmp_locale(left, right) 2117 : sv_cmp(left, right)); 2118 SETs(boolSV(cmp >= 0)); 2119 RETURN; 2120 } 2121 } 2122 2123 PP(pp_seq) 2124 { 2125 dSP; tryAMAGICbinSET(seq,0); 2126 { 2127 dPOPTOPssrl; 2128 SETs(boolSV(sv_eq(left, right))); 2129 RETURN; 2130 } 2131 } 2132 2133 PP(pp_sne) 2134 { 2135 dSP; tryAMAGICbinSET(sne,0); 2136 { 2137 dPOPTOPssrl; 2138 SETs(boolSV(!sv_eq(left, right))); 2139 RETURN; 2140 } 2141 } 2142 2143 PP(pp_scmp) 2144 { 2145 dSP; dTARGET; tryAMAGICbin(scmp,0); 2146 { 2147 dPOPTOPssrl; 2148 int cmp = (IN_LOCALE_RUNTIME 2149 ? sv_cmp_locale(left, right) 2150 : sv_cmp(left, right)); 2151 SETi( cmp ); 2152 RETURN; 2153 } 2154 } 2155 2156 PP(pp_bit_and) 2157 { 2158 dSP; dATARGET; tryAMAGICbin(band,opASSIGN); 2159 { 2160 dPOPTOPssrl; 2161 if (SvNIOKp(left) || SvNIOKp(right)) { 2162 if (PL_op->op_private & HINT_INTEGER) { 2163 IV i = SvIV(left) & SvIV(right); 2164 SETi(i); 2165 } 2166 else { 2167 UV u = SvUV(left) & SvUV(right); 2168 SETu(u); 2169 } 2170 } 2171 else { 2172 do_vop(PL_op->op_type, TARG, left, right); 2173 SETTARG; 2174 } 2175 RETURN; 2176 } 2177 } 2178 2179 PP(pp_bit_xor) 2180 { 2181 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN); 2182 { 2183 dPOPTOPssrl; 2184 if (SvNIOKp(left) || SvNIOKp(right)) { 2185 if (PL_op->op_private & HINT_INTEGER) { 2186 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right); 2187 SETi(i); 2188 } 2189 else { 2190 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right); 2191 SETu(u); 2192 } 2193 } 2194 else { 2195 do_vop(PL_op->op_type, TARG, left, right); 2196 SETTARG; 2197 } 2198 RETURN; 2199 } 2200 } 2201 2202 PP(pp_bit_or) 2203 { 2204 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN); 2205 { 2206 dPOPTOPssrl; 2207 if (SvNIOKp(left) || SvNIOKp(right)) { 2208 if (PL_op->op_private & HINT_INTEGER) { 2209 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right); 2210 SETi(i); 2211 } 2212 else { 2213 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right); 2214 SETu(u); 2215 } 2216 } 2217 else { 2218 do_vop(PL_op->op_type, TARG, left, right); 2219 SETTARG; 2220 } 2221 RETURN; 2222 } 2223 } 2224 2225 PP(pp_negate) 2226 { 2227 dSP; dTARGET; tryAMAGICun(neg); 2228 { 2229 dTOPss; 2230 int flags = SvFLAGS(sv); 2231 if (SvGMAGICAL(sv)) 2232 mg_get(sv); 2233 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) { 2234 /* It's publicly an integer, or privately an integer-not-float */ 2235 oops_its_an_int: 2236 if (SvIsUV(sv)) { 2237 if (SvIVX(sv) == IV_MIN) { 2238 /* 2s complement assumption. */ 2239 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */ 2240 RETURN; 2241 } 2242 else if (SvUVX(sv) <= IV_MAX) { 2243 SETi(-SvIVX(sv)); 2244 RETURN; 2245 } 2246 } 2247 else if (SvIVX(sv) != IV_MIN) { 2248 SETi(-SvIVX(sv)); 2249 RETURN; 2250 } 2251 #ifdef PERL_PRESERVE_IVUV 2252 else { 2253 SETu((UV)IV_MIN); 2254 RETURN; 2255 } 2256 #endif 2257 } 2258 if (SvNIOKp(sv)) 2259 SETn(-SvNV(sv)); 2260 else if (SvPOKp(sv)) { 2261 STRLEN len; 2262 char *s = SvPV(sv, len); 2263 if (isIDFIRST(*s)) { 2264 sv_setpvn(TARG, "-", 1); 2265 sv_catsv(TARG, sv); 2266 } 2267 else if (*s == '+' || *s == '-') { 2268 sv_setsv(TARG, sv); 2269 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-'; 2270 } 2271 else if (DO_UTF8(sv)) { 2272 SvIV_please(sv); 2273 if (SvIOK(sv)) 2274 goto oops_its_an_int; 2275 if (SvNOK(sv)) 2276 sv_setnv(TARG, -SvNV(sv)); 2277 else { 2278 sv_setpvn(TARG, "-", 1); 2279 sv_catsv(TARG, sv); 2280 } 2281 } 2282 else { 2283 SvIV_please(sv); 2284 if (SvIOK(sv)) 2285 goto oops_its_an_int; 2286 sv_setnv(TARG, -SvNV(sv)); 2287 } 2288 SETTARG; 2289 } 2290 else 2291 SETn(-SvNV(sv)); 2292 } 2293 RETURN; 2294 } 2295 2296 PP(pp_not) 2297 { 2298 dSP; tryAMAGICunSET(not); 2299 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp)); 2300 return NORMAL; 2301 } 2302 2303 PP(pp_complement) 2304 { 2305 dSP; dTARGET; tryAMAGICun(compl); 2306 { 2307 dTOPss; 2308 if (SvNIOKp(sv)) { 2309 if (PL_op->op_private & HINT_INTEGER) { 2310 IV i = ~SvIV(sv); 2311 SETi(i); 2312 } 2313 else { 2314 UV u = ~SvUV(sv); 2315 SETu(u); 2316 } 2317 } 2318 else { 2319 register U8 *tmps; 2320 register I32 anum; 2321 STRLEN len; 2322 2323 SvSetSV(TARG, sv); 2324 tmps = (U8*)SvPV_force(TARG, len); 2325 anum = len; 2326 if (SvUTF8(TARG)) { 2327 /* Calculate exact length, let's not estimate. */ 2328 STRLEN targlen = 0; 2329 U8 *result; 2330 U8 *send; 2331 STRLEN l; 2332 UV nchar = 0; 2333 UV nwide = 0; 2334 2335 send = tmps + len; 2336 while (tmps < send) { 2337 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV); 2338 tmps += UTF8SKIP(tmps); 2339 targlen += UNISKIP(~c); 2340 nchar++; 2341 if (c > 0xff) 2342 nwide++; 2343 } 2344 2345 /* Now rewind strings and write them. */ 2346 tmps -= len; 2347 2348 if (nwide) { 2349 Newz(0, result, targlen + 1, U8); 2350 while (tmps < send) { 2351 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV); 2352 tmps += UTF8SKIP(tmps); 2353 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY); 2354 } 2355 *result = '\0'; 2356 result -= targlen; 2357 sv_setpvn(TARG, (char*)result, targlen); 2358 SvUTF8_on(TARG); 2359 } 2360 else { 2361 Newz(0, result, nchar + 1, U8); 2362 while (tmps < send) { 2363 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY); 2364 tmps += UTF8SKIP(tmps); 2365 *result++ = ~c; 2366 } 2367 *result = '\0'; 2368 result -= nchar; 2369 sv_setpvn(TARG, (char*)result, nchar); 2370 } 2371 Safefree(result); 2372 SETs(TARG); 2373 RETURN; 2374 } 2375 #ifdef LIBERAL 2376 { 2377 register long *tmpl; 2378 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++) 2379 *tmps = ~*tmps; 2380 tmpl = (long*)tmps; 2381 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++) 2382 *tmpl = ~*tmpl; 2383 tmps = (U8*)tmpl; 2384 } 2385 #endif 2386 for ( ; anum > 0; anum--, tmps++) 2387 *tmps = ~*tmps; 2388 2389 SETs(TARG); 2390 } 2391 RETURN; 2392 } 2393 } 2394 2395 /* integer versions of some of the above */ 2396 2397 PP(pp_i_multiply) 2398 { 2399 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN); 2400 { 2401 dPOPTOPiirl; 2402 SETi( left * right ); 2403 RETURN; 2404 } 2405 } 2406 2407 PP(pp_i_divide) 2408 { 2409 dSP; dATARGET; tryAMAGICbin(div,opASSIGN); 2410 { 2411 dPOPiv; 2412 if (value == 0) 2413 DIE(aTHX_ "Illegal division by zero"); 2414 value = POPi / value; 2415 PUSHi( value ); 2416 RETURN; 2417 } 2418 } 2419 2420 PP(pp_i_modulo) 2421 { 2422 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); 2423 { 2424 dPOPTOPiirl; 2425 if (!right) 2426 DIE(aTHX_ "Illegal modulus zero"); 2427 SETi( left % right ); 2428 RETURN; 2429 } 2430 } 2431 2432 PP(pp_i_add) 2433 { 2434 dSP; dATARGET; tryAMAGICbin(add,opASSIGN); 2435 { 2436 dPOPTOPiirl_ul; 2437 SETi( left + right ); 2438 RETURN; 2439 } 2440 } 2441 2442 PP(pp_i_subtract) 2443 { 2444 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); 2445 { 2446 dPOPTOPiirl_ul; 2447 SETi( left - right ); 2448 RETURN; 2449 } 2450 } 2451 2452 PP(pp_i_lt) 2453 { 2454 dSP; tryAMAGICbinSET(lt,0); 2455 { 2456 dPOPTOPiirl; 2457 SETs(boolSV(left < right)); 2458 RETURN; 2459 } 2460 } 2461 2462 PP(pp_i_gt) 2463 { 2464 dSP; tryAMAGICbinSET(gt,0); 2465 { 2466 dPOPTOPiirl; 2467 SETs(boolSV(left > right)); 2468 RETURN; 2469 } 2470 } 2471 2472 PP(pp_i_le) 2473 { 2474 dSP; tryAMAGICbinSET(le,0); 2475 { 2476 dPOPTOPiirl; 2477 SETs(boolSV(left <= right)); 2478 RETURN; 2479 } 2480 } 2481 2482 PP(pp_i_ge) 2483 { 2484 dSP; tryAMAGICbinSET(ge,0); 2485 { 2486 dPOPTOPiirl; 2487 SETs(boolSV(left >= right)); 2488 RETURN; 2489 } 2490 } 2491 2492 PP(pp_i_eq) 2493 { 2494 dSP; tryAMAGICbinSET(eq,0); 2495 { 2496 dPOPTOPiirl; 2497 SETs(boolSV(left == right)); 2498 RETURN; 2499 } 2500 } 2501 2502 PP(pp_i_ne) 2503 { 2504 dSP; tryAMAGICbinSET(ne,0); 2505 { 2506 dPOPTOPiirl; 2507 SETs(boolSV(left != right)); 2508 RETURN; 2509 } 2510 } 2511 2512 PP(pp_i_ncmp) 2513 { 2514 dSP; dTARGET; tryAMAGICbin(ncmp,0); 2515 { 2516 dPOPTOPiirl; 2517 I32 value; 2518 2519 if (left > right) 2520 value = 1; 2521 else if (left < right) 2522 value = -1; 2523 else 2524 value = 0; 2525 SETi(value); 2526 RETURN; 2527 } 2528 } 2529 2530 PP(pp_i_negate) 2531 { 2532 dSP; dTARGET; tryAMAGICun(neg); 2533 SETi(-TOPi); 2534 RETURN; 2535 } 2536 2537 /* High falutin' math. */ 2538 2539 PP(pp_atan2) 2540 { 2541 dSP; dTARGET; tryAMAGICbin(atan2,0); 2542 { 2543 dPOPTOPnnrl; 2544 SETn(Perl_atan2(left, right)); 2545 RETURN; 2546 } 2547 } 2548 2549 PP(pp_sin) 2550 { 2551 dSP; dTARGET; tryAMAGICun(sin); 2552 { 2553 NV value; 2554 value = POPn; 2555 value = Perl_sin(value); 2556 XPUSHn(value); 2557 RETURN; 2558 } 2559 } 2560 2561 PP(pp_cos) 2562 { 2563 dSP; dTARGET; tryAMAGICun(cos); 2564 { 2565 NV value; 2566 value = POPn; 2567 value = Perl_cos(value); 2568 XPUSHn(value); 2569 RETURN; 2570 } 2571 } 2572 2573 /* Support Configure command-line overrides for rand() functions. 2574 After 5.005, perhaps we should replace this by Configure support 2575 for drand48(), random(), or rand(). For 5.005, though, maintain 2576 compatibility by calling rand() but allow the user to override it. 2577 See INSTALL for details. --Andy Dougherty 15 July 1998 2578 */ 2579 /* Now it's after 5.005, and Configure supports drand48() and random(), 2580 in addition to rand(). So the overrides should not be needed any more. 2581 --Jarkko Hietaniemi 27 September 1998 2582 */ 2583 2584 #ifndef HAS_DRAND48_PROTO 2585 extern double drand48 (void); 2586 #endif 2587 2588 PP(pp_rand) 2589 { 2590 dSP; dTARGET; 2591 NV value; 2592 if (MAXARG < 1) 2593 value = 1.0; 2594 else 2595 value = POPn; 2596 if (value == 0.0) 2597 value = 1.0; 2598 if (!PL_srand_called) { 2599 (void)seedDrand01((Rand_seed_t)seed()); 2600 PL_srand_called = TRUE; 2601 } 2602 value *= Drand01(); 2603 XPUSHn(value); 2604 RETURN; 2605 } 2606 2607 PP(pp_srand) 2608 { 2609 dSP; 2610 UV anum; 2611 if (MAXARG < 1) 2612 anum = seed(); 2613 else 2614 anum = POPu; 2615 (void)seedDrand01((Rand_seed_t)anum); 2616 PL_srand_called = TRUE; 2617 EXTEND(SP, 1); 2618 RETPUSHYES; 2619 } 2620 2621 STATIC U32 2622 S_seed(pTHX) 2623 { 2624 /* 2625 * This is really just a quick hack which grabs various garbage 2626 * values. It really should be a real hash algorithm which 2627 * spreads the effect of every input bit onto every output bit, 2628 * if someone who knows about such things would bother to write it. 2629 * Might be a good idea to add that function to CORE as well. 2630 * No numbers below come from careful analysis or anything here, 2631 * except they are primes and SEED_C1 > 1E6 to get a full-width 2632 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should 2633 * probably be bigger too. 2634 */ 2635 #if RANDBITS > 16 2636 # define SEED_C1 1000003 2637 #define SEED_C4 73819 2638 #else 2639 # define SEED_C1 25747 2640 #define SEED_C4 20639 2641 #endif 2642 #define SEED_C2 3 2643 #define SEED_C3 269 2644 #define SEED_C5 26107 2645 2646 #ifndef PERL_NO_DEV_RANDOM 2647 int fd; 2648 #endif 2649 U32 u; 2650 #ifdef VMS 2651 # include <starlet.h> 2652 /* when[] = (low 32 bits, high 32 bits) of time since epoch 2653 * in 100-ns units, typically incremented ever 10 ms. */ 2654 unsigned int when[2]; 2655 #else 2656 # ifdef HAS_GETTIMEOFDAY 2657 struct timeval when; 2658 # else 2659 Time_t when; 2660 # endif 2661 #endif 2662 2663 /* This test is an escape hatch, this symbol isn't set by Configure. */ 2664 #ifndef PERL_NO_DEV_RANDOM 2665 #ifndef PERL_RANDOM_DEVICE 2666 /* /dev/random isn't used by default because reads from it will block 2667 * if there isn't enough entropy available. You can compile with 2668 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there 2669 * is enough real entropy to fill the seed. */ 2670 # define PERL_RANDOM_DEVICE "/dev/urandom" 2671 #endif 2672 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0); 2673 if (fd != -1) { 2674 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u) 2675 u = 0; 2676 PerlLIO_close(fd); 2677 if (u) 2678 return u; 2679 } 2680 #endif 2681 2682 #ifdef VMS 2683 _ckvmssts(sys$gettim(when)); 2684 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1]; 2685 #else 2686 # ifdef HAS_GETTIMEOFDAY 2687 PerlProc_gettimeofday(&when,NULL); 2688 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec; 2689 # else 2690 (void)time(&when); 2691 u = (U32)SEED_C1 * when; 2692 # endif 2693 #endif 2694 u += SEED_C3 * (U32)PerlProc_getpid(); 2695 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp); 2696 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */ 2697 u += SEED_C5 * (U32)PTR2UV(&when); 2698 #endif 2699 return u; 2700 } 2701 2702 PP(pp_exp) 2703 { 2704 dSP; dTARGET; tryAMAGICun(exp); 2705 { 2706 NV value; 2707 value = POPn; 2708 value = Perl_exp(value); 2709 XPUSHn(value); 2710 RETURN; 2711 } 2712 } 2713 2714 PP(pp_log) 2715 { 2716 dSP; dTARGET; tryAMAGICun(log); 2717 { 2718 NV value; 2719 value = POPn; 2720 if (value <= 0.0) { 2721 SET_NUMERIC_STANDARD(); 2722 DIE(aTHX_ "Can't take log of %"NVgf, value); 2723 } 2724 value = Perl_log(value); 2725 XPUSHn(value); 2726 RETURN; 2727 } 2728 } 2729 2730 PP(pp_sqrt) 2731 { 2732 dSP; dTARGET; tryAMAGICun(sqrt); 2733 { 2734 NV value; 2735 value = POPn; 2736 if (value < 0.0) { 2737 SET_NUMERIC_STANDARD(); 2738 DIE(aTHX_ "Can't take sqrt of %"NVgf, value); 2739 } 2740 value = Perl_sqrt(value); 2741 XPUSHn(value); 2742 RETURN; 2743 } 2744 } 2745 2746 /* 2747 * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2. 2748 * These need to be revisited when a newer toolchain becomes available. 2749 */ 2750 #if defined(__sparc64__) && defined(__GNUC__) 2751 # if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96) 2752 # undef SPARC64_MODF_WORKAROUND 2753 # define SPARC64_MODF_WORKAROUND 1 2754 # endif 2755 #endif 2756 2757 #if defined(SPARC64_MODF_WORKAROUND) 2758 static NV 2759 sparc64_workaround_modf(NV theVal, NV *theIntRes) 2760 { 2761 NV res, ret; 2762 ret = Perl_modf(theVal, &res); 2763 *theIntRes = res; 2764 return ret; 2765 } 2766 #endif 2767 2768 PP(pp_int) 2769 { 2770 dSP; dTARGET; tryAMAGICun(int); 2771 { 2772 NV value; 2773 IV iv = TOPi; /* attempt to convert to IV if possible. */ 2774 /* XXX it's arguable that compiler casting to IV might be subtly 2775 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which 2776 else preferring IV has introduced a subtle behaviour change bug. OTOH 2777 relying on floating point to be accurate is a bug. */ 2778 2779 if (SvIOK(TOPs)) { 2780 if (SvIsUV(TOPs)) { 2781 UV uv = TOPu; 2782 SETu(uv); 2783 } else 2784 SETi(iv); 2785 } else { 2786 value = TOPn; 2787 if (value >= 0.0) { 2788 if (value < (NV)UV_MAX + 0.5) { 2789 SETu(U_V(value)); 2790 } else { 2791 #if defined(SPARC64_MODF_WORKAROUND) 2792 (void)sparc64_workaround_modf(value, &value); 2793 #else 2794 # if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE) 2795 # ifdef HAS_MODFL_POW32_BUG 2796 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */ 2797 { 2798 NV offset = Perl_modf(value, &value); 2799 (void)Perl_modf(offset, &offset); 2800 value += offset; 2801 } 2802 # else 2803 (void)Perl_modf(value, &value); 2804 # endif 2805 # else 2806 double tmp = (double)value; 2807 (void)Perl_modf(tmp, &tmp); 2808 value = (NV)tmp; 2809 # endif 2810 #endif 2811 SETn(value); 2812 } 2813 } 2814 else { 2815 if (value > (NV)IV_MIN - 0.5) { 2816 SETi(I_V(value)); 2817 } else { 2818 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE) 2819 # ifdef HAS_MODFL_POW32_BUG 2820 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */ 2821 { 2822 NV offset = Perl_modf(-value, &value); 2823 (void)Perl_modf(offset, &offset); 2824 value += offset; 2825 } 2826 # else 2827 (void)Perl_modf(-value, &value); 2828 # endif 2829 value = -value; 2830 #else 2831 double tmp = (double)value; 2832 (void)Perl_modf(-tmp, &tmp); 2833 value = -(NV)tmp; 2834 #endif 2835 SETn(value); 2836 } 2837 } 2838 } 2839 } 2840 RETURN; 2841 } 2842 2843 PP(pp_abs) 2844 { 2845 dSP; dTARGET; tryAMAGICun(abs); 2846 { 2847 /* This will cache the NV value if string isn't actually integer */ 2848 IV iv = TOPi; 2849 2850 if (SvIOK(TOPs)) { 2851 /* IVX is precise */ 2852 if (SvIsUV(TOPs)) { 2853 SETu(TOPu); /* force it to be numeric only */ 2854 } else { 2855 if (iv >= 0) { 2856 SETi(iv); 2857 } else { 2858 if (iv != IV_MIN) { 2859 SETi(-iv); 2860 } else { 2861 /* 2s complement assumption. Also, not really needed as 2862 IV_MIN and -IV_MIN should both be %100...00 and NV-able */ 2863 SETu(IV_MIN); 2864 } 2865 } 2866 } 2867 } else{ 2868 NV value = TOPn; 2869 if (value < 0.0) 2870 value = -value; 2871 SETn(value); 2872 } 2873 } 2874 RETURN; 2875 } 2876 2877 2878 PP(pp_hex) 2879 { 2880 dSP; dTARGET; 2881 char *tmps; 2882 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES; 2883 STRLEN len; 2884 NV result_nv; 2885 UV result_uv; 2886 SV* sv = POPs; 2887 2888 tmps = (SvPVx(sv, len)); 2889 if (DO_UTF8(sv)) { 2890 /* If Unicode, try to downgrade 2891 * If not possible, croak. */ 2892 SV* tsv = sv_2mortal(newSVsv(sv)); 2893 2894 SvUTF8_on(tsv); 2895 sv_utf8_downgrade(tsv, FALSE); 2896 tmps = SvPVX(tsv); 2897 } 2898 result_uv = grok_hex (tmps, &len, &flags, &result_nv); 2899 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) { 2900 XPUSHn(result_nv); 2901 } 2902 else { 2903 XPUSHu(result_uv); 2904 } 2905 RETURN; 2906 } 2907 2908 PP(pp_oct) 2909 { 2910 dSP; dTARGET; 2911 char *tmps; 2912 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES; 2913 STRLEN len; 2914 NV result_nv; 2915 UV result_uv; 2916 SV* sv = POPs; 2917 2918 tmps = (SvPVx(sv, len)); 2919 if (DO_UTF8(sv)) { 2920 /* If Unicode, try to downgrade 2921 * If not possible, croak. */ 2922 SV* tsv = sv_2mortal(newSVsv(sv)); 2923 2924 SvUTF8_on(tsv); 2925 sv_utf8_downgrade(tsv, FALSE); 2926 tmps = SvPVX(tsv); 2927 } 2928 while (*tmps && len && isSPACE(*tmps)) 2929 tmps++, len--; 2930 if (*tmps == '0') 2931 tmps++, len--; 2932 if (*tmps == 'x') 2933 result_uv = grok_hex (tmps, &len, &flags, &result_nv); 2934 else if (*tmps == 'b') 2935 result_uv = grok_bin (tmps, &len, &flags, &result_nv); 2936 else 2937 result_uv = grok_oct (tmps, &len, &flags, &result_nv); 2938 2939 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) { 2940 XPUSHn(result_nv); 2941 } 2942 else { 2943 XPUSHu(result_uv); 2944 } 2945 RETURN; 2946 } 2947 2948 /* String stuff. */ 2949 2950 PP(pp_length) 2951 { 2952 dSP; dTARGET; 2953 SV *sv = TOPs; 2954 2955 if (DO_UTF8(sv)) 2956 SETi(sv_len_utf8(sv)); 2957 else 2958 SETi(sv_len(sv)); 2959 RETURN; 2960 } 2961 2962 PP(pp_substr) 2963 { 2964 dSP; dTARGET; 2965 SV *sv; 2966 I32 len = 0; 2967 STRLEN curlen; 2968 STRLEN utf8_curlen; 2969 I32 pos; 2970 I32 rem; 2971 I32 fail; 2972 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET; 2973 char *tmps; 2974 I32 arybase = PL_curcop->cop_arybase; 2975 SV *repl_sv = NULL; 2976 char *repl = 0; 2977 STRLEN repl_len; 2978 int num_args = PL_op->op_private & 7; 2979 bool repl_need_utf8_upgrade = FALSE; 2980 bool repl_is_utf8 = FALSE; 2981 2982 SvTAINTED_off(TARG); /* decontaminate */ 2983 SvUTF8_off(TARG); /* decontaminate */ 2984 if (num_args > 2) { 2985 if (num_args > 3) { 2986 repl_sv = POPs; 2987 repl = SvPV(repl_sv, repl_len); 2988 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv); 2989 } 2990 len = POPi; 2991 } 2992 pos = POPi; 2993 sv = POPs; 2994 PUTBACK; 2995 if (repl_sv) { 2996 if (repl_is_utf8) { 2997 if (!DO_UTF8(sv)) 2998 sv_utf8_upgrade(sv); 2999 } 3000 else if (DO_UTF8(sv)) 3001 repl_need_utf8_upgrade = TRUE; 3002 } 3003 tmps = SvPV(sv, curlen); 3004 if (DO_UTF8(sv)) { 3005 utf8_curlen = sv_len_utf8(sv); 3006 if (utf8_curlen == curlen) 3007 utf8_curlen = 0; 3008 else 3009 curlen = utf8_curlen; 3010 } 3011 else 3012 utf8_curlen = 0; 3013 3014 if (pos >= arybase) { 3015 pos -= arybase; 3016 rem = curlen-pos; 3017 fail = rem; 3018 if (num_args > 2) { 3019 if (len < 0) { 3020 rem += len; 3021 if (rem < 0) 3022 rem = 0; 3023 } 3024 else if (rem > len) 3025 rem = len; 3026 } 3027 } 3028 else { 3029 pos += curlen; 3030 if (num_args < 3) 3031 rem = curlen; 3032 else if (len >= 0) { 3033 rem = pos+len; 3034 if (rem > (I32)curlen) 3035 rem = curlen; 3036 } 3037 else { 3038 rem = curlen+len; 3039 if (rem < pos) 3040 rem = pos; 3041 } 3042 if (pos < 0) 3043 pos = 0; 3044 fail = rem; 3045 rem -= pos; 3046 } 3047 if (fail < 0) { 3048 if (lvalue || repl) 3049 Perl_croak(aTHX_ "substr outside of string"); 3050 if (ckWARN(WARN_SUBSTR)) 3051 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string"); 3052 RETPUSHUNDEF; 3053 } 3054 else { 3055 I32 upos = pos; 3056 I32 urem = rem; 3057 if (utf8_curlen) 3058 sv_pos_u2b(sv, &pos, &rem); 3059 tmps += pos; 3060 sv_setpvn(TARG, tmps, rem); 3061 #ifdef USE_LOCALE_COLLATE 3062 sv_unmagic(TARG, PERL_MAGIC_collxfrm); 3063 #endif 3064 if (utf8_curlen) 3065 SvUTF8_on(TARG); 3066 if (repl) { 3067 SV* repl_sv_copy = NULL; 3068 3069 if (repl_need_utf8_upgrade) { 3070 repl_sv_copy = newSVsv(repl_sv); 3071 sv_utf8_upgrade(repl_sv_copy); 3072 repl = SvPV(repl_sv_copy, repl_len); 3073 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv); 3074 } 3075 sv_insert(sv, pos, rem, repl, repl_len); 3076 if (repl_is_utf8) 3077 SvUTF8_on(sv); 3078 if (repl_sv_copy) 3079 SvREFCNT_dec(repl_sv_copy); 3080 } 3081 else if (lvalue) { /* it's an lvalue! */ 3082 if (!SvGMAGICAL(sv)) { 3083 if (SvROK(sv)) { 3084 STRLEN n_a; 3085 SvPV_force(sv,n_a); 3086 if (ckWARN(WARN_SUBSTR)) 3087 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), 3088 "Attempt to use reference as lvalue in substr"); 3089 } 3090 if (SvOK(sv)) /* is it defined ? */ 3091 (void)SvPOK_only_UTF8(sv); 3092 else 3093 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */ 3094 } 3095 3096 if (SvTYPE(TARG) < SVt_PVLV) { 3097 sv_upgrade(TARG, SVt_PVLV); 3098 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0); 3099 } 3100 3101 LvTYPE(TARG) = 'x'; 3102 if (LvTARG(TARG) != sv) { 3103 if (LvTARG(TARG)) 3104 SvREFCNT_dec(LvTARG(TARG)); 3105 LvTARG(TARG) = SvREFCNT_inc(sv); 3106 } 3107 LvTARGOFF(TARG) = upos; 3108 LvTARGLEN(TARG) = urem; 3109 } 3110 } 3111 SPAGAIN; 3112 PUSHs(TARG); /* avoid SvSETMAGIC here */ 3113 RETURN; 3114 } 3115 3116 PP(pp_vec) 3117 { 3118 dSP; dTARGET; 3119 register IV size = POPi; 3120 register IV offset = POPi; 3121 register SV *src = POPs; 3122 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET; 3123 3124 SvTAINTED_off(TARG); /* decontaminate */ 3125 if (lvalue) { /* it's an lvalue! */ 3126 if (SvTYPE(TARG) < SVt_PVLV) { 3127 sv_upgrade(TARG, SVt_PVLV); 3128 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0); 3129 } 3130 LvTYPE(TARG) = 'v'; 3131 if (LvTARG(TARG) != src) { 3132 if (LvTARG(TARG)) 3133 SvREFCNT_dec(LvTARG(TARG)); 3134 LvTARG(TARG) = SvREFCNT_inc(src); 3135 } 3136 LvTARGOFF(TARG) = offset; 3137 LvTARGLEN(TARG) = size; 3138 } 3139 3140 sv_setuv(TARG, do_vecget(src, offset, size)); 3141 PUSHs(TARG); 3142 RETURN; 3143 } 3144 3145 PP(pp_index) 3146 { 3147 dSP; dTARGET; 3148 SV *big; 3149 SV *little; 3150 I32 offset; 3151 I32 retval; 3152 char *tmps; 3153 char *tmps2; 3154 STRLEN biglen; 3155 I32 arybase = PL_curcop->cop_arybase; 3156 3157 if (MAXARG < 3) 3158 offset = 0; 3159 else 3160 offset = POPi - arybase; 3161 little = POPs; 3162 big = POPs; 3163 tmps = SvPV(big, biglen); 3164 if (offset > 0 && DO_UTF8(big)) 3165 sv_pos_u2b(big, &offset, 0); 3166 if (offset < 0) 3167 offset = 0; 3168 else if (offset > (I32)biglen) 3169 offset = biglen; 3170 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset, 3171 (unsigned char*)tmps + biglen, little, 0))) 3172 retval = -1; 3173 else 3174 retval = tmps2 - tmps; 3175 if (retval > 0 && DO_UTF8(big)) 3176 sv_pos_b2u(big, &retval); 3177 PUSHi(retval + arybase); 3178 RETURN; 3179 } 3180 3181 PP(pp_rindex) 3182 { 3183 dSP; dTARGET; 3184 SV *big; 3185 SV *little; 3186 STRLEN blen; 3187 STRLEN llen; 3188 I32 offset; 3189 I32 retval; 3190 char *tmps; 3191 char *tmps2; 3192 I32 arybase = PL_curcop->cop_arybase; 3193 3194 if (MAXARG >= 3) 3195 offset = POPi; 3196 little = POPs; 3197 big = POPs; 3198 tmps2 = SvPV(little, llen); 3199 tmps = SvPV(big, blen); 3200 if (MAXARG < 3) 3201 offset = blen; 3202 else { 3203 if (offset > 0 && DO_UTF8(big)) 3204 sv_pos_u2b(big, &offset, 0); 3205 offset = offset - arybase + llen; 3206 } 3207 if (offset < 0) 3208 offset = 0; 3209 else if (offset > (I32)blen) 3210 offset = blen; 3211 if (!(tmps2 = rninstr(tmps, tmps + offset, 3212 tmps2, tmps2 + llen))) 3213 retval = -1; 3214 else 3215 retval = tmps2 - tmps; 3216 if (retval > 0 && DO_UTF8(big)) 3217 sv_pos_b2u(big, &retval); 3218 PUSHi(retval + arybase); 3219 RETURN; 3220 } 3221 3222 PP(pp_sprintf) 3223 { 3224 dSP; dMARK; dORIGMARK; dTARGET; 3225 do_sprintf(TARG, SP-MARK, MARK+1); 3226 TAINT_IF(SvTAINTED(TARG)); 3227 if (DO_UTF8(*(MARK+1))) 3228 SvUTF8_on(TARG); 3229 SP = ORIGMARK; 3230 PUSHTARG; 3231 RETURN; 3232 } 3233 3234 PP(pp_ord) 3235 { 3236 dSP; dTARGET; 3237 SV *argsv = POPs; 3238 STRLEN len; 3239 U8 *s = (U8*)SvPVx(argsv, len); 3240 SV *tmpsv; 3241 3242 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) { 3243 tmpsv = sv_2mortal(newSVsv(argsv)); 3244 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding); 3245 argsv = tmpsv; 3246 } 3247 3248 XPUSHu(DO_UTF8(argsv) ? 3249 utf8n_to_uvchr(s, UTF8_MAXLEN, 0, UTF8_ALLOW_ANYUV) : 3250 (*s & 0xff)); 3251 3252 RETURN; 3253 } 3254 3255 PP(pp_chr) 3256 { 3257 dSP; dTARGET; 3258 char *tmps; 3259 UV value = POPu; 3260 3261 (void)SvUPGRADE(TARG,SVt_PV); 3262 3263 if (value > 255 && !IN_BYTES) { 3264 SvGROW(TARG, (STRLEN)UNISKIP(value)+1); 3265 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0); 3266 SvCUR_set(TARG, tmps - SvPVX(TARG)); 3267 *tmps = '\0'; 3268 (void)SvPOK_only(TARG); 3269 SvUTF8_on(TARG); 3270 XPUSHs(TARG); 3271 RETURN; 3272 } 3273 3274 SvGROW(TARG,2); 3275 SvCUR_set(TARG, 1); 3276 tmps = SvPVX(TARG); 3277 *tmps++ = (char)value; 3278 *tmps = '\0'; 3279 (void)SvPOK_only(TARG); 3280 if (PL_encoding) 3281 sv_recode_to_utf8(TARG, PL_encoding); 3282 XPUSHs(TARG); 3283 RETURN; 3284 } 3285 3286 PP(pp_crypt) 3287 { 3288 dSP; dTARGET; 3289 #ifdef HAS_CRYPT 3290 dPOPTOPssrl; 3291 STRLEN n_a; 3292 STRLEN len; 3293 char *tmps = SvPV(left, len); 3294 3295 if (DO_UTF8(left)) { 3296 /* If Unicode, try to downgrade. 3297 * If not possible, croak. 3298 * Yes, we made this up. */ 3299 SV* tsv = sv_2mortal(newSVsv(left)); 3300 3301 SvUTF8_on(tsv); 3302 sv_utf8_downgrade(tsv, FALSE); 3303 tmps = SvPVX(tsv); 3304 } 3305 # ifdef FCRYPT 3306 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a))); 3307 # else 3308 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a))); 3309 # endif 3310 SETs(TARG); 3311 RETURN; 3312 #else 3313 DIE(aTHX_ 3314 "The crypt() function is unimplemented due to excessive paranoia."); 3315 #endif 3316 } 3317 3318 PP(pp_ucfirst) 3319 { 3320 dSP; 3321 SV *sv = TOPs; 3322 register U8 *s; 3323 STRLEN slen; 3324 3325 if (DO_UTF8(sv)) { 3326 U8 tmpbuf[UTF8_MAXLEN_UCLC+1]; 3327 STRLEN ulen; 3328 STRLEN tculen; 3329 3330 s = (U8*)SvPV(sv, slen); 3331 utf8_to_uvchr(s, &ulen); 3332 3333 toTITLE_utf8(s, tmpbuf, &tculen); 3334 utf8_to_uvchr(tmpbuf, 0); 3335 3336 if (!SvPADTMP(sv) || SvREADONLY(sv)) { 3337 dTARGET; 3338 sv_setpvn(TARG, (char*)tmpbuf, tculen); 3339 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen); 3340 SvUTF8_on(TARG); 3341 SETs(TARG); 3342 } 3343 else { 3344 s = (U8*)SvPV_force(sv, slen); 3345 Copy(tmpbuf, s, tculen, U8); 3346 } 3347 } 3348 else { 3349 if (!SvPADTMP(sv) || SvREADONLY(sv)) { 3350 dTARGET; 3351 SvUTF8_off(TARG); /* decontaminate */ 3352 sv_setsv(TARG, sv); 3353 sv = TARG; 3354 SETs(sv); 3355 } 3356 s = (U8*)SvPV_force(sv, slen); 3357 if (*s) { 3358 if (IN_LOCALE_RUNTIME) { 3359 TAINT; 3360 SvTAINTED_on(sv); 3361 *s = toUPPER_LC(*s); 3362 } 3363 else 3364 *s = toUPPER(*s); 3365 } 3366 } 3367 if (SvSMAGICAL(sv)) 3368 mg_set(sv); 3369 RETURN; 3370 } 3371 3372 PP(pp_lcfirst) 3373 { 3374 dSP; 3375 SV *sv = TOPs; 3376 register U8 *s; 3377 STRLEN slen; 3378 3379 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) { 3380 STRLEN ulen; 3381 U8 tmpbuf[UTF8_MAXLEN_UCLC+1]; 3382 U8 *tend; 3383 UV uv; 3384 3385 toLOWER_utf8(s, tmpbuf, &ulen); 3386 uv = utf8_to_uvchr(tmpbuf, 0); 3387 3388 tend = uvchr_to_utf8(tmpbuf, uv); 3389 3390 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) { 3391 dTARGET; 3392 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf); 3393 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen); 3394 SvUTF8_on(TARG); 3395 SETs(TARG); 3396 } 3397 else { 3398 s = (U8*)SvPV_force(sv, slen); 3399 Copy(tmpbuf, s, ulen, U8); 3400 } 3401 } 3402 else { 3403 if (!SvPADTMP(sv) || SvREADONLY(sv)) { 3404 dTARGET; 3405 SvUTF8_off(TARG); /* decontaminate */ 3406 sv_setsv(TARG, sv); 3407 sv = TARG; 3408 SETs(sv); 3409 } 3410 s = (U8*)SvPV_force(sv, slen); 3411 if (*s) { 3412 if (IN_LOCALE_RUNTIME) { 3413 TAINT; 3414 SvTAINTED_on(sv); 3415 *s = toLOWER_LC(*s); 3416 } 3417 else 3418 *s = toLOWER(*s); 3419 } 3420 } 3421 if (SvSMAGICAL(sv)) 3422 mg_set(sv); 3423 RETURN; 3424 } 3425 3426 PP(pp_uc) 3427 { 3428 dSP; 3429 SV *sv = TOPs; 3430 register U8 *s; 3431 STRLEN len; 3432 3433 if (DO_UTF8(sv)) { 3434 dTARGET; 3435 STRLEN ulen; 3436 register U8 *d; 3437 U8 *send; 3438 U8 tmpbuf[UTF8_MAXLEN_UCLC+1]; 3439 3440 s = (U8*)SvPV(sv,len); 3441 if (!len) { 3442 SvUTF8_off(TARG); /* decontaminate */ 3443 sv_setpvn(TARG, "", 0); 3444 SETs(TARG); 3445 } 3446 else { 3447 STRLEN nchar = utf8_length(s, s + len); 3448 3449 (void)SvUPGRADE(TARG, SVt_PV); 3450 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1); 3451 (void)SvPOK_only(TARG); 3452 d = (U8*)SvPVX(TARG); 3453 send = s + len; 3454 while (s < send) { 3455 toUPPER_utf8(s, tmpbuf, &ulen); 3456 Copy(tmpbuf, d, ulen, U8); 3457 d += ulen; 3458 s += UTF8SKIP(s); 3459 } 3460 *d = '\0'; 3461 SvUTF8_on(TARG); 3462 SvCUR_set(TARG, d - (U8*)SvPVX(TARG)); 3463 SETs(TARG); 3464 } 3465 } 3466 else { 3467 if (!SvPADTMP(sv) || SvREADONLY(sv)) { 3468 dTARGET; 3469 SvUTF8_off(TARG); /* decontaminate */ 3470 sv_setsv(TARG, sv); 3471 sv = TARG; 3472 SETs(sv); 3473 } 3474 s = (U8*)SvPV_force(sv, len); 3475 if (len) { 3476 register U8 *send = s + len; 3477 3478 if (IN_LOCALE_RUNTIME) { 3479 TAINT; 3480 SvTAINTED_on(sv); 3481 for (; s < send; s++) 3482 *s = toUPPER_LC(*s); 3483 } 3484 else { 3485 for (; s < send; s++) 3486 *s = toUPPER(*s); 3487 } 3488 } 3489 } 3490 if (SvSMAGICAL(sv)) 3491 mg_set(sv); 3492 RETURN; 3493 } 3494 3495 PP(pp_lc) 3496 { 3497 dSP; 3498 SV *sv = TOPs; 3499 register U8 *s; 3500 STRLEN len; 3501 3502 if (DO_UTF8(sv)) { 3503 dTARGET; 3504 STRLEN ulen; 3505 register U8 *d; 3506 U8 *send; 3507 U8 tmpbuf[UTF8_MAXLEN_UCLC+1]; 3508 3509 s = (U8*)SvPV(sv,len); 3510 if (!len) { 3511 SvUTF8_off(TARG); /* decontaminate */ 3512 sv_setpvn(TARG, "", 0); 3513 SETs(TARG); 3514 } 3515 else { 3516 STRLEN nchar = utf8_length(s, s + len); 3517 3518 (void)SvUPGRADE(TARG, SVt_PV); 3519 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1); 3520 (void)SvPOK_only(TARG); 3521 d = (U8*)SvPVX(TARG); 3522 send = s + len; 3523 while (s < send) { 3524 UV uv = toLOWER_utf8(s, tmpbuf, &ulen); 3525 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */ 3526 if (uv == GREEK_CAPITAL_LETTER_SIGMA) { 3527 /* 3528 * Now if the sigma is NOT followed by 3529 * /$ignorable_sequence$cased_letter/; 3530 * and it IS preceded by 3531 * /$cased_letter$ignorable_sequence/; 3532 * where $ignorable_sequence is 3533 * [\x{2010}\x{AD}\p{Mn}]* 3534 * and $cased_letter is 3535 * [\p{Ll}\p{Lo}\p{Lt}] 3536 * then it should be mapped to 0x03C2, 3537 * (GREEK SMALL LETTER FINAL SIGMA), 3538 * instead of staying 0x03A3. 3539 * See lib/unicore/SpecCase.txt. 3540 */ 3541 } 3542 Copy(tmpbuf, d, ulen, U8); 3543 d += ulen; 3544 s += UTF8SKIP(s); 3545 } 3546 *d = '\0'; 3547 SvUTF8_on(TARG); 3548 SvCUR_set(TARG, d - (U8*)SvPVX(TARG)); 3549 SETs(TARG); 3550 } 3551 } 3552 else { 3553 if (!SvPADTMP(sv) || SvREADONLY(sv)) { 3554 dTARGET; 3555 SvUTF8_off(TARG); /* decontaminate */ 3556 sv_setsv(TARG, sv); 3557 sv = TARG; 3558 SETs(sv); 3559 } 3560 3561 s = (U8*)SvPV_force(sv, len); 3562 if (len) { 3563 register U8 *send = s + len; 3564 3565 if (IN_LOCALE_RUNTIME) { 3566 TAINT; 3567 SvTAINTED_on(sv); 3568 for (; s < send; s++) 3569 *s = toLOWER_LC(*s); 3570 } 3571 else { 3572 for (; s < send; s++) 3573 *s = toLOWER(*s); 3574 } 3575 } 3576 } 3577 if (SvSMAGICAL(sv)) 3578 mg_set(sv); 3579 RETURN; 3580 } 3581 3582 PP(pp_quotemeta) 3583 { 3584 dSP; dTARGET; 3585 SV *sv = TOPs; 3586 STRLEN len; 3587 register char *s = SvPV(sv,len); 3588 register char *d; 3589 3590 SvUTF8_off(TARG); /* decontaminate */ 3591 if (len) { 3592 (void)SvUPGRADE(TARG, SVt_PV); 3593 SvGROW(TARG, (len * 2) + 1); 3594 d = SvPVX(TARG); 3595 if (DO_UTF8(sv)) { 3596 while (len) { 3597 if (UTF8_IS_CONTINUED(*s)) { 3598 STRLEN ulen = UTF8SKIP(s); 3599 if (ulen > len) 3600 ulen = len; 3601 len -= ulen; 3602 while (ulen--) 3603 *d++ = *s++; 3604 } 3605 else { 3606 if (!isALNUM(*s)) 3607 *d++ = '\\'; 3608 *d++ = *s++; 3609 len--; 3610 } 3611 } 3612 SvUTF8_on(TARG); 3613 } 3614 else { 3615 while (len--) { 3616 if (!isALNUM(*s)) 3617 *d++ = '\\'; 3618 *d++ = *s++; 3619 } 3620 } 3621 *d = '\0'; 3622 SvCUR_set(TARG, d - SvPVX(TARG)); 3623 (void)SvPOK_only_UTF8(TARG); 3624 } 3625 else 3626 sv_setpvn(TARG, s, len); 3627 SETs(TARG); 3628 if (SvSMAGICAL(TARG)) 3629 mg_set(TARG); 3630 RETURN; 3631 } 3632 3633 /* Arrays. */ 3634 3635 PP(pp_aslice) 3636 { 3637 dSP; dMARK; dORIGMARK; 3638 register SV** svp; 3639 register AV* av = (AV*)POPs; 3640 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET); 3641 I32 arybase = PL_curcop->cop_arybase; 3642 I32 elem; 3643 3644 if (SvTYPE(av) == SVt_PVAV) { 3645 if (lval && PL_op->op_private & OPpLVAL_INTRO) { 3646 I32 max = -1; 3647 for (svp = MARK + 1; svp <= SP; svp++) { 3648 elem = SvIVx(*svp); 3649 if (elem > max) 3650 max = elem; 3651 } 3652 if (max > AvMAX(av)) 3653 av_extend(av, max); 3654 } 3655 while (++MARK <= SP) { 3656 elem = SvIVx(*MARK); 3657 3658 if (elem > 0) 3659 elem -= arybase; 3660 svp = av_fetch(av, elem, lval); 3661 if (lval) { 3662 if (!svp || *svp == &PL_sv_undef) 3663 DIE(aTHX_ PL_no_aelem, elem); 3664 if (PL_op->op_private & OPpLVAL_INTRO) 3665 save_aelem(av, elem, svp); 3666 } 3667 *MARK = svp ? *svp : &PL_sv_undef; 3668 } 3669 } 3670 if (GIMME != G_ARRAY) { 3671 MARK = ORIGMARK; 3672 *++MARK = *SP; 3673 SP = MARK; 3674 } 3675 RETURN; 3676 } 3677 3678 /* Associative arrays. */ 3679 3680 PP(pp_each) 3681 { 3682 dSP; 3683 HV *hash = (HV*)POPs; 3684 HE *entry; 3685 I32 gimme = GIMME_V; 3686 I32 realhv = (SvTYPE(hash) == SVt_PVHV); 3687 3688 PUTBACK; 3689 /* might clobber stack_sp */ 3690 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash); 3691 SPAGAIN; 3692 3693 EXTEND(SP, 2); 3694 if (entry) { 3695 SV* sv = hv_iterkeysv(entry); 3696 PUSHs(sv); /* won't clobber stack_sp */ 3697 if (gimme == G_ARRAY) { 3698 SV *val; 3699 PUTBACK; 3700 /* might clobber stack_sp */ 3701 val = realhv ? 3702 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry); 3703 SPAGAIN; 3704 PUSHs(val); 3705 } 3706 } 3707 else if (gimme == G_SCALAR) 3708 RETPUSHUNDEF; 3709 3710 RETURN; 3711 } 3712 3713 PP(pp_values) 3714 { 3715 return do_kv(); 3716 } 3717 3718 PP(pp_keys) 3719 { 3720 return do_kv(); 3721 } 3722 3723 PP(pp_delete) 3724 { 3725 dSP; 3726 I32 gimme = GIMME_V; 3727 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0; 3728 SV *sv; 3729 HV *hv; 3730 3731 if (PL_op->op_private & OPpSLICE) { 3732 dMARK; dORIGMARK; 3733 U32 hvtype; 3734 hv = (HV*)POPs; 3735 hvtype = SvTYPE(hv); 3736 if (hvtype == SVt_PVHV) { /* hash element */ 3737 while (++MARK <= SP) { 3738 sv = hv_delete_ent(hv, *MARK, discard, 0); 3739 *MARK = sv ? sv : &PL_sv_undef; 3740 } 3741 } 3742 else if (hvtype == SVt_PVAV) { 3743 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */ 3744 while (++MARK <= SP) { 3745 sv = av_delete((AV*)hv, SvIV(*MARK), discard); 3746 *MARK = sv ? sv : &PL_sv_undef; 3747 } 3748 } 3749 else { /* pseudo-hash element */ 3750 while (++MARK <= SP) { 3751 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0); 3752 *MARK = sv ? sv : &PL_sv_undef; 3753 } 3754 } 3755 } 3756 else 3757 DIE(aTHX_ "Not a HASH reference"); 3758 if (discard) 3759 SP = ORIGMARK; 3760 else if (gimme == G_SCALAR) { 3761 MARK = ORIGMARK; 3762 *++MARK = *SP; 3763 SP = MARK; 3764 } 3765 } 3766 else { 3767 SV *keysv = POPs; 3768 hv = (HV*)POPs; 3769 if (SvTYPE(hv) == SVt_PVHV) 3770 sv = hv_delete_ent(hv, keysv, discard, 0); 3771 else if (SvTYPE(hv) == SVt_PVAV) { 3772 if (PL_op->op_flags & OPf_SPECIAL) 3773 sv = av_delete((AV*)hv, SvIV(keysv), discard); 3774 else 3775 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0); 3776 } 3777 else 3778 DIE(aTHX_ "Not a HASH reference"); 3779 if (!sv) 3780 sv = &PL_sv_undef; 3781 if (!discard) 3782 PUSHs(sv); 3783 } 3784 RETURN; 3785 } 3786 3787 PP(pp_exists) 3788 { 3789 dSP; 3790 SV *tmpsv; 3791 HV *hv; 3792 3793 if (PL_op->op_private & OPpEXISTS_SUB) { 3794 GV *gv; 3795 CV *cv; 3796 SV *sv = POPs; 3797 cv = sv_2cv(sv, &hv, &gv, FALSE); 3798 if (cv) 3799 RETPUSHYES; 3800 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv)) 3801 RETPUSHYES; 3802 RETPUSHNO; 3803 } 3804 tmpsv = POPs; 3805 hv = (HV*)POPs; 3806 if (SvTYPE(hv) == SVt_PVHV) { 3807 if (hv_exists_ent(hv, tmpsv, 0)) 3808 RETPUSHYES; 3809 } 3810 else if (SvTYPE(hv) == SVt_PVAV) { 3811 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */ 3812 if (av_exists((AV*)hv, SvIV(tmpsv))) 3813 RETPUSHYES; 3814 } 3815 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */ 3816 RETPUSHYES; 3817 } 3818 else { 3819 DIE(aTHX_ "Not a HASH reference"); 3820 } 3821 RETPUSHNO; 3822 } 3823 3824 PP(pp_hslice) 3825 { 3826 dSP; dMARK; dORIGMARK; 3827 register HV *hv = (HV*)POPs; 3828 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET); 3829 I32 realhv = (SvTYPE(hv) == SVt_PVHV); 3830 bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE; 3831 bool other_magic = FALSE; 3832 3833 if (localizing) { 3834 MAGIC *mg; 3835 HV *stash; 3836 3837 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) || 3838 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied)) 3839 /* Try to preserve the existenceness of a tied hash 3840 * element by using EXISTS and DELETE if possible. 3841 * Fallback to FETCH and STORE otherwise */ 3842 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg)))) 3843 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE) 3844 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)); 3845 } 3846 3847 if (!realhv && localizing) 3848 DIE(aTHX_ "Can't localize pseudo-hash element"); 3849 3850 if (realhv || SvTYPE(hv) == SVt_PVAV) { 3851 while (++MARK <= SP) { 3852 SV *keysv = *MARK; 3853 SV **svp; 3854 bool preeminent = FALSE; 3855 3856 if (localizing) { 3857 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 : 3858 realhv ? hv_exists_ent(hv, keysv, 0) 3859 : avhv_exists_ent((AV*)hv, keysv, 0); 3860 } 3861 3862 if (realhv) { 3863 HE *he = hv_fetch_ent(hv, keysv, lval, 0); 3864 svp = he ? &HeVAL(he) : 0; 3865 } 3866 else { 3867 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0); 3868 } 3869 if (lval) { 3870 if (!svp || *svp == &PL_sv_undef) { 3871 STRLEN n_a; 3872 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a)); 3873 } 3874 if (localizing) { 3875 if (preeminent) 3876 save_helem(hv, keysv, svp); 3877 else { 3878 STRLEN keylen; 3879 char *key = SvPV(keysv, keylen); 3880 SAVEDELETE(hv, savepvn(key,keylen), keylen); 3881 } 3882 } 3883 } 3884 *MARK = svp ? *svp : &PL_sv_undef; 3885 } 3886 } 3887 if (GIMME != G_ARRAY) { 3888 MARK = ORIGMARK; 3889 *++MARK = *SP; 3890 SP = MARK; 3891 } 3892 RETURN; 3893 } 3894 3895 /* List operators. */ 3896 3897 PP(pp_list) 3898 { 3899 dSP; dMARK; 3900 if (GIMME != G_ARRAY) { 3901 if (++MARK <= SP) 3902 *MARK = *SP; /* unwanted list, return last item */ 3903 else 3904 *MARK = &PL_sv_undef; 3905 SP = MARK; 3906 } 3907 RETURN; 3908 } 3909 3910 PP(pp_lslice) 3911 { 3912 dSP; 3913 SV **lastrelem = PL_stack_sp; 3914 SV **lastlelem = PL_stack_base + POPMARK; 3915 SV **firstlelem = PL_stack_base + POPMARK + 1; 3916 register SV **firstrelem = lastlelem + 1; 3917 I32 arybase = PL_curcop->cop_arybase; 3918 I32 lval = PL_op->op_flags & OPf_MOD; 3919 I32 is_something_there = lval; 3920 3921 register I32 max = lastrelem - lastlelem; 3922 register SV **lelem; 3923 register I32 ix; 3924 3925 if (GIMME != G_ARRAY) { 3926 ix = SvIVx(*lastlelem); 3927 if (ix < 0) 3928 ix += max; 3929 else 3930 ix -= arybase; 3931 if (ix < 0 || ix >= max) 3932 *firstlelem = &PL_sv_undef; 3933 else 3934 *firstlelem = firstrelem[ix]; 3935 SP = firstlelem; 3936 RETURN; 3937 } 3938 3939 if (max == 0) { 3940 SP = firstlelem - 1; 3941 RETURN; 3942 } 3943 3944 for (lelem = firstlelem; lelem <= lastlelem; lelem++) { 3945 ix = SvIVx(*lelem); 3946 if (ix < 0) 3947 ix += max; 3948 else 3949 ix -= arybase; 3950 if (ix < 0 || ix >= max) 3951 *lelem = &PL_sv_undef; 3952 else { 3953 is_something_there = TRUE; 3954 if (!(*lelem = firstrelem[ix])) 3955 *lelem = &PL_sv_undef; 3956 } 3957 } 3958 if (is_something_there) 3959 SP = lastlelem; 3960 else 3961 SP = firstlelem - 1; 3962 RETURN; 3963 } 3964 3965 PP(pp_anonlist) 3966 { 3967 dSP; dMARK; dORIGMARK; 3968 I32 items = SP - MARK; 3969 SV *av = sv_2mortal((SV*)av_make(items, MARK+1)); 3970 SP = ORIGMARK; /* av_make() might realloc stack_sp */ 3971 XPUSHs(av); 3972 RETURN; 3973 } 3974 3975 PP(pp_anonhash) 3976 { 3977 dSP; dMARK; dORIGMARK; 3978 HV* hv = (HV*)sv_2mortal((SV*)newHV()); 3979 3980 while (MARK < SP) { 3981 SV* key = *++MARK; 3982 SV *val = NEWSV(46, 0); 3983 if (MARK < SP) 3984 sv_setsv(val, *++MARK); 3985 else if (ckWARN(WARN_MISC)) 3986 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash"); 3987 (void)hv_store_ent(hv,key,val,0); 3988 } 3989 SP = ORIGMARK; 3990 XPUSHs((SV*)hv); 3991 RETURN; 3992 } 3993 3994 PP(pp_splice) 3995 { 3996 dSP; dMARK; dORIGMARK; 3997 register AV *ary = (AV*)*++MARK; 3998 register SV **src; 3999 register SV **dst; 4000 register I32 i; 4001 register I32 offset; 4002 register I32 length; 4003 I32 newlen; 4004 I32 after; 4005 I32 diff; 4006 SV **tmparyval = 0; 4007 MAGIC *mg; 4008 4009 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) { 4010 *MARK-- = SvTIED_obj((SV*)ary, mg); 4011 PUSHMARK(MARK); 4012 PUTBACK; 4013 ENTER; 4014 call_method("SPLICE",GIMME_V); 4015 LEAVE; 4016 SPAGAIN; 4017 RETURN; 4018 } 4019 4020 SP++; 4021 4022 if (++MARK < SP) { 4023 offset = i = SvIVx(*MARK); 4024 if (offset < 0) 4025 offset += AvFILLp(ary) + 1; 4026 else 4027 offset -= PL_curcop->cop_arybase; 4028 if (offset < 0) 4029 DIE(aTHX_ PL_no_aelem, i); 4030 if (++MARK < SP) { 4031 length = SvIVx(*MARK++); 4032 if (length < 0) { 4033 length += AvFILLp(ary) - offset + 1; 4034 if (length < 0) 4035 length = 0; 4036 } 4037 } 4038 else 4039 length = AvMAX(ary) + 1; /* close enough to infinity */ 4040 } 4041 else { 4042 offset = 0; 4043 length = AvMAX(ary) + 1; 4044 } 4045 if (offset > AvFILLp(ary) + 1) { 4046 if (ckWARN(WARN_MISC)) 4047 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" ); 4048 offset = AvFILLp(ary) + 1; 4049 } 4050 after = AvFILLp(ary) + 1 - (offset + length); 4051 if (after < 0) { /* not that much array */ 4052 length += after; /* offset+length now in array */ 4053 after = 0; 4054 if (!AvALLOC(ary)) 4055 av_extend(ary, 0); 4056 } 4057 4058 /* At this point, MARK .. SP-1 is our new LIST */ 4059 4060 newlen = SP - MARK; 4061 diff = newlen - length; 4062 if (newlen && !AvREAL(ary) && AvREIFY(ary)) 4063 av_reify(ary); 4064 4065 if (diff < 0) { /* shrinking the area */ 4066 if (newlen) { 4067 New(451, tmparyval, newlen, SV*); /* so remember insertion */ 4068 Copy(MARK, tmparyval, newlen, SV*); 4069 } 4070 4071 MARK = ORIGMARK + 1; 4072 if (GIMME == G_ARRAY) { /* copy return vals to stack */ 4073 MEXTEND(MARK, length); 4074 Copy(AvARRAY(ary)+offset, MARK, length, SV*); 4075 if (AvREAL(ary)) { 4076 EXTEND_MORTAL(length); 4077 for (i = length, dst = MARK; i; i--) { 4078 sv_2mortal(*dst); /* free them eventualy */ 4079 dst++; 4080 } 4081 } 4082 MARK += length - 1; 4083 } 4084 else { 4085 *MARK = AvARRAY(ary)[offset+length-1]; 4086 if (AvREAL(ary)) { 4087 sv_2mortal(*MARK); 4088 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--) 4089 SvREFCNT_dec(*dst++); /* free them now */ 4090 } 4091 } 4092 AvFILLp(ary) += diff; 4093 4094 /* pull up or down? */ 4095 4096 if (offset < after) { /* easier to pull up */ 4097 if (offset) { /* esp. if nothing to pull */ 4098 src = &AvARRAY(ary)[offset-1]; 4099 dst = src - diff; /* diff is negative */ 4100 for (i = offset; i > 0; i--) /* can't trust Copy */ 4101 *dst-- = *src--; 4102 } 4103 dst = AvARRAY(ary); 4104 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */ 4105 AvMAX(ary) += diff; 4106 } 4107 else { 4108 if (after) { /* anything to pull down? */ 4109 src = AvARRAY(ary) + offset + length; 4110 dst = src + diff; /* diff is negative */ 4111 Move(src, dst, after, SV*); 4112 } 4113 dst = &AvARRAY(ary)[AvFILLp(ary)+1]; 4114 /* avoid later double free */ 4115 } 4116 i = -diff; 4117 while (i) 4118 dst[--i] = &PL_sv_undef; 4119 4120 if (newlen) { 4121 for (src = tmparyval, dst = AvARRAY(ary) + offset; 4122 newlen; newlen--) { 4123 *dst = NEWSV(46, 0); 4124 sv_setsv(*dst++, *src++); 4125 } 4126 Safefree(tmparyval); 4127 } 4128 } 4129 else { /* no, expanding (or same) */ 4130 if (length) { 4131 New(452, tmparyval, length, SV*); /* so remember deletion */ 4132 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*); 4133 } 4134 4135 if (diff > 0) { /* expanding */ 4136 4137 /* push up or down? */ 4138 4139 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) { 4140 if (offset) { 4141 src = AvARRAY(ary); 4142 dst = src - diff; 4143 Move(src, dst, offset, SV*); 4144 } 4145 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */ 4146 AvMAX(ary) += diff; 4147 AvFILLp(ary) += diff; 4148 } 4149 else { 4150 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */ 4151 av_extend(ary, AvFILLp(ary) + diff); 4152 AvFILLp(ary) += diff; 4153 4154 if (after) { 4155 dst = AvARRAY(ary) + AvFILLp(ary); 4156 src = dst - diff; 4157 for (i = after; i; i--) { 4158 *dst-- = *src--; 4159 } 4160 } 4161 } 4162 } 4163 4164 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) { 4165 *dst = NEWSV(46, 0); 4166 sv_setsv(*dst++, *src++); 4167 } 4168 MARK = ORIGMARK + 1; 4169 if (GIMME == G_ARRAY) { /* copy return vals to stack */ 4170 if (length) { 4171 Copy(tmparyval, MARK, length, SV*); 4172 if (AvREAL(ary)) { 4173 EXTEND_MORTAL(length); 4174 for (i = length, dst = MARK; i; i--) { 4175 sv_2mortal(*dst); /* free them eventualy */ 4176 dst++; 4177 } 4178 } 4179 Safefree(tmparyval); 4180 } 4181 MARK += length - 1; 4182 } 4183 else if (length--) { 4184 *MARK = tmparyval[length]; 4185 if (AvREAL(ary)) { 4186 sv_2mortal(*MARK); 4187 while (length-- > 0) 4188 SvREFCNT_dec(tmparyval[length]); 4189 } 4190 Safefree(tmparyval); 4191 } 4192 else 4193 *MARK = &PL_sv_undef; 4194 } 4195 SP = MARK; 4196 RETURN; 4197 } 4198 4199 PP(pp_push) 4200 { 4201 dSP; dMARK; dORIGMARK; dTARGET; 4202 register AV *ary = (AV*)*++MARK; 4203 register SV *sv = &PL_sv_undef; 4204 MAGIC *mg; 4205 4206 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) { 4207 *MARK-- = SvTIED_obj((SV*)ary, mg); 4208 PUSHMARK(MARK); 4209 PUTBACK; 4210 ENTER; 4211 call_method("PUSH",G_SCALAR|G_DISCARD); 4212 LEAVE; 4213 SPAGAIN; 4214 } 4215 else { 4216 /* Why no pre-extend of ary here ? */ 4217 for (++MARK; MARK <= SP; MARK++) { 4218 sv = NEWSV(51, 0); 4219 if (*MARK) 4220 sv_setsv(sv, *MARK); 4221 av_push(ary, sv); 4222 } 4223 } 4224 SP = ORIGMARK; 4225 PUSHi( AvFILL(ary) + 1 ); 4226 RETURN; 4227 } 4228 4229 PP(pp_pop) 4230 { 4231 dSP; 4232 AV *av = (AV*)POPs; 4233 SV *sv = av_pop(av); 4234 if (AvREAL(av)) 4235 (void)sv_2mortal(sv); 4236 PUSHs(sv); 4237 RETURN; 4238 } 4239 4240 PP(pp_shift) 4241 { 4242 dSP; 4243 AV *av = (AV*)POPs; 4244 SV *sv = av_shift(av); 4245 EXTEND(SP, 1); 4246 if (!sv) 4247 RETPUSHUNDEF; 4248 if (AvREAL(av)) 4249 (void)sv_2mortal(sv); 4250 PUSHs(sv); 4251 RETURN; 4252 } 4253 4254 PP(pp_unshift) 4255 { 4256 dSP; dMARK; dORIGMARK; dTARGET; 4257 register AV *ary = (AV*)*++MARK; 4258 register SV *sv; 4259 register I32 i = 0; 4260 MAGIC *mg; 4261 4262 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) { 4263 *MARK-- = SvTIED_obj((SV*)ary, mg); 4264 PUSHMARK(MARK); 4265 PUTBACK; 4266 ENTER; 4267 call_method("UNSHIFT",G_SCALAR|G_DISCARD); 4268 LEAVE; 4269 SPAGAIN; 4270 } 4271 else { 4272 av_unshift(ary, SP - MARK); 4273 while (MARK < SP) { 4274 sv = NEWSV(27, 0); 4275 sv_setsv(sv, *++MARK); 4276 (void)av_store(ary, i++, sv); 4277 } 4278 } 4279 SP = ORIGMARK; 4280 PUSHi( AvFILL(ary) + 1 ); 4281 RETURN; 4282 } 4283 4284 PP(pp_reverse) 4285 { 4286 dSP; dMARK; 4287 register SV *tmp; 4288 SV **oldsp = SP; 4289 4290 if (GIMME == G_ARRAY) { 4291 MARK++; 4292 while (MARK < SP) { 4293 tmp = *MARK; 4294 *MARK++ = *SP; 4295 *SP-- = tmp; 4296 } 4297 /* safe as long as stack cannot get extended in the above */ 4298 SP = oldsp; 4299 } 4300 else { 4301 register char *up; 4302 register char *down; 4303 register I32 tmp; 4304 dTARGET; 4305 STRLEN len; 4306 4307 SvUTF8_off(TARG); /* decontaminate */ 4308 if (SP - MARK > 1) 4309 do_join(TARG, &PL_sv_no, MARK, SP); 4310 else 4311 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV); 4312 up = SvPV_force(TARG, len); 4313 if (len > 1) { 4314 if (DO_UTF8(TARG)) { /* first reverse each character */ 4315 U8* s = (U8*)SvPVX(TARG); 4316 U8* send = (U8*)(s + len); 4317 while (s < send) { 4318 if (UTF8_IS_INVARIANT(*s)) { 4319 s++; 4320 continue; 4321 } 4322 else { 4323 if (!utf8_to_uvchr(s, 0)) 4324 break; 4325 up = (char*)s; 4326 s += UTF8SKIP(s); 4327 down = (char*)(s - 1); 4328 /* reverse this character */ 4329 while (down > up) { 4330 tmp = *up; 4331 *up++ = *down; 4332 *down-- = (char)tmp; 4333 } 4334 } 4335 } 4336 up = SvPVX(TARG); 4337 } 4338 down = SvPVX(TARG) + len - 1; 4339 while (down > up) { 4340 tmp = *up; 4341 *up++ = *down; 4342 *down-- = (char)tmp; 4343 } 4344 (void)SvPOK_only_UTF8(TARG); 4345 } 4346 SP = MARK + 1; 4347 SETTARG; 4348 } 4349 RETURN; 4350 } 4351 4352 PP(pp_split) 4353 { 4354 dSP; dTARG; 4355 AV *ary; 4356 register IV limit = POPi; /* note, negative is forever */ 4357 SV *sv = POPs; 4358 STRLEN len; 4359 register char *s = SvPV(sv, len); 4360 bool do_utf8 = DO_UTF8(sv); 4361 char *strend = s + len; 4362 register PMOP *pm; 4363 register REGEXP *rx; 4364 register SV *dstr; 4365 register char *m; 4366 I32 iters = 0; 4367 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s); 4368 I32 maxiters = slen + 10; 4369 I32 i; 4370 char *orig; 4371 I32 origlimit = limit; 4372 I32 realarray = 0; 4373 I32 base; 4374 AV *oldstack = PL_curstack; 4375 I32 gimme = GIMME_V; 4376 I32 oldsave = PL_savestack_ix; 4377 I32 make_mortal = 1; 4378 MAGIC *mg = (MAGIC *) NULL; 4379 4380 #ifdef DEBUGGING 4381 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*); 4382 #else 4383 pm = (PMOP*)POPs; 4384 #endif 4385 if (!pm || !s) 4386 DIE(aTHX_ "panic: pp_split"); 4387 rx = PM_GETRE(pm); 4388 4389 TAINT_IF((pm->op_pmflags & PMf_LOCALE) && 4390 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE))); 4391 4392 PL_reg_match_utf8 = do_utf8; 4393 4394 if (pm->op_pmreplroot) { 4395 #ifdef USE_ITHREADS 4396 ary = GvAVn((GV*)PL_curpad[INT2PTR(PADOFFSET, pm->op_pmreplroot)]); 4397 #else 4398 ary = GvAVn((GV*)pm->op_pmreplroot); 4399 #endif 4400 } 4401 else if (gimme != G_ARRAY) 4402 #ifdef USE_5005THREADS 4403 ary = (AV*)PL_curpad[0]; 4404 #else 4405 ary = GvAVn(PL_defgv); 4406 #endif /* USE_5005THREADS */ 4407 else 4408 ary = Nullav; 4409 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) { 4410 realarray = 1; 4411 PUTBACK; 4412 av_extend(ary,0); 4413 av_clear(ary); 4414 SPAGAIN; 4415 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) { 4416 PUSHMARK(SP); 4417 XPUSHs(SvTIED_obj((SV*)ary, mg)); 4418 } 4419 else { 4420 if (!AvREAL(ary)) { 4421 AvREAL_on(ary); 4422 AvREIFY_off(ary); 4423 for (i = AvFILLp(ary); i >= 0; i--) 4424 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */ 4425 } 4426 /* temporarily switch stacks */ 4427 SWITCHSTACK(PL_curstack, ary); 4428 make_mortal = 0; 4429 } 4430 } 4431 base = SP - PL_stack_base; 4432 orig = s; 4433 if (pm->op_pmflags & PMf_SKIPWHITE) { 4434 if (pm->op_pmflags & PMf_LOCALE) { 4435 while (isSPACE_LC(*s)) 4436 s++; 4437 } 4438 else { 4439 while (isSPACE(*s)) 4440 s++; 4441 } 4442 } 4443 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) { 4444 SAVEINT(PL_multiline); 4445 PL_multiline = pm->op_pmflags & PMf_MULTILINE; 4446 } 4447 4448 if (!limit) 4449 limit = maxiters + 2; 4450 if (pm->op_pmflags & PMf_WHITE) { 4451 while (--limit) { 4452 m = s; 4453 while (m < strend && 4454 !((pm->op_pmflags & PMf_LOCALE) 4455 ? isSPACE_LC(*m) : isSPACE(*m))) 4456 ++m; 4457 if (m >= strend) 4458 break; 4459 4460 dstr = NEWSV(30, m-s); 4461 sv_setpvn(dstr, s, m-s); 4462 if (make_mortal) 4463 sv_2mortal(dstr); 4464 if (do_utf8) 4465 (void)SvUTF8_on(dstr); 4466 XPUSHs(dstr); 4467 4468 s = m + 1; 4469 while (s < strend && 4470 ((pm->op_pmflags & PMf_LOCALE) 4471 ? isSPACE_LC(*s) : isSPACE(*s))) 4472 ++s; 4473 } 4474 } 4475 else if (strEQ("^", rx->precomp)) { 4476 while (--limit) { 4477 /*SUPPRESS 530*/ 4478 for (m = s; m < strend && *m != '\n'; m++) ; 4479 m++; 4480 if (m >= strend) 4481 break; 4482 dstr = NEWSV(30, m-s); 4483 sv_setpvn(dstr, s, m-s); 4484 if (make_mortal) 4485 sv_2mortal(dstr); 4486 if (do_utf8) 4487 (void)SvUTF8_on(dstr); 4488 XPUSHs(dstr); 4489 s = m; 4490 } 4491 } 4492 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) && 4493 (rx->reganch & RE_USE_INTUIT) && !rx->nparens 4494 && (rx->reganch & ROPT_CHECK_ALL) 4495 && !(rx->reganch & ROPT_ANCH)) { 4496 int tail = (rx->reganch & RE_INTUIT_TAIL); 4497 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx); 4498 4499 len = rx->minlen; 4500 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) { 4501 STRLEN n_a; 4502 char c = *SvPV(csv, n_a); 4503 while (--limit) { 4504 /*SUPPRESS 530*/ 4505 for (m = s; m < strend && *m != c; m++) ; 4506 if (m >= strend) 4507 break; 4508 dstr = NEWSV(30, m-s); 4509 sv_setpvn(dstr, s, m-s); 4510 if (make_mortal) 4511 sv_2mortal(dstr); 4512 if (do_utf8) 4513 (void)SvUTF8_on(dstr); 4514 XPUSHs(dstr); 4515 /* The rx->minlen is in characters but we want to step 4516 * s ahead by bytes. */ 4517 if (do_utf8) 4518 s = (char*)utf8_hop((U8*)m, len); 4519 else 4520 s = m + len; /* Fake \n at the end */ 4521 } 4522 } 4523 else { 4524 #ifndef lint 4525 while (s < strend && --limit && 4526 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend, 4527 csv, PL_multiline ? FBMrf_MULTILINE : 0)) ) 4528 #endif 4529 { 4530 dstr = NEWSV(31, m-s); 4531 sv_setpvn(dstr, s, m-s); 4532 if (make_mortal) 4533 sv_2mortal(dstr); 4534 if (do_utf8) 4535 (void)SvUTF8_on(dstr); 4536 XPUSHs(dstr); 4537 /* The rx->minlen is in characters but we want to step 4538 * s ahead by bytes. */ 4539 if (do_utf8) 4540 s = (char*)utf8_hop((U8*)m, len); 4541 else 4542 s = m + len; /* Fake \n at the end */ 4543 } 4544 } 4545 } 4546 else { 4547 maxiters += slen * rx->nparens; 4548 while (s < strend && --limit 4549 /* && (!rx->check_substr 4550 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend, 4551 0, NULL)))) 4552 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig, 4553 1 /* minend */, sv, NULL, 0)) 4554 { 4555 TAINT_IF(RX_MATCH_TAINTED(rx)); 4556 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) { 4557 m = s; 4558 s = orig; 4559 orig = rx->subbeg; 4560 s = orig + (m - s); 4561 strend = s + (strend - m); 4562 } 4563 m = rx->startp[0] + orig; 4564 dstr = NEWSV(32, m-s); 4565 sv_setpvn(dstr, s, m-s); 4566 if (make_mortal) 4567 sv_2mortal(dstr); 4568 if (do_utf8) 4569 (void)SvUTF8_on(dstr); 4570 XPUSHs(dstr); 4571 if (rx->nparens) { 4572 for (i = 1; i <= (I32)rx->nparens; i++) { 4573 s = rx->startp[i] + orig; 4574 m = rx->endp[i] + orig; 4575 4576 /* japhy (07/27/01) -- the (m && s) test doesn't catch 4577 parens that didn't match -- they should be set to 4578 undef, not the empty string */ 4579 if (m >= orig && s >= orig) { 4580 dstr = NEWSV(33, m-s); 4581 sv_setpvn(dstr, s, m-s); 4582 } 4583 else 4584 dstr = &PL_sv_undef; /* undef, not "" */ 4585 if (make_mortal) 4586 sv_2mortal(dstr); 4587 if (do_utf8) 4588 (void)SvUTF8_on(dstr); 4589 XPUSHs(dstr); 4590 } 4591 } 4592 s = rx->endp[0] + orig; 4593 } 4594 } 4595 4596 LEAVE_SCOPE(oldsave); 4597 iters = (SP - PL_stack_base) - base; 4598 if (iters > maxiters) 4599 DIE(aTHX_ "Split loop"); 4600 4601 /* keep field after final delim? */ 4602 if (s < strend || (iters && origlimit)) { 4603 STRLEN l = strend - s; 4604 dstr = NEWSV(34, l); 4605 sv_setpvn(dstr, s, l); 4606 if (make_mortal) 4607 sv_2mortal(dstr); 4608 if (do_utf8) 4609 (void)SvUTF8_on(dstr); 4610 XPUSHs(dstr); 4611 iters++; 4612 } 4613 else if (!origlimit) { 4614 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) 4615 iters--, SP--; 4616 } 4617 4618 if (realarray) { 4619 if (!mg) { 4620 SWITCHSTACK(ary, oldstack); 4621 if (SvSMAGICAL(ary)) { 4622 PUTBACK; 4623 mg_set((SV*)ary); 4624 SPAGAIN; 4625 } 4626 if (gimme == G_ARRAY) { 4627 EXTEND(SP, iters); 4628 Copy(AvARRAY(ary), SP + 1, iters, SV*); 4629 SP += iters; 4630 RETURN; 4631 } 4632 } 4633 else { 4634 PUTBACK; 4635 ENTER; 4636 call_method("PUSH",G_SCALAR|G_DISCARD); 4637 LEAVE; 4638 SPAGAIN; 4639 if (gimme == G_ARRAY) { 4640 /* EXTEND should not be needed - we just popped them */ 4641 EXTEND(SP, iters); 4642 for (i=0; i < iters; i++) { 4643 SV **svp = av_fetch(ary, i, FALSE); 4644 PUSHs((svp) ? *svp : &PL_sv_undef); 4645 } 4646 RETURN; 4647 } 4648 } 4649 } 4650 else { 4651 if (gimme == G_ARRAY) 4652 RETURN; 4653 } 4654 if (iters || !pm->op_pmreplroot) { 4655 GETTARGET; 4656 PUSHi(iters); 4657 RETURN; 4658 } 4659 RETPUSHUNDEF; 4660 } 4661 4662 #ifdef USE_5005THREADS 4663 void 4664 Perl_unlock_condpair(pTHX_ void *svv) 4665 { 4666 MAGIC *mg = mg_find((SV*)svv, PERL_MAGIC_mutex); 4667 4668 if (!mg) 4669 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex"); 4670 MUTEX_LOCK(MgMUTEXP(mg)); 4671 if (MgOWNER(mg) != thr) 4672 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own"); 4673 MgOWNER(mg) = 0; 4674 COND_SIGNAL(MgOWNERCONDP(mg)); 4675 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n", 4676 PTR2UV(thr), PTR2UV(svv))); 4677 MUTEX_UNLOCK(MgMUTEXP(mg)); 4678 } 4679 #endif /* USE_5005THREADS */ 4680 4681 PP(pp_lock) 4682 { 4683 dSP; 4684 dTOPss; 4685 SV *retsv = sv; 4686 SvLOCK(sv); 4687 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV 4688 || SvTYPE(retsv) == SVt_PVCV) { 4689 retsv = refto(retsv); 4690 } 4691 SETs(retsv); 4692 RETURN; 4693 } 4694 4695 PP(pp_threadsv) 4696 { 4697 #ifdef USE_5005THREADS 4698 dSP; 4699 EXTEND(SP, 1); 4700 if (PL_op->op_private & OPpLVAL_INTRO) 4701 PUSHs(*save_threadsv(PL_op->op_targ)); 4702 else 4703 PUSHs(THREADSV(PL_op->op_targ)); 4704 RETURN; 4705 #else 4706 DIE(aTHX_ "tried to access per-thread data in non-threaded perl"); 4707 #endif /* USE_5005THREADS */ 4708 } 4709