1 /* pp.c 2 * 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 4 * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others 5 * 6 * You may distribute under the terms of either the GNU General Public 7 * License or the Artistic License, as specified in the README file. 8 * 9 */ 10 11 /* 12 * "It's a big house this, and very peculiar. Always a bit more to discover, 13 * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise 14 */ 15 16 /* This file contains general pp ("push/pop") functions that execute the 17 * opcodes that make up a perl program. A typical pp function expects to 18 * find its arguments on the stack, and usually pushes its results onto 19 * the stack, hence the 'pp' terminology. Each OP structure contains 20 * a pointer to the relevant pp_foo() function. 21 */ 22 23 #include "EXTERN.h" 24 #define PERL_IN_PP_C 25 #include "perl.h" 26 #include "keywords.h" 27 28 #include "reentr.h" 29 30 /* XXX I can't imagine anyone who doesn't have this actually _needs_ 31 it, since pid_t is an integral type. 32 --AD 2/20/1998 33 */ 34 #ifdef NEED_GETPID_PROTO 35 extern Pid_t getpid (void); 36 #endif 37 38 /* 39 * Some BSDs and Cygwin default to POSIX math instead of IEEE. 40 * This switches them over to IEEE. 41 */ 42 #if defined(LIBM_LIB_VERSION) 43 _LIB_VERSION_TYPE _LIB_VERSION = _IEEE_; 44 #endif 45 46 /* variations on pp_null */ 47 48 PP(pp_stub) 49 409803 { 50 409803 dSP; 51 409803 if (GIMME_V == G_SCALAR) 52 3810 XPUSHs(&PL_sv_undef); 53 409803 RETURN; 54 } 55 56 PP(pp_scalar) 57 ###### { 58 ###### return NORMAL; 59 } 60 61 /* Pushy stuff. */ 62 63 PP(pp_padav) 64 5592586 { 65 5592586 dSP; dTARGET; 66 5592586 I32 gimme; 67 5592586 if (PL_op->op_private & OPpLVAL_INTRO) 68 1293095 SAVECLEARSV(PAD_SVl(PL_op->op_targ)); 69 5592586 EXTEND(SP, 1); 70 5592586 if (PL_op->op_flags & OPf_REF) { 71 3619434 PUSHs(TARG); 72 3619434 RETURN; 73 1973152 } else if (LVRET) { 74 2 if (GIMME == G_SCALAR) 75 ###### Perl_croak(aTHX_ "Can't return array to lvalue scalar context"); 76 2 PUSHs(TARG); 77 2 RETURN; 78 } 79 1973150 gimme = GIMME_V; 80 1973150 if (gimme == G_ARRAY) { 81 990480 const I32 maxarg = AvFILL((AV*)TARG) + 1; 82 990480 EXTEND(SP, maxarg); 83 990480 if (SvMAGICAL(TARG)) { 84 3105 U32 i; 85 62972 for (i=0; i < (U32)maxarg; i++) { 86 59867 SV ** const svp = av_fetch((AV*)TARG, i, FALSE); 87 59867 SP[i+1] = (svp) ? *svp : &PL_sv_undef; 88 } 89 } 90 else { 91 987375 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*); 92 } 93 990480 SP += maxarg; 94 } 95 982670 else if (gimme == G_SCALAR) { 96 755264 SV* const sv = sv_newmortal(); 97 755264 const I32 maxarg = AvFILL((AV*)TARG) + 1; 98 755264 sv_setiv(sv, maxarg); 99 755264 PUSHs(sv); 100 } 101 1973150 RETURN; 102 } 103 104 PP(pp_padhv) 105 4249879 { 106 4249879 dSP; dTARGET; 107 4249879 I32 gimme; 108 109 4249879 XPUSHs(TARG); 110 4249879 if (PL_op->op_private & OPpLVAL_INTRO) 111 151124 SAVECLEARSV(PAD_SVl(PL_op->op_targ)); 112 4249879 if (PL_op->op_flags & OPf_REF) 113 4127312 RETURN; 114 122567 else if (LVRET) { 115 1 if (GIMME == G_SCALAR) 116 ###### Perl_croak(aTHX_ "Can't return hash to lvalue scalar context"); 117 1 RETURN; 118 } 119 122566 gimme = GIMME_V; 120 122566 if (gimme == G_ARRAY) { 121 40220 RETURNOP(do_kv()); 122 } 123 82346 else if (gimme == G_SCALAR) { 124 17582 SV* const sv = Perl_hv_scalar(aTHX_ (HV*)TARG); 125 17582 SETs(sv); 126 } 127 82346 RETURN; 128 } 129 130 PP(pp_padany) 131 ###### { 132 ###### DIE(aTHX_ "NOT IMPL LINE %d",__LINE__); 133 } 134 135 /* Translations. */ 136 137 PP(pp_rv2gv) 138 1052078 { 139 1052078 dSP; dTOPss; 140 141 1052078 if (SvROK(sv)) { 142 wasref: 143 789363 tryAMAGICunDEREF(to_gv); 144 145 789363 sv = SvRV(sv); 146 789363 if (SvTYPE(sv) == SVt_PVIO) { 147 30389 GV * const gv = (GV*) sv_newmortal(); 148 30389 gv_init(gv, 0, "", 0, 0); 149 30389 GvIOp(gv) = (IO *)sv; 150 30389 (void)SvREFCNT_inc(sv); 151 30389 sv = (SV*) gv; 152 } 153 758974 else if (SvTYPE(sv) != SVt_PVGV) 154 192 DIE(aTHX_ "Not a GLOB reference"); 155 } 156 else { 157 267652 if (SvTYPE(sv) != SVt_PVGV) { 158 147203 if (SvGMAGICAL(sv)) { 159 3 mg_get(sv); 160 3 if (SvROK(sv)) 161 ###### goto wasref; 162 } 163 147203 if (!SvOK(sv) && sv != &PL_sv_undef) { 164 /* If this is a 'my' scalar and flag is set then vivify 165 * NI-S 1999/05/07 166 */ 167 4954 if (SvREADONLY(sv)) 168 1 Perl_croak(aTHX_ PL_no_modify); 169 4953 if (PL_op->op_private & OPpDEREF) { 170 4937 GV *gv; 171 4937 if (cUNOP->op_targ) { 172 4929 STRLEN len; 173 4929 SV *namesv = PAD_SV(cUNOP->op_targ); 174 4929 const char *name = SvPV(namesv, len); 175 4929 gv = (GV*)NEWSV(0,0); 176 4929 gv_init(gv, CopSTASH(PL_curcop), name, len, 0); 177 } 178 else { 179 8 const char *name = CopSTASHPV(PL_curcop); 180 8 gv = newGVgen(name); 181 } 182 4937 if (SvTYPE(sv) < SVt_RV) 183 419 sv_upgrade(sv, SVt_RV); 184 4937 if (SvPVX_const(sv)) { 185 1 SvPV_free(sv); 186 1 SvLEN_set(sv, 0); 187 1 SvCUR_set(sv, 0); 188 } 189 4937 SvRV_set(sv, (SV*)gv); 190 4937 SvROK_on(sv); 191 4937 SvSETMAGIC(sv); 192 ###### goto wasref; 193 } 194 16 if (PL_op->op_flags & OPf_REF || 195 PL_op->op_private & HINT_STRICT_REFS) 196 1 DIE(aTHX_ PL_no_usym, "a symbol"); 197 15 if (ckWARN(WARN_UNINITIALIZED)) 198 10 report_uninit(sv); 199 15 RETSETUNDEF; 200 } 201 142249 if ((PL_op->op_flags & OPf_SPECIAL) && 202 !(PL_op->op_flags & OPf_MOD)) 203 { 204 32066 SV * const temp = (SV*)gv_fetchsv(sv, FALSE, SVt_PVGV); 205 32066 if (!temp 206 && (!is_gv_magical_sv(sv,0) 207 || !(sv = (SV*)gv_fetchsv(sv, TRUE, SVt_PVGV)))) { 208 148 RETSETUNDEF; 209 } 210 31918 sv = temp; 211 } 212 else { 213 110183 if (PL_op->op_private & HINT_STRICT_REFS) 214 ###### DIE(aTHX_ PL_no_symref_sv, sv, "a symbol"); 215 110183 sv = (SV*)gv_fetchsv(sv, TRUE, SVt_PVGV); 216 } 217 } 218 } 219 1051721 if (PL_op->op_private & OPpLVAL_INTRO) 220 30480 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL)); 221 1051721 SETs(sv); 222 1051721 RETURN; 223 } 224 225 PP(pp_rv2sv) 226 2074096 { 227 2074096 GV *gv = Nullgv; 228 2074096 dSP; dTOPss; 229 230 2074096 if (SvROK(sv)) { 231 wasref: 232 1003463 tryAMAGICunDEREF(to_sv); 233 234 1003463 sv = SvRV(sv); 235 1003463 switch (SvTYPE(sv)) { 236 case SVt_PVAV: 237 case SVt_PVHV: 238 case SVt_PVCV: 239 ###### DIE(aTHX_ "Not a SCALAR reference"); 240 } 241 } 242 else { 243 1070633 gv = (GV*)sv; 244 245 1070633 if (SvTYPE(gv) != SVt_PVGV) { 246 138019 if (SvGMAGICAL(sv)) { 247 ###### mg_get(sv); 248 ###### if (SvROK(sv)) 249 ###### goto wasref; 250 } 251 138019 if (!SvOK(sv)) { 252 7 if (PL_op->op_flags & OPf_REF || 253 PL_op->op_private & HINT_STRICT_REFS) 254 1 DIE(aTHX_ PL_no_usym, "a SCALAR"); 255 6 if (ckWARN(WARN_UNINITIALIZED)) 256 4 report_uninit(sv); 257 6 RETSETUNDEF; 258 } 259 138012 if ((PL_op->op_flags & OPf_SPECIAL) && 260 !(PL_op->op_flags & OPf_MOD)) 261 { 262 35729 gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PV); 263 35729 if (!gv 264 && (!is_gv_magical_sv(sv, 0) 265 || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PV)))) 266 { 267 515 RETSETUNDEF; 268 } 269 } 270 else { 271 102283 if (PL_op->op_private & HINT_STRICT_REFS) 272 19 DIE(aTHX_ PL_no_symref_sv, sv, "a SCALAR"); 273 102264 gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PV); 274 } 275 } 276 1070092 sv = GvSVn(gv); 277 } 278 2073555 if (PL_op->op_flags & OPf_MOD) { 279 1222408 if (PL_op->op_private & OPpLVAL_INTRO) { 280 12 if (cUNOP->op_first->op_type == OP_NULL) 281 ###### sv = save_scalar((GV*)TOPs); 282 12 else if (gv) 283 5 sv = save_scalar(gv); 284 else 285 7 Perl_croak(aTHX_ PL_no_localize_ref); 286 } 287 1222396 else if (PL_op->op_private & OPpDEREF) 288 932576 vivify_ref(sv, PL_op->op_private & OPpDEREF); 289 } 290 2073548 SETs(sv); 291 2073548 RETURN; 292 } 293 294 PP(pp_av2arylen) 295 384674 { 296 384674 dSP; 297 384674 AV * const av = (AV*)TOPs; 298 384674 SV ** const sv = Perl_av_arylen_p(aTHX_ (AV*)av); 299 384674 if (!*sv) { 300 16154 *sv = NEWSV(0,0); 301 16154 sv_upgrade(*sv, SVt_PVMG); 302 16154 sv_magic(*sv, (SV*)av, PERL_MAGIC_arylen, Nullch, 0); 303 } 304 384674 SETs(*sv); 305 384674 RETURN; 306 } 307 308 PP(pp_pos) 309 289813 { 310 289813 dSP; dTARGET; dPOPss; 311 312 289813 if (PL_op->op_flags & OPf_MOD || LVRET) { 313 201109 if (SvTYPE(TARG) < SVt_PVLV) { 314 557 sv_upgrade(TARG, SVt_PVLV); 315 557 sv_magic(TARG, Nullsv, PERL_MAGIC_pos, Nullch, 0); 316 } 317 318 201109 LvTYPE(TARG) = '.'; 319 201109 if (LvTARG(TARG) != sv) { 320 40102 if (LvTARG(TARG)) 321 39545 SvREFCNT_dec(LvTARG(TARG)); 322 40102 LvTARG(TARG) = SvREFCNT_inc(sv); 323 } 324 201109 PUSHs(TARG); /* no SvSETMAGIC */ 325 201109 RETURN; 326 } 327 else { 328 88704 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { 329 88517 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global); 330 88517 if (mg && mg->mg_len >= 0) { 331 88205 I32 i = mg->mg_len; 332 88205 if (DO_UTF8(sv)) 333 8424 sv_pos_b2u(sv, &i); 334 88205 PUSHi(i + PL_curcop->cop_arybase); 335 88205 RETURN; 336 } 337 } 338 499 RETPUSHUNDEF; 339 } 340 } 341 342 PP(pp_rv2cv) 343 148087 { 344 148087 dSP; 345 148087 GV *gv; 346 148087 HV *stash; 347 348 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */ 349 /* (But not in defined().) */ 350 148087 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL)); 351 148085 if (cv) { 352 99103 if (CvCLONE(cv)) 353 ###### cv = (CV*)sv_2mortal((SV*)cv_clone(cv)); 354 99103 if ((PL_op->op_private & OPpLVAL_INTRO)) { 355 7 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE))) 356 1 cv = GvCV(gv); 357 7 if (!CvLVALUE(cv)) 358 1 DIE(aTHX_ "Can't modify non-lvalue subroutine call"); 359 } 360 } 361 else 362 48982 cv = (CV*)&PL_sv_undef; 363 148084 SETs((SV*)cv); 364 148084 RETURN; 365 } 366 367 PP(pp_prototype) 368 888 { 369 888 dSP; 370 888 CV *cv; 371 888 HV *stash; 372 888 GV *gv; 373 888 SV *ret; 374 375 888 ret = &PL_sv_undef; 376 888 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) { 377 776 const char *s = SvPVX_const(TOPs); 378 776 if (strnEQ(s, "CORE::", 6)) { 379 325 const int code = keyword(s + 6, SvCUR(TOPs) - 6); 380 325 if (code < 0) { /* Overridable. */ 381 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2) 382 253 int i = 0, n = 0, seen_question = 0; 383 253 I32 oa; 384 253 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */ 385 386 253 if (code == -KEY_chop || code == -KEY_chomp 387 || code == -KEY_exec || code == -KEY_system) 388 247 goto set; 389 49615 while (i < MAXO) { /* The slow way. */ 390 49610 if (strEQ(s + 6, PL_op_name[i]) 391 || strEQ(s + 6, PL_op_desc[i])) 392 { 393 38 goto found; 394 } 395 49368 i++; 396 } 397 242 goto nonesuch; /* Should not happen... */ 398 found: 399 242 oa = PL_opargs[i] >> OASHIFT; 400 592 while (oa) { 401 350 if (oa & OA_OPTIONAL && !seen_question) { 402 121 seen_question = 1; 403 121 str[n++] = ';'; 404 } 405 350 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF 406 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF 407 /* But globs are already references (kinda) */ 408 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF 409 ) { 410 51 str[n++] = '\\'; 411 } 412 350 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)]; 413 350 oa = oa >> 4; 414 } 415 242 str[n++] = '\0'; 416 242 ret = sv_2mortal(newSVpvn(str, n - 1)); 417 } 418 72 else if (code) /* Non-Overridable */ 419 71 goto set; 420 else { /* None such */ 421 nonesuch: 422 6 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6); 423 } 424 } 425 } 426 805 cv = sv_2cv(TOPs, &stash, &gv, FALSE); 427 805 if (cv && SvPOK(cv)) 428 446 ret = sv_2mortal(newSVpvn(SvPVX_const(cv), SvCUR(cv))); 429 set: 430 882 SETs(ret); 431 882 RETURN; 432 } 433 434 PP(pp_anoncode) 435 36580 { 436 36580 dSP; 437 36580 CV* cv = (CV*)PAD_SV(PL_op->op_targ); 438 36580 if (CvCLONE(cv)) 439 15387 cv = (CV*)sv_2mortal((SV*)cv_clone(cv)); 440 36580 EXTEND(SP,1); 441 36580 PUSHs((SV*)cv); 442 36580 RETURN; 443 } 444 445 PP(pp_srefgen) 446 2319777 { 447 2319777 dSP; 448 2319777 *SP = refto(*SP); 449 2319777 RETURN; 450 } 451 452 PP(pp_refgen) 453 573776 { 454 573776 dSP; dMARK; 455 573776 if (GIMME != G_ARRAY) { 456 366058 if (++MARK <= SP) 457 366058 *MARK = *SP; 458 else 459 ###### *MARK = &PL_sv_undef; 460 366058 *MARK = refto(*MARK); 461 366058 SP = MARK; 462 366058 RETURN; 463 } 464 207718 EXTEND_MORTAL(SP - MARK); 465 415730 while (++MARK <= SP) 466 208012 *MARK = refto(*MARK); 467 207718 RETURN; 468 } 469 470 STATIC SV* 471 S_refto(pTHX_ SV *sv) 472 2893848 { 473 2893848 SV* rv; 474 475 2893848 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') { 476 3 if (LvTARGLEN(sv)) 477 3 vivify_defelem(sv); 478 3 if (!(sv = LvTARG(sv))) 479 ###### sv = &PL_sv_undef; 480 else 481 3 (void)SvREFCNT_inc(sv); 482 } 483 2893845 else if (SvTYPE(sv) == SVt_PVAV) { 484 1467010 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv)) 485 73 av_reify((AV*)sv); 486 1467010 SvTEMP_off(sv); 487 1467010 (void)SvREFCNT_inc(sv); 488 } 489 1426835 else if (SvPADTMP(sv) && !IS_PADGV(sv)) 490 7 sv = newSVsv(sv); 491 else { 492 1426828 SvTEMP_off(sv); 493 1426828 (void)SvREFCNT_inc(sv); 494 } 495 2893848 rv = sv_newmortal(); 496 2893848 sv_upgrade(rv, SVt_RV); 497 2893848 SvRV_set(rv, sv); 498 2893848 SvROK_on(rv); 499 2893848 return rv; 500 } 501 502 PP(pp_ref) 503 1004785 { 504 1004785 dSP; dTARGET; 505 1004785 const char *pv; 506 1004785 SV * const sv = POPs; 507 508 1004785 if (sv && SvGMAGICAL(sv)) 509 580 mg_get(sv); 510 511 1004785 if (!sv || !SvROK(sv)) 512 319179 RETPUSHNO; 513 514 685606 pv = sv_reftype(SvRV(sv),TRUE); 515 685606 PUSHp(pv, strlen(pv)); 516 685606 RETURN; 517 } 518 519 PP(pp_bless) 520 439777 { 521 439777 dSP; 522 439777 HV *stash; 523 524 439777 if (MAXARG == 1) 525 194779 stash = CopSTASH(PL_curcop); 526 else { 527 244998 SV * const ssv = POPs; 528 244998 STRLEN len; 529 244998 const char *ptr; 530 531 244998 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv)) 532 1 Perl_croak(aTHX_ "Attempt to bless into a reference"); 533 244997 ptr = SvPV_const(ssv,len); 534 244997 if (ckWARN(WARN_MISC) && len == 0) 535 4 Perl_warner(aTHX_ packWARN(WARN_MISC), 536 "Explicit blessing to '' (assuming package main)"); 537 244997 stash = gv_stashpvn(ptr, len, TRUE); 538 } 539 540 439776 (void)sv_bless(TOPs, stash); 541 439775 RETURN; 542 } 543 544 PP(pp_gelem) 545 7076 { 546 7076 dSP; 547 548 7076 SV *sv = POPs; 549 7076 const char * const elem = SvPV_nolen_const(sv); 550 7076 GV * const gv = (GV*)POPs; 551 7076 SV * tmpRef = Nullsv; 552 553 7076 sv = Nullsv; 554 7076 if (elem) { 555 /* elem will always be NUL terminated. */ 556 7076 const char * const second_letter = elem + 1; 557 7076 switch (*elem) { 558 case 'A': 559 504 if (strEQ(second_letter, "RRAY")) 560 504 tmpRef = (SV*)GvAV(gv); 561 504 break; 562 case 'C': 563 2119 if (strEQ(second_letter, "ODE")) 564 2119 tmpRef = (SV*)GvCVu(gv); 565 2119 break; 566 case 'F': 567 6 if (strEQ(second_letter, "ILEHANDLE")) { 568 /* finally deprecated in 5.8.0 */ 569 1 deprecate("*glob{FILEHANDLE}"); 570 1 tmpRef = (SV*)GvIOp(gv); 571 } 572 else 573 5 if (strEQ(second_letter, "ORMAT")) 574 5 tmpRef = (SV*)GvFORM(gv); 575 5 break; 576 case 'G': 577 1 if (strEQ(second_letter, "LOB")) 578 1 tmpRef = (SV*)gv; 579 1 break; 580 case 'H': 581 1215 if (strEQ(second_letter, "ASH")) 582 1215 tmpRef = (SV*)GvHV(gv); 583 1215 break; 584 case 'I': 585 713 if (*second_letter == 'O' && !elem[2]) 586 713 tmpRef = (SV*)GvIOp(gv); 587 713 break; 588 case 'N': 589 20 if (strEQ(second_letter, "AME")) 590 20 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv)); 591 20 break; 592 case 'P': 593 6 if (strEQ(second_letter, "ACKAGE")) { 594 6 const HEK *hek = HvNAME_HEK(GvSTASH(gv)); 595 6 sv = hek ? newSVhek(hek) : newSVpvn("__ANON__", 8); 596 } 597 6 break; 598 case 'S': 599 2491 if (strEQ(second_letter, "CALAR")) 600 2491 tmpRef = GvSV(gv); 601 break; 602 } 603 } 604 7076 if (tmpRef) 605 5593 sv = newRV(tmpRef); 606 7076 if (sv) 607 5619 sv_2mortal(sv); 608 else 609 1457 sv = &PL_sv_undef; 610 7076 XPUSHs(sv); 611 7076 RETURN; 612 } 613 614 /* Pattern matching */ 615 616 PP(pp_study) 617 4586 { 618 4586 dSP; dPOPss; 619 4586 register unsigned char *s; 620 4586 register I32 pos; 621 4586 register I32 ch; 622 4586 register I32 *sfirst; 623 4586 register I32 *snext; 624 4586 STRLEN len; 625 626 4586 if (sv == PL_lastscream) { 627 4 if (SvSCREAM(sv)) 628 ###### RETPUSHYES; 629 } 630 else { 631 4582 if (PL_lastscream) { 632 4572 SvSCREAM_off(PL_lastscream); 633 4572 SvREFCNT_dec(PL_lastscream); 634 } 635 4582 PL_lastscream = SvREFCNT_inc(sv); 636 } 637 638 4586 s = (unsigned char*)(SvPV(sv, len)); 639 4586 pos = len; 640 4586 if (pos <= 0) 641 2 RETPUSHNO; 642 4584 if (pos > PL_maxscream) { 643 9 if (PL_maxscream < 0) { 644 9 PL_maxscream = pos + 80; 645 9 New(301, PL_screamfirst, 256, I32); 646 9 New(302, PL_screamnext, PL_maxscream, I32); 647 } 648 else { 649 ###### PL_maxscream = pos + pos / 4; 650 ###### Renew(PL_screamnext, PL_maxscream, I32); 651 } 652 } 653 654 4584 sfirst = PL_screamfirst; 655 4584 snext = PL_screamnext; 656 657 4584 if (!sfirst || !snext) 658 ###### DIE(aTHX_ "do_study: out of memory"); 659 660 1178088 for (ch = 256; ch; --ch) 661 1173504 *sfirst++ = -1; 662 4584 sfirst -= 256; 663 664 82401 while (--pos >= 0) { 665 77817 register const I32 ch = s[pos]; 666 77817 if (sfirst[ch] >= 0) 667 13748 snext[pos] = sfirst[ch] - pos; 668 else 669 64069 snext[pos] = -pos; 670 77817 sfirst[ch] = pos; 671 } 672 673 4584 SvSCREAM_on(sv); 674 /* piggyback on m//g magic */ 675 4584 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0); 676 4584 RETPUSHYES; 677 } 678 679 PP(pp_trans) 680 71445 { 681 71445 dSP; dTARG; 682 71445 SV *sv; 683 684 71445 if (PL_op->op_flags & OPf_STACKED) 685 61615 sv = POPs; 686 9830 else if (PL_op->op_private & OPpTARGET_MY) 687 2 sv = GETTARGET; 688 else { 689 9828 sv = DEFSV; 690 9828 EXTEND(SP,1); 691 } 692 71445 TARG = sv_newmortal(); 693 71445 PUSHi(do_trans(sv)); 694 71444 RETURN; 695 } 696 697 /* Lvalue operators. */ 698 699 PP(pp_schop) 700 52286 { 701 52286 dSP; dTARGET; 702 52286 do_chop(TARG, TOPs); 703 52267 SETTARG; 704 52267 RETURN; 705 } 706 707 PP(pp_chop) 708 43 { 709 43 dSP; dMARK; dTARGET; dORIGMARK; 710 123 while (MARK < SP) 711 80 do_chop(TARG, *++MARK); 712 43 SP = ORIGMARK; 713 43 PUSHTARG; 714 43 RETURN; 715 } 716 717 PP(pp_schomp) 718 242890 { 719 242890 dSP; dTARGET; 720 242890 SETi(do_chomp(TOPs)); 721 242889 RETURN; 722 } 723 724 PP(pp_chomp) 725 1179 { 726 1179 dSP; dMARK; dTARGET; 727 1179 register I32 count = 0; 728 729 2442 while (SP > MARK) 730 1263 count += do_chomp(POPs); 731 1179 PUSHi(count); 732 1179 RETURN; 733 } 734 735 PP(pp_defined) 736 5101871 { 737 5101871 dSP; 738 5101871 register SV* const sv = POPs; 739 740 5101871 if (!sv || !SvANY(sv)) 741 894247 RETPUSHNO; 742 4207624 switch (SvTYPE(sv)) { 743 case SVt_PVAV: 744 130 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) 745 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied))) 746 42 RETPUSHYES; 747 38 break; 748 case SVt_PVHV: 749 38 if (HvARRAY(sv) || SvGMAGICAL(sv) 750 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied))) 751 35 RETPUSHYES; 752 7911 break; 753 case SVt_PVCV: 754 7911 if (CvROOT(sv) || CvXSUB(sv)) 755 7402 RETPUSHYES; 756 4199545 break; 757 default: 758 4199545 if (SvGMAGICAL(sv)) 759 780686 mg_get(sv); 760 4199545 if (SvOK(sv)) 761 3141356 RETPUSHYES; 762 } 763 1058789 RETPUSHNO; 764 } 765 766 PP(pp_undef) 767 416039 { 768 416039 dSP; 769 416039 SV *sv; 770 771 416039 if (!PL_op->op_private) { 772 393083 EXTEND(SP, 1); 773 393083 RETPUSHUNDEF; 774 } 775 776 22956 sv = POPs; 777 22956 if (!sv) 778 ###### RETPUSHUNDEF; 779 780 22956 SV_CHECK_THINKFIRST_COW_DROP(sv); 781 782 22955 switch (SvTYPE(sv)) { 783 case SVt_NULL: 784 1640 break; 785 case SVt_PVAV: 786 1640 av_undef((AV*)sv); 787 1640 break; 788 case SVt_PVHV: 789 6526 hv_undef((HV*)sv); 790 6526 break; 791 case SVt_PVCV: 792 689 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv)) 793 3 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined", 794 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv))); 795 /* FALL THROUGH */ 796 case SVt_PVFM: 797 { 798 /* let user-undef'd sub keep its identity */ 799 689 GV* gv = CvGV((CV*)sv); 800 689 cv_undef((CV*)sv); 801 689 CvGV((CV*)sv) = gv; 802 } 803 689 break; 804 case SVt_PVGV: 805 9 if (SvFAKE(sv)) 806 ###### SvSetMagicSV(sv, &PL_sv_undef); 807 else { 808 9 GP *gp; 809 9 gp_free((GV*)sv); 810 9 Newz(602, gp, 1, GP); 811 9 GvGP(sv) = gp_ref(gp); 812 9 GvSV(sv) = NEWSV(72,0); 813 9 GvLINE(sv) = CopLINE(PL_curcop); 814 9 GvEGV(sv) = (GV*)sv; 815 9 GvMULTI_on(sv); 816 } 817 9 break; 818 default: 819 9633 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) { 820 1479 SvPV_free(sv); 821 1479 SvPV_set(sv, Nullch); 822 1479 SvLEN_set(sv, 0); 823 } 824 9633 SvOK_off(sv); 825 9633 SvSETMAGIC(sv); 826 } 827 828 22955 RETPUSHUNDEF; 829 } 830 831 PP(pp_predec) 832 337984 { 833 337984 dSP; 834 337984 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV) 835 ###### DIE(aTHX_ PL_no_modify); 836 337984 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) 837 && SvIVX(TOPs) != IV_MIN) 838 { 839 327614 SvIV_set(TOPs, SvIVX(TOPs) - 1); 840 327614 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); 841 } 842 else 843 10370 sv_dec(TOPs); 844 337982 SvSETMAGIC(TOPs); 845 337982 return NORMAL; 846 } 847 848 PP(pp_postinc) 849 1799739 { 850 1799739 dSP; dTARGET; 851 1799739 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV) 852 ###### DIE(aTHX_ PL_no_modify); 853 1799739 sv_setsv(TARG, TOPs); 854 1799739 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) 855 && SvIVX(TOPs) != IV_MAX) 856 { 857 211924 SvIV_set(TOPs, SvIVX(TOPs) + 1); 858 211924 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); 859 } 860 else 861 1587815 sv_inc(TOPs); 862 1799739 SvSETMAGIC(TOPs); 863 /* special case for undef: see thread at 2003-03/msg00536.html in archive */ 864 1799739 if (!SvOK(TARG)) 865 260457 sv_setiv(TARG, 0); 866 1799739 SETs(TARG); 867 1799739 return NORMAL; 868 } 869 870 PP(pp_postdec) 871 60093 { 872 60093 dSP; dTARGET; 873 60093 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV) 874 ###### DIE(aTHX_ PL_no_modify); 875 60093 sv_setsv(TARG, TOPs); 876 60093 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) 877 && SvIVX(TOPs) != IV_MIN) 878 { 879 50565 SvIV_set(TOPs, SvIVX(TOPs) - 1); 880 50565 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); 881 } 882 else 883 9528 sv_dec(TOPs); 884 60093 SvSETMAGIC(TOPs); 885 60093 SETs(TARG); 886 60093 return NORMAL; 887 } 888 889 /* Ordinary operators. */ 890 891 PP(pp_pow) 892 4921 { 893 4921 dSP; dATARGET; 894 #ifdef PERL_PRESERVE_IVUV 895 4921 bool is_int = 0; 896 #endif 897 4921 tryAMAGICbin(pow,opASSIGN); 898 #ifdef PERL_PRESERVE_IVUV 899 /* For integer to integer power, we do the calculation by hand wherever 900 we're sure it is safe; otherwise we call pow() and try to convert to 901 integer afterwards. */ 902 { 903 4352 SvIV_please(TOPm1s); 904 4352 if (SvIOK(TOPm1s)) { 905 4312 bool baseuok = SvUOK(TOPm1s); 906 4312 UV baseuv; 907 908 4312 if (baseuok) { 909 1 baseuv = SvUVX(TOPm1s); 910 } else { 911 4311 const IV iv = SvIVX(TOPm1s); 912 4311 if (iv >= 0) { 913 4208 baseuv = iv; 914 4208 baseuok = TRUE; /* effectively it's a UV now */ 915 } else { 916 103 baseuv = -iv; /* abs, baseuok == false records sign */ 917 } 918 } 919 4312 SvIV_please(TOPs); 920 4312 if (SvIOK(TOPs)) { 921 4213 UV power; 922 923 4213 if (SvUOK(TOPs)) { 924 ###### power = SvUVX(TOPs); 925 } else { 926 4213 IV iv = SvIVX(TOPs); 927 4213 if (iv >= 0) { 928 4212 power = iv; 929 } else { 930 4212 goto float_it; /* Can't do negative powers this way. */ 931 } 932 } 933 /* now we have integer ** positive integer. */ 934 4212 is_int = 1; 935 936 /* foo & (foo - 1) is zero only for a power of 2. */ 937 4212 if (!(baseuv & (baseuv - 1))) { 938 /* We are raising power-of-2 to a positive integer. 939 The logic here will work for any base (even non-integer 940 bases) but it can be less accurate than 941 pow (base,power) or exp (power * log (base)) when the 942 intermediate values start to spill out of the mantissa. 943 With powers of 2 we know this can't happen. 944 And powers of 2 are the favourite thing for perl 945 programmers to notice ** not doing what they mean. */ 946 4055 NV result = 1.0; 947 4055 NV base = baseuok ? baseuv : -(NV)baseuv; 948 4055 int n = 0; 949 950 33007 for (; power; base *= base, n++) { 951 /* Do I look like I trust gcc with long longs here? 952 Do I hell. */ 953 18381 const UV bit = (UV)1 << (UV)n; 954 18381 if (power & bit) { 955 10150 result *= base; 956 /* Only bother to clear the bit if it is set. */ 957 10150 power -= bit; 958 /* Avoid squaring base again if we're done. */ 959 10150 if (power == 0) break; 960 } 961 } 962 4055 SP--; 963 4055 SETn( result ); 964 4055 SvIV_please(TOPs); 965 4055 RETURN; 966 } else { 967 157 register unsigned int highbit = 8 * sizeof(UV); 968 157 register unsigned int lowbit = 0; 969 157 register unsigned int diff; 970 157 bool odd_power = (bool)(power & 1); 971 942 while ((diff = (highbit - lowbit) >> 1)) { 972 785 if (baseuv & ~((1 << (lowbit + diff)) - 1)) 973 218 lowbit += diff; 974 else 975 567 highbit -= diff; 976 } 977 /* we now have baseuv < 2 ** highbit */ 978 157 if (power * highbit <= 8 * sizeof(UV)) { 979 /* result will definitely fit in UV, so use UV math 980 on same algorithm as above */ 981 97 register UV result = 1; 982 97 register UV base = baseuv; 983 97 register int n = 0; 984 333 for (; power; base *= base, n++) { 985 187 register const UV bit = (UV)1 << (UV)n; 986 187 if (power & bit) { 987 121 result *= base; 988 121 power -= bit; 989 121 if (power == 0) break; 990 } 991 } 992 97 SP--; 993 97 if (baseuok || !odd_power) 994 /* answer is positive */ 995 87 SETu( result ); 996 10 else if (result <= (UV)IV_MAX) 997 /* answer negative, fits in IV */ 998 10 SETi( -(IV)result ); 999 ###### else if (result == (UV)IV_MIN) 1000 /* 2's complement assumption: special case IV_MIN */ 1001 ###### SETi( IV_MIN ); 1002 else 1003 /* answer negative, doesn't fit */ 1004 ###### SETn( -(NV)result ); 1005 97 RETURN; 1006 } 1007 } 1008 } 1009 } 1010 } 1011 float_it: 1012 #endif 1013 { 1014 200 dPOPTOPnnrl; 1015 200 SETn( Perl_pow( left, right) ); 1016 #ifdef PERL_PRESERVE_IVUV 1017 200 if (is_int) 1018 60 SvIV_please(TOPs); 1019 #endif 1020 200 RETURN; 1021 } 1022 } 1023 1024 PP(pp_multiply) 1025 1227970 { 1026 1227970 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN); 1027 #ifdef PERL_PRESERVE_IVUV 1028 1221751 SvIV_please(TOPs); 1029 1221751 if (SvIOK(TOPs)) { 1030 /* Unless the left argument is integer in range we are going to have to 1031 use NV maths. Hence only attempt to coerce the right argument if 1032 we know the left is integer. */ 1033 /* Left operand is defined, so is it IV? */ 1034 1165721 SvIV_please(TOPm1s); 1035 1165721 if (SvIOK(TOPm1s)) { 1036 1142030 bool auvok = SvUOK(TOPm1s); 1037 1142030 bool buvok = SvUOK(TOPs); 1038 1142030 const UV topmask = (~ (UV)0) << (4 * sizeof (UV)); 1039 1142030 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV))); 1040 1142030 UV alow; 1041 1142030 UV ahigh; 1042 1142030 UV blow; 1043 1142030 UV bhigh; 1044 1045 1142030 if (auvok) { 1046 27 alow = SvUVX(TOPm1s); 1047 } else { 1048 1142003 const IV aiv = SvIVX(TOPm1s); 1049 1142003 if (aiv >= 0) { 1050 1137622 alow = aiv; 1051 1137622 auvok = TRUE; /* effectively it's a UV now */ 1052 } else { 1053 4381 alow = -aiv; /* abs, auvok == false records sign */ 1054 } 1055 } 1056 1142030 if (buvok) { 1057 124 blow = SvUVX(TOPs); 1058 } else { 1059 1141906 const IV biv = SvIVX(TOPs); 1060 1141906 if (biv >= 0) { 1061 1141358 blow = biv; 1062 1141358 buvok = TRUE; /* effectively it's a UV now */ 1063 } else { 1064 548 blow = -biv; /* abs, buvok == false records sign */ 1065 } 1066 } 1067 1068 /* If this does sign extension on unsigned it's time for plan B */ 1069 1142030 ahigh = alow >> (4 * sizeof (UV)); 1070 1142030 alow &= botmask; 1071 1142030 bhigh = blow >> (4 * sizeof (UV)); 1072 1142030 blow &= botmask; 1073 1142030 if (ahigh && bhigh) { 1074 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000 1075 which is overflow. Drop to NVs below. */ 1076 474067 } else if (!ahigh && !bhigh) { 1077 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001 1078 so the unsigned multiply cannot overflow. */ 1079 114164 UV product = alow * blow; 1080 114164 if (auvok == buvok) { 1081 /* -ve * -ve or +ve * +ve gives a +ve result. */ 1082 110038 SP--; 1083 110038 SETu( product ); 1084 110038 RETURN; 1085 4126 } else if (product <= (UV)IV_MIN) { 1086 /* 2s complement assumption that (UV)-IV_MIN is correct. */ 1087 /* -ve result, which could overflow an IV */ 1088 4120 SP--; 1089 4120 SETi( -(IV)product ); 1090 4120 RETURN; 1091 } /* else drop to NVs below. */ 1092 } else { 1093 /* One operand is large, 1 small */ 1094 359903 UV product_middle; 1095 359903 if (bhigh) { 1096 /* swap the operands */ 1097 260185 ahigh = bhigh; 1098 260185 bhigh = blow; /* bhigh now the temp var for the swap */ 1099 260185 blow = alow; 1100 260185 alow = bhigh; 1101 } 1102 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow) 1103 multiplies can't overflow. shift can, add can, -ve can. */ 1104 359903 product_middle = ahigh * blow; 1105 359903 if (!(product_middle & topmask)) { 1106 /* OK, (ahigh * blow) won't lose bits when we shift it. */ 1107 257230 UV product_low; 1108 257230 product_middle <<= (4 * sizeof (UV)); 1109 257230 product_low = alow * blow; 1110 1111 /* as for pp_add, UV + something mustn't get smaller. 1112 IIRC ANSI mandates this wrapping *behaviour* for 1113 unsigned whatever the actual representation*/ 1114 257230 product_low += product_middle; 1115 257230 if (product_low >= product_middle) { 1116 /* didn't overflow */ 1117 255992 if (auvok == buvok) { 1118 /* -ve * -ve or +ve * +ve gives a +ve result. */ 1119 255946 SP--; 1120 255946 SETu( product_low ); 1121 255946 RETURN; 1122 46 } else if (product_low <= (UV)IV_MIN) { 1123 /* 2s complement assumption again */ 1124 /* -ve result, which could overflow an IV */ 1125 24 SP--; 1126 24 SETi( -(IV)product_low ); 1127 24 RETURN; 1128 } /* else drop to NVs below. */ 1129 } 1130 } /* product_middle too large */ 1131 } /* ahigh && bhigh */ 1132 } /* SvIOK(TOPm1s) */ 1133 } /* SvIOK(TOPs) */ 1134 #endif 1135 { 1136 851623 dPOPTOPnnrl; 1137 851623 SETn( left * right ); 1138 851623 RETURN; 1139 } 1140 } 1141 1142 PP(pp_divide) 1143 621314 { 1144 621314 dSP; dATARGET; tryAMAGICbin(div,opASSIGN); 1145 /* Only try to do UV divide first 1146 if ((SLOPPYDIVIDE is true) or 1147 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large 1148 to preserve)) 1149 The assumption is that it is better to use floating point divide 1150 whenever possible, only doing integer divide first if we can't be sure. 1151 If NV_PRESERVES_UV is true then we know at compile time that no UV 1152 can be too large to preserve, so don't need to compile the code to 1153 test the size of UVs. */ 1154 1155 #ifdef SLOPPYDIVIDE 1156 # define PERL_TRY_UV_DIVIDE 1157 /* ensure that 20./5. == 4. */ 1158 #else 1159 # ifdef PERL_PRESERVE_IVUV 1160 # ifndef NV_PRESERVES_UV 1161 # define PERL_TRY_UV_DIVIDE 1162 # endif 1163 # endif 1164 #endif 1165 1166 #ifdef PERL_TRY_UV_DIVIDE 1167 SvIV_please(TOPs); 1168 if (SvIOK(TOPs)) { 1169 SvIV_please(TOPm1s); 1170 if (SvIOK(TOPm1s)) { 1171 bool left_non_neg = SvUOK(TOPm1s); 1172 bool right_non_neg = SvUOK(TOPs); 1173 UV left; 1174 UV right; 1175 1176 if (right_non_neg) { 1177 right = SvUVX(TOPs); 1178 } 1179 else { 1180 const IV biv = SvIVX(TOPs); 1181 if (biv >= 0) { 1182 right = biv; 1183 right_non_neg = TRUE; /* effectively it's a UV now */ 1184 } 1185 else { 1186 right = -biv; 1187 } 1188 } 1189 /* historically undef()/0 gives a "Use of uninitialized value" 1190 warning before dieing, hence this test goes here. 1191 If it were immediately before the second SvIV_please, then 1192 DIE() would be invoked before left was even inspected, so 1193 no inpsection would give no warning. */ 1194 if (right == 0) 1195 DIE(aTHX_ "Illegal division by zero"); 1196 1197 if (left_non_neg) { 1198 left = SvUVX(TOPm1s); 1199 } 1200 else { 1201 const IV aiv = SvIVX(TOPm1s); 1202 if (aiv >= 0) { 1203 left = aiv; 1204 left_non_neg = TRUE; /* effectively it's a UV now */ 1205 } 1206 else { 1207 left = -aiv; 1208 } 1209 } 1210 1211 if (left >= right 1212 #ifdef SLOPPYDIVIDE 1213 /* For sloppy divide we always attempt integer division. */ 1214 #else 1215 /* Otherwise we only attempt it if either or both operands 1216 would not be preserved by an NV. If both fit in NVs 1217 we fall through to the NV divide code below. However, 1218 as left >= right to ensure integer result here, we know that 1219 we can skip the test on the right operand - right big 1220 enough not to be preserved can't get here unless left is 1221 also too big. */ 1222 1223 && (left > ((UV)1 << NV_PRESERVES_UV_BITS)) 1224 #endif 1225 ) { 1226 /* Integer division can't overflow, but it can be imprecise. */ 1227 const UV result = left / right; 1228 if (result * right == left) { 1229 SP--; /* result is valid */ 1230 if (left_non_neg == right_non_neg) { 1231 /* signs identical, result is positive. */ 1232 SETu( result ); 1233 RETURN; 1234 } 1235 /* 2s complement assumption */ 1236 if (result <= (UV)IV_MIN) 1237 SETi( -(IV)result ); 1238 else { 1239 /* It's exact but too negative for IV. */ 1240 SETn( -(NV)result ); 1241 } 1242 RETURN; 1243 } /* tried integer divide but it was not an integer result */ 1244 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */ 1245 } /* left wasn't SvIOK */ 1246 } /* right wasn't SvIOK */ 1247 #endif /* PERL_TRY_UV_DIVIDE */ 1248 { 1249 619087 dPOPPOPnnrl; 1250 619087 if (right == 0.0) 1251 3 DIE(aTHX_ "Illegal division by zero"); 1252 619084 PUSHn( left / right ); 1253 619084 RETURN; 1254 } 1255 } 1256 1257 PP(pp_modulo) 1258 318298 { 1259 318298 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); 1260 { 1261 317502 UV left = 0; 1262 317502 UV right = 0; 1263 317502 bool left_neg = FALSE; 1264 317502 bool right_neg = FALSE; 1265 317502 bool use_double = FALSE; 1266 317502 bool dright_valid = FALSE; 1267 317502 NV dright = 0.0; 1268 317502 NV dleft = 0.0; 1269 1270 317502 SvIV_please(TOPs); 1271 317502 if (SvIOK(TOPs)) { 1272 279843 right_neg = !SvUOK(TOPs); 1273 279843 if (!right_neg) { 1274 2 right = SvUVX(POPs); 1275 } else { 1276 279841 const IV biv = SvIVX(POPs); 1277 279841 if (biv >= 0) { 1278 279838 right = biv; 1279 279838 right_neg = FALSE; /* effectively it's a UV now */ 1280 } else { 1281 3 right = -biv; 1282 } 1283 } 1284 } 1285 else { 1286 37659 dright = POPn; 1287 37659 right_neg = dright < 0; 1288 37659 if (right_neg) 1289 2 dright = -dright; 1290 37659 if (dright < UV_MAX_P1) { 1291 1 right = U_V(dright); 1292 1 dright_valid = TRUE; /* In case we need to use double below. */ 1293 } else { 1294 37658 use_double = TRUE; 1295 } 1296 } 1297 1298 /* At this point use_double is only true if right is out of range for 1299 a UV. In range NV has been rounded down to nearest UV and 1300 use_double false. */ 1301 317502 SvIV_please(TOPs); 1302 317502 if (!use_double && SvIOK(TOPs)) { 1303 278179 if (SvIOK(TOPs)) { 1304 278179 left_neg = !SvUOK(TOPs); 1305 278179 if (!left_neg) { 1306 89 left = SvUVX(POPs); 1307 } else { 1308 278090 IV aiv = SvIVX(POPs); 1309 278090 if (aiv >= 0) { 1310 278088 left = aiv; 1311 278088 left_neg = FALSE; /* effectively it's a UV now */ 1312 } else { 1313 2 left = -aiv; 1314 } 1315 } 1316 } 1317 } 1318 else { 1319 39323 dleft = POPn; 1320 39323 left_neg = dleft < 0; 1321 39323 if (left_neg) 1322 2 dleft = -dleft; 1323 1324 /* This should be exactly the 5.6 behaviour - if left and right are 1325 both in range for UV then use U_V() rather than floor. */ 1326 39323 if (!use_double) { 1327 1665 if (dleft < UV_MAX_P1) { 1328 /* right was in range, so is dleft, so use UVs not double. 1329 */ 1330 4 left = U_V(dleft); 1331 } 1332 /* left is out of range for UV, right was in range, so promote 1333 right (back) to double. */ 1334 else { 1335 /* The +0.5 is used in 5.6 even though it is not strictly 1336 consistent with the implicit +0 floor in the U_V() 1337 inside the #if 1. */ 1338 1661 dleft = Perl_floor(dleft + 0.5); 1339 1661 use_double = TRUE; 1340 1661 if (dright_valid) 1341 ###### dright = Perl_floor(dright + 0.5); 1342 else 1343 1661 dright = right; 1344 } 1345 } 1346 } 1347 317502 if (use_double) { 1348 39319 NV dans; 1349 1350 39319 if (!dright) 1351 ###### DIE(aTHX_ "Illegal modulus zero"); 1352 1353 39319 dans = Perl_fmod(dleft, dright); 1354 39319 if ((left_neg != right_neg) && dans) 1355 2 dans = dright - dans; 1356 39319 if (right_neg) 1357 2 dans = -dans; 1358 39319 sv_setnv(TARG, dans); 1359 } 1360 else { 1361 278183 UV ans; 1362 1363 278183 if (!right) 1364 1 DIE(aTHX_ "Illegal modulus zero"); 1365 1366 278182 ans = left % right; 1367 278182 if ((left_neg != right_neg) && ans) 1368 3 ans = right - ans; 1369 278182 if (right_neg) { 1370 /* XXX may warn: unary minus operator applied to unsigned type */ 1371 /* could change -foo to be (~foo)+1 instead */ 1372 3 if (ans <= ~((UV)IV_MAX)+1) 1373 3 sv_setiv(TARG, ~ans+1); 1374 else 1375 ###### sv_setnv(TARG, -(NV)ans); 1376 } 1377 else 1378 278179 sv_setuv(TARG, ans); 1379 } 1380 317501 PUSHTARG; 1381 317501 RETURN; 1382 } 1383 } 1384 1385 PP(pp_repeat) 1386 124811 { 1387 124811 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN); 1388 { 1389 124810 register IV count; 1390 124810 dPOPss; 1391 124810 if (SvGMAGICAL(sv)) 1392 239 mg_get(sv); 1393 124810 if (SvIOKp(sv)) { 1394 111553 if (SvUOK(sv)) { 1395 ###### const UV uv = SvUV(sv); 1396 ###### if (uv > IV_MAX) 1397 ###### count = IV_MAX; /* The best we can do? */ 1398 else 1399 ###### count = uv; 1400 } else { 1401 111553 IV iv = SvIV(sv); 1402 111553 if (iv < 0) 1403 5 count = 0; 1404 else 1405 111548 count = iv; 1406 } 1407 } 1408 13257 else if (SvNOKp(sv)) { 1409 12475 const NV nv = SvNV(sv); 1410 12475 if (nv < 0.0) 1411 ###### count = 0; 1412 else 1413 12475 count = (IV)nv; 1414 } 1415 else 1416 782 count = SvIVx(sv); 1417 124810 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) { 1418 5977 dMARK; 1419 5977 I32 items = SP - MARK; 1420 5977 I32 max; 1421 static const char oom_list_extend[] = 1422 5977 "Out of memory during list extend"; 1423 1424 5977 max = items * count; 1425 5977 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend); 1426 /* Did the max computation overflow? */ 1427 5977 if (items > 0 && max > 0 && (max < items || max < count)) 1428 ###### Perl_croak(aTHX_ oom_list_extend); 1429 5977 MEXTEND(MARK, max); 1430 5977 if (count > 1) { 1431 7224 while (SP > MARK) { 1432 #if 0 1433 /* This code was intended to fix 20010809.028: 1434 1435 $x = 'abcd'; 1436 for (($x =~ /./g) x 2) { 1437 print chop; # "abcdabcd" expected as output. 1438 } 1439 1440 * but that change (#11635) broke this code: 1441 1442 $x = [("foo")x2]; # only one "foo" ended up in the anonlist. 1443 1444 * I can't think of a better fix that doesn't introduce 1445 * an efficiency hit by copying the SVs. The stack isn't 1446 * refcounted, and mortalisation obviously doesn't 1447 * Do The Right Thing when the stack has more than 1448 * one pointer to the same mortal value. 1449 * .robin. 1450 */ 1451 if (*SP) { 1452 *SP = sv_2mortal(newSVsv(*SP)); 1453 SvREADONLY_on(*SP); 1454 } 1455 #else 1456 4456 if (*SP) 1457 4456 SvTEMP_off((*SP)); 1458 #endif 1459 4456 SP--; 1460 } 1461 2768 MARK++; 1462 2768 repeatcpy((char*)(MARK + items), (char*)MARK, 1463 items * sizeof(SV*), count - 1); 1464 2768 SP += max; 1465 } 1466 3209 else if (count <= 0) 1467 129 SP -= items; 1468 } 1469 else { /* Note: mark already snarfed by pp_list */ 1470 118833 SV *tmpstr = POPs; 1471 118833 STRLEN len; 1472 118833 bool isutf; 1473 static const char oom_string_extend[] = 1474 118833 "Out of memory during string extend"; 1475 1476 118833 SvSetSV(TARG, tmpstr); 1477 118833 SvPV_force(TARG, len); 1478 118833 isutf = DO_UTF8(TARG); 1479 118833 if (count != 1) { 1480 109144 if (count < 1) 1481 5404 SvCUR_set(TARG, 0); 1482 else { 1483 103740 STRLEN max = (UV)count * len; 1484 103740 if (len > ((MEM_SIZE)~0)/count) 1485 ###### Perl_croak(aTHX_ oom_string_extend); 1486 103740 MEM_WRAP_CHECK_1(max, char, oom_string_extend); 1487 103740 SvGROW(TARG, max + 1); 1488 103740 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1); 1489 103740 SvCUR_set(TARG, SvCUR(TARG) * count); 1490 } 1491 109144 *SvEND(TARG) = '\0'; 1492 } 1493 118833 if (isutf) 1494 12 (void)SvPOK_only_UTF8(TARG); 1495 else 1496 118821 (void)SvPOK_only(TARG); 1497 1498 118833 if (PL_op->op_private & OPpREPEAT_DOLIST) { 1499 /* The parser saw this as a list repeat, and there 1500 are probably several items on the stack. But we're 1501 in scalar context, and there's no pp_list to save us 1502 now. So drop the rest of the items -- robin@kitsite.com 1503 */ 1504 5 dMARK; 1505 5 SP = MARK; 1506 } 1507 118833 PUSHTARG; 1508 } 1509 124810 RETURN; 1510 } 1511 } 1512 1513 PP(pp_subtract) 1514 16632175 { 1515 16632175 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN); 1516 16629842 useleft = USE_LEFT(TOPm1s); 1517 #ifdef PERL_PRESERVE_IVUV 1518 /* See comments in pp_add (in pp_hot.c) about Overflow, and how 1519 "bad things" happen if you rely on signed integers wrapping. */ 1520 16629842 SvIV_please(TOPs); 1521 16629842 if (SvIOK(TOPs)) { 1522 /* Unless the left argument is integer in range we are going to have to 1523 use NV maths. Hence only attempt to coerce the right argument if 1524 we know the left is integer. */ 1525 16255409 register UV auv = 0; 1526 16255409 bool auvok = FALSE; 1527 16255409 bool a_valid = 0; 1528 1529 16255409 if (!useleft) { 1530 4 auv = 0; 1531 4 a_valid = auvok = 1; 1532 /* left operand is undef, treat as zero. */ 1533 } else { 1534 /* Left operand is defined, so is it IV? */ 1535 16255405 SvIV_please(TOPm1s); 1536 16255405 if (SvIOK(TOPm1s)) { 1537 16249653 if ((auvok = SvUOK(TOPm1s))) 1538 7874 auv = SvUVX(TOPm1s); 1539 else { 1540 16241779 register const IV aiv = SvIVX(TOPm1s); 1541 16241779 if (aiv >= 0) { 1542 16228949 auv = aiv; 1543 16228949 auvok = 1; /* Now acting as a sign flag. */ 1544 } else { /* 2s complement assumption for IV_MIN */ 1545 12830 auv = (UV)-aiv; 1546 } 1547 } 1548 16249653 a_valid = 1; 1549 } 1550 } 1551 16255409 if (a_valid) { 1552 16249657 bool result_good = 0; 1553 16249657 UV result; 1554 16249657 register UV buv; 1555 16249657 bool buvok = SvUOK(TOPs); 1556 1557 16249657 if (buvok) 1558 7682 buv = SvUVX(TOPs); 1559 else { 1560 16241975 register const IV biv = SvIVX(TOPs); 1561 16241975 if (biv >= 0) { 1562 16239841 buv = biv; 1563 16239841 buvok = 1; 1564 } else 1565 2134 buv = (UV)-biv; 1566 } 1567 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve, 1568 else "IV" now, independent of how it came in. 1569 if a, b represents positive, A, B negative, a maps to -A etc 1570 a - b => (a - b) 1571 A - b => -(a + b) 1572 a - B => (a + b) 1573 A - B => -(a - b) 1574 all UV maths. negate result if A negative. 1575 subtract if signs same, add if signs differ. */ 1576 1577 16249657 if (auvok ^ buvok) { 1578 /* Signs differ. */ 1579 12086 result = auv + buv; 1580 12086 if (result >= auv) 1581 12085 result_good = 1; 1582 } else { 1583 /* Signs same */ 1584 16237571 if (auv >= buv) { 1585 16133186 result = auv - buv; 1586 /* Must get smaller */ 1587 16133186 if (result <= auv) 1588 16133186 result_good = 1; 1589 } else { 1590 104385 result = buv - auv; 1591 104385 if (result <= buv) { 1592 /* result really should be -(auv-buv). as its negation 1593 of true value, need to swap our result flag */ 1594 104385 auvok = !auvok; 1595 104385 result_good = 1; 1596 } 1597 } 1598 } 1599 16249657 if (result_good) { 1600 16249656 SP--; 1601 16249656 if (auvok) 1602 16134967 SETu( result ); 1603 else { 1604 /* Negate result */ 1605 114689 if (result <= (UV)IV_MIN) 1606 114682 SETi( -(IV)result ); 1607 else { 1608 /* result valid, but out of range for IV. */ 1609 7 SETn( -(NV)result ); 1610 } 1611 } 1612 16249656 RETURN; 1613 } /* Overflow, drop through to NVs. */ 1614 } 1615 } 1616 #endif 1617 380186 useleft = USE_LEFT(TOPm1s); 1618 { 1619 380186 dPOPnv; 1620 380186 if (!useleft) { 1621 /* left operand is undef, treat as zero - value */ 1622 3 SETn(-value); 1623 3 RETURN; 1624 } 1625 380183 SETn( TOPn - value ); 1626 380183 RETURN; 1627 } 1628 } 1629 1630 PP(pp_left_shift) 1631 15069 { 1632 15069 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN); 1633 { 1634 15013 const IV shift = POPi; 1635 15013 if (PL_op->op_private & HINT_INTEGER) { 1636 5 IV i = TOPi; 1637 5 SETi(i << shift); 1638 } 1639 else { 1640 15008 UV u = TOPu; 1641 15008 SETu(u << shift); 1642 } 1643 15013 RETURN; 1644 } 1645 } 1646 1647 PP(pp_right_shift) 1648 25405 { 1649 25405 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN); 1650 { 1651 25344 const IV shift = POPi; 1652 25344 if (PL_op->op_private & HINT_INTEGER) { 1653 5 IV i = TOPi; 1654 5 SETi(i >> shift); 1655 } 1656 else { 1657 25339 UV u = TOPu; 1658 25339 SETu(u >> shift); 1659 } 1660 25343 RETURN; 1661 } 1662 } 1663 1664 PP(pp_lt) 1665 15370863 { 1666 15370863 dSP; tryAMAGICbinSET(lt,0); 1667 #ifdef PERL_PRESERVE_IVUV 1668 15370825 SvIV_please(TOPs); 1669 15370825 if (SvIOK(TOPs)) { 1670 15284112 SvIV_please(TOPm1s); 1671 15284112 if (SvIOK(TOPm1s)) { 1672 15260279 bool auvok = SvUOK(TOPm1s); 1673 15260279 bool buvok = SvUOK(TOPs); 1674 1675 15260279 if (!auvok && !buvok) { /* ## IV < IV ## */ 1676 15256923 const IV aiv = SvIVX(TOPm1s); 1677 15256923 const IV biv = SvIVX(TOPs); 1678 1679 15256923 SP--; 1680 15256923 SETs(boolSV(aiv < biv)); 1681 15256923 RETURN; 1682 } 1683 3356 if (auvok && buvok) { /* ## UV < UV ## */ 1684 92 const UV auv = SvUVX(TOPm1s); 1685 92 const UV buv = SvUVX(TOPs); 1686 1687 92 SP--; 1688 92 SETs(boolSV(auv < buv)); 1689 92 RETURN; 1690 } 1691 3264 if (auvok) { /* ## UV < IV ## */ 1692 1998 UV auv; 1693 1998 const IV biv = SvIVX(TOPs); 1694 1998 SP--; 1695 1998 if (biv < 0) { 1696 /* As (a) is a UV, it's >=0, so it cannot be < */ 1697 10 SETs(&PL_sv_no); 1698 10 RETURN; 1699 } 1700 1988 auv = SvUVX(TOPs); 1701 1988 SETs(boolSV(auv < (UV)biv)); 1702 1988 RETURN; 1703 } 1704 { /* ## IV < UV ## */ 1705 1266 const IV aiv = SvIVX(TOPm1s); 1706 1266 UV buv; 1707 1708 1266 if (aiv < 0) { 1709 /* As (b) is a UV, it's >=0, so it must be < */ 1710 8 SP--; 1711 8 SETs(&PL_sv_yes); 1712 8 RETURN; 1713 } 1714 1258 buv = SvUVX(TOPs); 1715 1258 SP--; 1716 1258 SETs(boolSV((UV)aiv < buv)); 1717 1258 RETURN; 1718 } 1719 } 1720 } 1721 #endif 1722 #ifndef NV_PRESERVES_UV 1723 #ifdef PERL_PRESERVE_IVUV 1724 else 1725 #endif 1726 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) { 1727 SP--; 1728 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s))); 1729 RETURN; 1730 } 1731 #endif 1732 { 1733 110546 dPOPnv; 1734 110546 SETs(boolSV(TOPn < value)); 1735 110546 RETURN; 1736 } 1737 } 1738 1739 PP(pp_gt) 1740 1574568 { 1741 1574568 dSP; tryAMAGICbinSET(gt,0); 1742 #ifdef PERL_PRESERVE_IVUV 1743 1574521 SvIV_please(TOPs); 1744 1574521 if (SvIOK(TOPs)) { 1745 1440172 SvIV_please(TOPm1s); 1746 1440172 if (SvIOK(TOPm1s)) { 1747 1434282 bool auvok = SvUOK(TOPm1s); 1748 1434282 bool buvok = SvUOK(TOPs); 1749 1750 1434282 if (!auvok && !buvok) { /* ## IV > IV ## */ 1751 1433079 const IV aiv = SvIVX(TOPm1s); 1752 1433079 const IV biv = SvIVX(TOPs); 1753 1754 1433079 SP--; 1755 1433079 SETs(boolSV(aiv > biv)); 1756 1433079 RETURN; 1757 } 1758 1203 if (auvok && buvok) { /* ## UV > UV ## */ 1759 26 const UV auv = SvUVX(TOPm1s); 1760 26 const UV buv = SvUVX(TOPs); 1761 1762 26 SP--; 1763 26 SETs(boolSV(auv > buv)); 1764 26 RETURN; 1765 } 1766 1177 if (auvok) { /* ## UV > IV ## */ 1767 52 UV auv; 1768 52 const IV biv = SvIVX(TOPs); 1769 1770 52 SP--; 1771 52 if (biv < 0) { 1772 /* As (a) is a UV, it's >=0, so it must be > */ 1773 8 SETs(&PL_sv_yes); 1774 8 RETURN; 1775 } 1776 44 auv = SvUVX(TOPs); 1777 44 SETs(boolSV(auv > (UV)biv)); 1778 44 RETURN; 1779 } 1780 { /* ## IV > UV ## */ 1781 1125 const IV aiv = SvIVX(TOPm1s); 1782 1125 UV buv; 1783 1784 1125 if (aiv < 0) { 1785 /* As (b) is a UV, it's >=0, so it cannot be > */ 1786 9 SP--; 1787 9 SETs(&PL_sv_no); 1788 9 RETURN; 1789 } 1790 1116 buv = SvUVX(TOPs); 1791 1116 SP--; 1792 1116 SETs(boolSV((UV)aiv > buv)); 1793 1116 RETURN; 1794 } 1795 } 1796 } 1797 #endif 1798 #ifndef NV_PRESERVES_UV 1799 #ifdef PERL_PRESERVE_IVUV 1800 else 1801 #endif 1802 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) { 1803 SP--; 1804 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s))); 1805 RETURN; 1806 } 1807 #endif 1808 { 1809 140239 dPOPnv; 1810 140239 SETs(boolSV(TOPn > value)); 1811 140239 RETURN; 1812 } 1813 } 1814 1815 PP(pp_le) 1816 2039569 { 1817 2039569 dSP; tryAMAGICbinSET(le,0); 1818 #ifdef PERL_PRESERVE_IVUV 1819 2039550 SvIV_please(TOPs); 1820 2039550 if (SvIOK(TOPs)) { 1821 1833079 SvIV_please(TOPm1s); 1822 1833079 if (SvIOK(TOPm1s)) { 1823 1832961 bool auvok = SvUOK(TOPm1s); 1824 1832961 bool buvok = SvUOK(TOPs); 1825 1826 1832961 if (!auvok && !buvok) { /* ## IV <= IV ## */ 1827 1832851 const IV aiv = SvIVX(TOPm1s); 1828 1832851 const IV biv = SvIVX(TOPs); 1829 1830 1832851 SP--; 1831 1832851 SETs(boolSV(aiv <= biv)); 1832 1832851 RETURN; 1833 } 1834 110 if (auvok && buvok) { /* ## UV <= UV ## */ 1835 10 UV auv = SvUVX(TOPm1s); 1836 10 UV buv = SvUVX(TOPs); 1837 1838 10 SP--; 1839 10 SETs(boolSV(auv <= buv)); 1840 10 RETURN; 1841 } 1842 100 if (auvok) { /* ## UV <= IV ## */ 1843 42 UV auv; 1844 42 const IV biv = SvIVX(TOPs); 1845 1846 42 SP--; 1847 42 if (biv < 0) { 1848 /* As (a) is a UV, it's >=0, so a cannot be <= */ 1849 8 SETs(&PL_sv_no); 1850 8 RETURN; 1851 } 1852 34 auv = SvUVX(TOPs); 1853 34 SETs(boolSV(auv <= (UV)biv)); 1854 34 RETURN; 1855 } 1856 { /* ## IV <= UV ## */ 1857 58 const IV aiv = SvIVX(TOPm1s); 1858 58 UV buv; 1859 1860 58 if (aiv < 0) { 1861 /* As (b) is a UV, it's >=0, so a must be <= */ 1862 8 SP--; 1863 8 SETs(&PL_sv_yes); 1864 8 RETURN; 1865 } 1866 50 buv = SvUVX(TOPs); 1867 50 SP--; 1868 50 SETs(boolSV((UV)aiv <= buv)); 1869 50 RETURN; 1870 } 1871 } 1872 } 1873 #endif 1874 #ifndef NV_PRESERVES_UV 1875 #ifdef PERL_PRESERVE_IVUV 1876 else 1877 #endif 1878 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) { 1879 SP--; 1880 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s))); 1881 RETURN; 1882 } 1883 #endif 1884 { 1885 206589 dPOPnv; 1886 206589 SETs(boolSV(TOPn <= value)); 1887 206589 RETURN; 1888 } 1889 } 1890 1891 PP(pp_ge) 1892 2428266 { 1893 2428266 dSP; tryAMAGICbinSET(ge,0); 1894 #ifdef PERL_PRESERVE_IVUV 1895 2428232 SvIV_please(TOPs); 1896 2428232 if (SvIOK(TOPs)) { 1897 2421831 SvIV_please(TOPm1s); 1898 2421831 if (SvIOK(TOPm1s)) { 1899 2406236 bool auvok = SvUOK(TOPm1s); 1900 2406236 bool buvok = SvUOK(TOPs); 1901 1902 2406236 if (!auvok && !buvok) { /* ## IV >= IV ## */ 1903 2406113 const IV aiv = SvIVX(TOPm1s); 1904 2406113 const IV biv = SvIVX(TOPs); 1905 1906 2406113 SP--; 1907 2406113 SETs(boolSV(aiv >= biv)); 1908 2406113 RETURN; 1909 } 1910 123 if (auvok && buvok) { /* ## UV >= UV ## */ 1911 10 const UV auv = SvUVX(TOPm1s); 1912 10 const UV buv = SvUVX(TOPs); 1913 1914 10 SP--; 1915 10 SETs(boolSV(auv >= buv)); 1916 10 RETURN; 1917 } 1918 113 if (auvok) { /* ## UV >= IV ## */ 1919 65 UV auv; 1920 65 const IV biv = SvIVX(TOPs); 1921 1922 65 SP--; 1923 65 if (biv < 0) { 1924 /* As (a) is a UV, it's >=0, so it must be >= */ 1925 8 SETs(&PL_sv_yes); 1926 8 RETURN; 1927 } 1928 57 auv = SvUVX(TOPs); 1929 57 SETs(boolSV(auv >= (UV)biv)); 1930 57 RETURN; 1931 } 1932 { /* ## IV >= UV ## */ 1933 48 const IV aiv = SvIVX(TOPm1s); 1934 48 UV buv; 1935 1936 48 if (aiv < 0) { 1937 /* As (b) is a UV, it's >=0, so a cannot be >= */ 1938 8 SP--; 1939 8 SETs(&PL_sv_no); 1940 8 RETURN; 1941 } 1942 40 buv = SvUVX(TOPs); 1943 40 SP--; 1944 40 SETs(boolSV((UV)aiv >= buv)); 1945 40 RETURN; 1946 } 1947 } 1948 } 1949 #endif 1950 #ifndef NV_PRESERVES_UV 1951 #ifdef PERL_PRESERVE_IVUV 1952 else 1953 #endif 1954 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) { 1955 SP--; 1956 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s))); 1957 RETURN; 1958 } 1959 #endif 1960 { 1961 21996 dPOPnv; 1962 21996 SETs(boolSV(TOPn >= value)); 1963 21996 RETURN; 1964 } 1965 } 1966 1967 PP(pp_ne) 1968 840062 { 1969 840062 dSP; tryAMAGICbinSET(ne,0); 1970 #ifndef NV_PRESERVES_UV 1971 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) { 1972 SP--; 1973 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s))); 1974 RETURN; 1975 } 1976 #endif 1977 #ifdef PERL_PRESERVE_IVUV 1978 840046 SvIV_please(TOPs); 1979 840046 if (SvIOK(TOPs)) { 1980 315923 SvIV_please(TOPm1s); 1981 315923 if (SvIOK(TOPm1s)) { 1982 315531 bool auvok = SvUOK(TOPm1s); 1983 315531 bool buvok = SvUOK(TOPs); 1984 1985 315531 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */ 1986 /* Casting IV to UV before comparison isn't going to matter 1987 on 2s complement. On 1s complement or sign&magnitude 1988 (if we have any of them) it could make negative zero 1989 differ from normal zero. As I understand it. (Need to 1990 check - is negative zero implementation defined behaviour 1991 anyway?). NWC */ 1992 315434 const UV buv = SvUVX(POPs); 1993 315434 const UV auv = SvUVX(TOPs); 1994 1995 315434 SETs(boolSV(auv != buv)); 1996 315434 RETURN; 1997 } 1998 { /* ## Mixed IV,UV ## */ 1999 97 IV iv; 2000 97 UV uv; 2001 2002 /* != is commutative so swap if needed (save code) */ 2003 97 if (auvok) { 2004 /* swap. top of stack (b) is the iv */ 2005 34 iv = SvIVX(TOPs); 2006 34 SP--; 2007 34 if (iv < 0) { 2008 /* As (a) is a UV, it's >0, so it cannot be == */ 2009 10 SETs(&PL_sv_yes); 2010 10 RETURN; 2011 } 2012 24 uv = SvUVX(TOPs); 2013 } else { 2014 63 iv = SvIVX(TOPm1s); 2015 63 SP--; 2016 63 if (iv < 0) { 2017 /* As (b) is a UV, it's >0, so it cannot be == */ 2018 8 SETs(&PL_sv_yes); 2019 8 RETURN; 2020 } 2021 55 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */ 2022 } 2023 79 SETs(boolSV((UV)iv != uv)); 2024 79 RETURN; 2025 } 2026 } 2027 } 2028 #endif 2029 { 2030 524515 dPOPnv; 2031 524515 SETs(boolSV(TOPn != value)); 2032 524515 RETURN; 2033 } 2034 } 2035 2036 PP(pp_ncmp) 2037 1404221 { 2038 1404221 dSP; dTARGET; tryAMAGICbin(ncmp,0); 2039 #ifndef NV_PRESERVES_UV 2040 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) { 2041 UV right = PTR2UV(SvRV(POPs)); 2042 UV left = PTR2UV(SvRV(TOPs)); 2043 SETi((left > right) - (left < right)); 2044 RETURN; 2045 } 2046 #endif 2047 #ifdef PERL_PRESERVE_IVUV 2048 /* Fortunately it seems NaN isn't IOK */ 2049 1403782 SvIV_please(TOPs); 2050 1403782 if (SvIOK(TOPs)) { 2051 1403151 SvIV_please(TOPm1s); 2052 1403151 if (SvIOK(TOPm1s)) { 2053 1402915 const bool leftuvok = SvUOK(TOPm1s); 2054 1402915 const bool rightuvok = SvUOK(TOPs); 2055 1402915 I32 value; 2056 1402915 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */ 2057 1402635 const IV leftiv = SvIVX(TOPm1s); 2058 1402635 const IV rightiv = SvIVX(TOPs); 2059 2060 1402635 if (leftiv > rightiv) 2061 139430 value = 1; 2062 1263205 else if (leftiv < rightiv) 2063 372845 value = -1; 2064 else 2065 890360 value = 0; 2066 280 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */ 2067 20 const UV leftuv = SvUVX(TOPm1s); 2068 20 const UV rightuv = SvUVX(TOPs); 2069 2070 20 if (leftuv > rightuv) 2071 5 value = 1; 2072 15 else if (leftuv < rightuv) 2073 5 value = -1; 2074 else 2075 10 value = 0; 2076 260 } else if (leftuvok) { /* ## UV <=> IV ## */ 2077 180 const IV rightiv = SvIVX(TOPs); 2078 180 if (rightiv < 0) { 2079 /* As (a) is a UV, it's >=0, so it cannot be < */ 2080 16 value = 1; 2081 } else { 2082 164 const UV leftuv = SvUVX(TOPm1s); 2083 164 if (leftuv > (UV)rightiv) { 2084 164 value = 1; 2085 ###### } else if (leftuv < (UV)rightiv) { 2086 ###### value = -1; 2087 } else { 2088 ###### value = 0; 2089 } 2090 } 2091 } else { /* ## IV <=> UV ## */ 2092 80 const IV leftiv = SvIVX(TOPm1s); 2093 80 if (leftiv < 0) { 2094 /* As (b) is a UV, it's >=0, so it must be < */ 2095 16 value = -1; 2096 } else { 2097 64 const UV rightuv = SvUVX(TOPs); 2098 64 if ((UV)leftiv > rightuv) { 2099 ###### value = 1; 2100 64 } else if ((UV)leftiv < rightuv) { 2101 64 value = -1; 2102 } else { 2103 ###### value = 0; 2104 } 2105 } 2106 } 2107 1402915 SP--; 2108 1402915 SETi(value); 2109 1402915 RETURN; 2110 } 2111 } 2112 #endif 2113 { 2114 867 dPOPTOPnnrl; 2115 867 I32 value; 2116 2117 #ifdef Perl_isnan 2118 867 if (Perl_isnan(left) || Perl_isnan(right)) { 2119 ###### SETs(&PL_sv_undef); 2120 ###### RETURN; 2121 } 2122 867 value = (left > right) - (left < right); 2123 #else 2124 if (left == right) 2125 value = 0; 2126 else if (left < right) 2127 value = -1; 2128 else if (left > right) 2129 value = 1; 2130 else { 2131 SETs(&PL_sv_undef); 2132 RETURN; 2133 } 2134 #endif 2135 867 SETi(value); 2136 867 RETURN; 2137 } 2138 } 2139 2140 PP(pp_slt) 2141 2838 { 2142 2838 dSP; tryAMAGICbinSET(slt,0); 2143 { 2144 2831 dPOPTOPssrl; 2145 2831 const int cmp = (IN_LOCALE_RUNTIME 2146 ? sv_cmp_locale(left, right) 2147 2831 : sv_cmp(left, right)); 2148 2831 SETs(boolSV(cmp < 0)); 2149 2831 RETURN; 2150 } 2151 } 2152 2153 PP(pp_sgt) 2154 861 { 2155 861 dSP; tryAMAGICbinSET(sgt,0); 2156 { 2157 853 dPOPTOPssrl; 2158 853 const int cmp = (IN_LOCALE_RUNTIME 2159 ? sv_cmp_locale(left, right) 2160 853 : sv_cmp(left, right)); 2161 853 SETs(boolSV(cmp > 0)); 2162 853 RETURN; 2163 } 2164 } 2165 2166 PP(pp_sle) 2167 52469 { 2168 52469 dSP; tryAMAGICbinSET(sle,0); 2169 { 2170 52469 dPOPTOPssrl; 2171 52469 const int cmp = (IN_LOCALE_RUNTIME 2172 ? sv_cmp_locale(left, right) 2173 52469 : sv_cmp(left, right)); 2174 52469 SETs(boolSV(cmp <= 0)); 2175 52469 RETURN; 2176 } 2177 } 2178 2179 PP(pp_sge) 2180 6121 { 2181 6121 dSP; tryAMAGICbinSET(sge,0); 2182 { 2183 6121 dPOPTOPssrl; 2184 6121 const int cmp = (IN_LOCALE_RUNTIME 2185 ? sv_cmp_locale(left, right) 2186 6121 : sv_cmp(left, right)); 2187 6121 SETs(boolSV(cmp >= 0)); 2188 6121 RETURN; 2189 } 2190 } 2191 2192 PP(pp_seq) 2193 3579359 { 2194 3579359 dSP; tryAMAGICbinSET(seq,0); 2195 { 2196 3566863 dPOPTOPssrl; 2197 3566863 SETs(boolSV(sv_eq(left, right))); 2198 3566863 RETURN; 2199 } 2200 } 2201 2202 PP(pp_sne) 2203 235180 { 2204 235180 dSP; tryAMAGICbinSET(sne,0); 2205 { 2206 235171 dPOPTOPssrl; 2207 235171 SETs(boolSV(!sv_eq(left, right))); 2208 235171 RETURN; 2209 } 2210 } 2211 2212 PP(pp_scmp) 2213 1767764 { 2214 1767764 dSP; dTARGET; tryAMAGICbin(scmp,0); 2215 { 2216 1767753 dPOPTOPssrl; 2217 1767753 const int cmp = (IN_LOCALE_RUNTIME 2218 ? sv_cmp_locale(left, right) 2219 1767753 : sv_cmp(left, right)); 2220 1767753 SETi( cmp ); 2221 1767753 RETURN; 2222 } 2223 } 2224 2225 PP(pp_bit_and) 2226 460155 { 2227 460155 dSP; dATARGET; tryAMAGICbin(band,opASSIGN); 2228 { 2229 460012 dPOPTOPssrl; 2230 460012 if (SvGMAGICAL(left)) mg_get(left); 2231 460012 if (SvGMAGICAL(right)) mg_get(right); 2232 460012 if (SvNIOKp(left) || SvNIOKp(right)) { 2233 456076 if (PL_op->op_private & HINT_INTEGER) { 2234 639 const IV i = SvIV_nomg(left) & SvIV_nomg(right); 2235 639 SETi(i); 2236 } 2237 else { 2238 455437 const UV u = SvUV_nomg(left) & SvUV_nomg(right); 2239 455437 SETu(u); 2240 } 2241 } 2242 else { 2243 3936 do_vop(PL_op->op_type, TARG, left, right); 2244 3936 SETTARG; 2245 } 2246 460012 RETURN; 2247 } 2248 } 2249 2250 PP(pp_bit_xor) 2251 26116 { 2252 26116 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN); 2253 { 2254 25914 dPOPTOPssrl; 2255 25914 if (SvGMAGICAL(left)) mg_get(left); 2256 25914 if (SvGMAGICAL(right)) mg_get(right); 2257 25914 if (SvNIOKp(left) || SvNIOKp(right)) { 2258 25851 if (PL_op->op_private & HINT_INTEGER) { 2259 669 const IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) ^ SvIV_nomg(right); 2260 669 SETi(i); 2261 } 2262 else { 2263 25182 const UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) ^ SvUV_nomg(right); 2264 25182 SETu(u); 2265 } 2266 } 2267 else { 2268 63 do_vop(PL_op->op_type, TARG, left, right); 2269 63 SETTARG; 2270 } 2271 25914 RETURN; 2272 } 2273 } 2274 2275 PP(pp_bit_or) 2276 84360 { 2277 84360 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN); 2278 { 2279 84155 dPOPTOPssrl; 2280 84155 if (SvGMAGICAL(left)) mg_get(left); 2281 84155 if (SvGMAGICAL(right)) mg_get(right); 2282 84155 if (SvNIOKp(left) || SvNIOKp(right)) { 2283 53644 if (PL_op->op_private & HINT_INTEGER) { 2284 669 const IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) | SvIV_nomg(right); 2285 669 SETi(i); 2286 } 2287 else { 2288 52975 const UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) | SvUV_nomg(right); 2289 52975 SETu(u); 2290 } 2291 } 2292 else { 2293 30511 do_vop(PL_op->op_type, TARG, left, right); 2294 30511 SETTARG; 2295 } 2296 84155 RETURN; 2297 } 2298 } 2299 2300 PP(pp_negate) 2301 1397792 { 2302 1397792 dSP; dTARGET; tryAMAGICun(neg); 2303 { 2304 1397681 dTOPss; 2305 1397681 const int flags = SvFLAGS(sv); 2306 1397681 if (SvGMAGICAL(sv)) 2307 ###### mg_get(sv); 2308 1397681 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) { 2309 /* It's publicly an integer, or privately an integer-not-float */ 2310 oops_its_an_int: 2311 1354940 if (SvIsUV(sv)) { 2312 111 if (SvIVX(sv) == IV_MIN) { 2313 /* 2s complement assumption. */ 2314 78 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */ 2315 78 RETURN; 2316 } 2317 33 else if (SvUVX(sv) <= IV_MAX) { 2318 ###### SETi(-SvIVX(sv)); 2319 ###### RETURN; 2320 } 2321 } 2322 1354829 else if (SvIVX(sv) != IV_MIN) { 2323 1354829 SETi(-SvIVX(sv)); 2324 1354829 RETURN; 2325 } 2326 #ifdef PERL_PRESERVE_IVUV 2327 else { 2328 ###### SETu((UV)IV_MIN); 2329 ###### RETURN; 2330 } 2331 #endif 2332 } 2333 42778 if (SvNIOKp(sv)) 2334 876 SETn(-SvNV(sv)); 2335 41902 else if (SvPOKp(sv)) { 2336 41897 STRLEN len; 2337 41897 const char *s = SvPV_const(sv, len); 2338 41897 if (isIDFIRST(*s)) { 2339 41893 sv_setpvn(TARG, "-", 1); 2340 41893 sv_catsv(TARG, sv); 2341 } 2342 4 else if (*s == '+' || *s == '-') { 2343 ###### sv_setsv(TARG, sv); 2344 ###### *SvPV_force(TARG, len) = *s == '-' ? '+' : '-'; 2345 } 2346 4 else if (DO_UTF8(sv)) { 2347 2 SvIV_please(sv); 2348 2 if (SvIOK(sv)) 2349 2 goto oops_its_an_int; 2350 ###### if (SvNOK(sv)) 2351 ###### sv_setnv(TARG, -SvNV(sv)); 2352 else { 2353 ###### sv_setpvn(TARG, "-", 1); 2354 ###### sv_catsv(TARG, sv); 2355 } 2356 } 2357 else { 2358 2 SvIV_please(sv); 2359 2 if (SvIOK(sv)) 2360 2 goto oops_its_an_int; 2361 ###### sv_setnv(TARG, -SvNV(sv)); 2362 } 2363 41893 SETTARG; 2364 } 2365 else 2366 5 SETn(-SvNV(sv)); 2367 } 2368 42774 RETURN; 2369 } 2370 2371 PP(pp_not) 2372 2822664 { 2373 2822664 dSP; tryAMAGICunSET(not); 2374 2822659 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp)); 2375 2822659 return NORMAL; 2376 } 2377 2378 PP(pp_complement) 2379 63607 { 2380 63607 dSP; dTARGET; tryAMAGICun(compl); 2381 { 2382 63584 dTOPss; 2383 63584 if (SvGMAGICAL(sv)) 2384 3 mg_get(sv); 2385 63584 if (SvNIOKp(sv)) { 2386 26551 if (PL_op->op_private & HINT_INTEGER) { 2387 3 const IV i = ~SvIV_nomg(sv); 2388 3 SETi(i); 2389 } 2390 else { 2391 26548 const UV u = ~SvUV_nomg(sv); 2392 26548 SETu(u); 2393 } 2394 } 2395 else { 2396 37033 register U8 *tmps; 2397 37033 register I32 anum; 2398 37033 STRLEN len; 2399 2400 37033 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */ 2401 37033 sv_setsv_nomg(TARG, sv); 2402 37033 tmps = (U8*)SvPV_force(TARG, len); 2403 37033 anum = len; 2404 37033 if (SvUTF8(TARG)) { 2405 /* Calculate exact length, let's not estimate. */ 2406 25198 STRLEN targlen = 0; 2407 25198 U8 *result; 2408 25198 U8 *send; 2409 25198 STRLEN l; 2410 25198 UV nchar = 0; 2411 25198 UV nwide = 0; 2412 2413 25198 send = tmps + len; 2414 61378 while (tmps < send) { 2415 36180 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV); 2416 36180 tmps += UTF8SKIP(tmps); 2417 36180 targlen += UNISKIP(~c); 2418 36180 nchar++; 2419 36180 if (c > 0xff) 2420 31315 nwide++; 2421 } 2422 2423 /* Now rewind strings and write them. */ 2424 25198 tmps -= len; 2425 2426 25198 if (nwide) { 2427 25197 Newz(0, result, targlen + 1, U8); 2428 61376 while (tmps < send) { 2429 36179 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV); 2430 36179 tmps += UTF8SKIP(tmps); 2431 36179 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY); 2432 } 2433 25197 *result = '\0'; 2434 25197 result -= targlen; 2435 25197 sv_setpvn(TARG, (char*)result, targlen); 2436 25197 SvUTF8_on(TARG); 2437 } 2438 else { 2439 1 Newz(0, result, nchar + 1, U8); 2440 2 while (tmps < send) { 2441 1 const U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY); 2442 1 tmps += UTF8SKIP(tmps); 2443 1 *result++ = ~c; 2444 } 2445 1 *result = '\0'; 2446 1 result -= nchar; 2447 1 sv_setpvn(TARG, (char*)result, nchar); 2448 1 SvUTF8_off(TARG); 2449 } 2450 25198 Safefree(result); 2451 25198 SETs(TARG); 2452 25198 RETURN; 2453 } 2454 #ifdef LIBERAL 2455 { 2456 11835 register long *tmpl; 2457 11835 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++) 2458 ###### *tmps = ~*tmps; 2459 11835 tmpl = (long*)tmps; 2460 63535 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++) 2461 25850 *tmpl = ~*tmpl; 2462 11835 tmps = (U8*)tmpl; 2463 } 2464 #endif 2465 12689 for ( ; anum > 0; anum--, tmps++) 2466 427 *tmps = ~*tmps; 2467 2468 11835 SETs(TARG); 2469 } 2470 38386 RETURN; 2471 } 2472 } 2473 2474 /* integer versions of some of the above */ 2475 2476 PP(pp_i_multiply) 2477 281 { 2478 281 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN); 2479 { 2480 281 dPOPTOPiirl; 2481 281 SETi( left * right ); 2482 281 RETURN; 2483 } 2484 } 2485 2486 PP(pp_i_divide) 2487 119 { 2488 119 dSP; dATARGET; tryAMAGICbin(div,opASSIGN); 2489 { 2490 119 dPOPiv; 2491 119 if (value == 0) 2492 1 DIE(aTHX_ "Illegal division by zero"); 2493 118 value = POPi / value; 2494 118 PUSHi( value ); 2495 118 RETURN; 2496 } 2497 } 2498 2499 STATIC 2500 PP(pp_i_modulo_0) 2501 404 { 2502 /* This is the vanilla old i_modulo. */ 2503 404 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); 2504 { 2505 404 dPOPTOPiirl; 2506 404 if (!right) 2507 ###### DIE(aTHX_ "Illegal modulus zero"); 2508 404 SETi( left % right ); 2509 404 RETURN; 2510 } 2511 } 2512 2513 #if defined(__GLIBC__) && IVSIZE == 8 2514 STATIC 2515 PP(pp_i_modulo_1) 2516 { 2517 /* This is the i_modulo with the workaround for the _moddi3 bug 2518 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround). 2519 * See below for pp_i_modulo. */ 2520 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); 2521 { 2522 dPOPTOPiirl; 2523 if (!right) 2524 DIE(aTHX_ "Illegal modulus zero"); 2525 SETi( left % PERL_ABS(right) ); 2526 RETURN; 2527 } 2528 } 2529 #endif 2530 2531 PP(pp_i_modulo) 2532 49 { 2533 49 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); 2534 { 2535 49 dPOPTOPiirl; 2536 49 if (!right) 2537 1 DIE(aTHX_ "Illegal modulus zero"); 2538 /* The assumption is to use hereafter the old vanilla version... */ 2539 48 PL_op->op_ppaddr = 2540 PL_ppaddr[OP_I_MODULO] = 2541 Perl_pp_i_modulo_0; 2542 /* .. but if we have glibc, we might have a buggy _moddi3 2543 * (at least glicb 2.2.5 is known to have this bug), in other 2544 * words our integer modulus with negative quad as the second 2545 * argument might be broken. Test for this and re-patch the 2546 * opcode dispatch table if that is the case, remembering to 2547 * also apply the workaround so that this first round works 2548 * right, too. See [perl #9402] for more information. */ 2549 #if defined(__GLIBC__) && IVSIZE == 8 2550 { 2551 IV l = 3; 2552 IV r = -10; 2553 /* Cannot do this check with inlined IV constants since 2554 * that seems to work correctly even with the buggy glibc. */ 2555 if (l % r == -3) { 2556 /* Yikes, we have the bug. 2557 * Patch in the workaround version. */ 2558 PL_op->op_ppaddr = 2559 PL_ppaddr[OP_I_MODULO] = 2560 &Perl_pp_i_modulo_1; 2561 /* Make certain we work right this time, too. */ 2562 right = PERL_ABS(right); 2563 } 2564 } 2565 #endif 2566 48 SETi( left % right ); 2567 48 RETURN; 2568 } 2569 } 2570 2571 PP(pp_i_add) 2572 23114 { 2573 23114 dSP; dATARGET; tryAMAGICbin(add,opASSIGN); 2574 { 2575 23114 dPOPTOPiirl_ul; 2576 23114 SETi( left + right ); 2577 23114 RETURN; 2578 } 2579 } 2580 2581 PP(pp_i_subtract) 2582 2277 { 2583 2277 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); 2584 { 2585 2277 dPOPTOPiirl_ul; 2586 2277 SETi( left - right ); 2587 2277 RETURN; 2588 } 2589 } 2590 2591 PP(pp_i_lt) 2592 3915 { 2593 3915 dSP; tryAMAGICbinSET(lt,0); 2594 { 2595 3915 dPOPTOPiirl; 2596 3915 SETs(boolSV(left < right)); 2597 3915 RETURN; 2598 } 2599 } 2600 2601 PP(pp_i_gt) 2602 790 { 2603 790 dSP; tryAMAGICbinSET(gt,0); 2604 { 2605 790 dPOPTOPiirl; 2606 790 SETs(boolSV(left > right)); 2607 790 RETURN; 2608 } 2609 } 2610 2611 PP(pp_i_le) 2612 206 { 2613 206 dSP; tryAMAGICbinSET(le,0); 2614 { 2615 206 dPOPTOPiirl; 2616 206 SETs(boolSV(left <= right)); 2617 206 RETURN; 2618 } 2619 } 2620 2621 PP(pp_i_ge) 2622 219 { 2623 219 dSP; tryAMAGICbinSET(ge,0); 2624 { 2625 219 dPOPTOPiirl; 2626 219 SETs(boolSV(left >= right)); 2627 219 RETURN; 2628 } 2629 } 2630 2631 PP(pp_i_eq) 2632 3687 { 2633 3687 dSP; tryAMAGICbinSET(eq,0); 2634 { 2635 3687 dPOPTOPiirl; 2636 3687 SETs(boolSV(left == right)); 2637 3687 RETURN; 2638 } 2639 } 2640 2641 PP(pp_i_ne) 2642 46 { 2643 46 dSP; tryAMAGICbinSET(ne,0); 2644 { 2645 46 dPOPTOPiirl; 2646 46 SETs(boolSV(left != right)); 2647 46 RETURN; 2648 } 2649 } 2650 2651 PP(pp_i_ncmp) 2652 5 { 2653 5 dSP; dTARGET; tryAMAGICbin(ncmp,0); 2654 { 2655 5 dPOPTOPiirl; 2656 5 I32 value; 2657 2658 5 if (left > right) 2659 ###### value = 1; 2660 5 else if (left < right) 2661 ###### value = -1; 2662 else 2663 5 value = 0; 2664 5 SETi(value); 2665 5 RETURN; 2666 } 2667 } 2668 2669 PP(pp_i_negate) 2670 86 { 2671 86 dSP; dTARGET; tryAMAGICun(neg); 2672 86 SETi(-TOPi); 2673 86 RETURN; 2674 } 2675 2676 /* High falutin' math. */ 2677 2678 PP(pp_atan2) 2679 974 { 2680 974 dSP; dTARGET; tryAMAGICbin(atan2,0); 2681 { 2682 968 dPOPTOPnnrl; 2683 968 SETn(Perl_atan2(left, right)); 2684 968 RETURN; 2685 } 2686 } 2687 2688 PP(pp_sin) 2689 1570 { 2690 1570 dSP; dTARGET; tryAMAGICun(sin); 2691 { 2692 1506 const NV value = POPn; 2693 1506 XPUSHn(Perl_sin(value)); 2694 1506 RETURN; 2695 } 2696 } 2697 2698 PP(pp_cos) 2699 1537 { 2700 1537 dSP; dTARGET; tryAMAGICun(cos); 2701 { 2702 1473 const NV value = POPn; 2703 1473 XPUSHn(Perl_cos(value)); 2704 1473 RETURN; 2705 } 2706 } 2707 2708 /* Support Configure command-line overrides for rand() functions. 2709 After 5.005, perhaps we should replace this by Configure support 2710 for drand48(), random(), or rand(). For 5.005, though, maintain 2711 compatibility by calling rand() but allow the user to override it. 2712 See INSTALL for details. --Andy Dougherty 15 July 1998 2713 */ 2714 /* Now it's after 5.005, and Configure supports drand48() and random(), 2715 in addition to rand(). So the overrides should not be needed any more. 2716 --Jarkko Hietaniemi 27 September 1998 2717 */ 2718 2719 #ifndef HAS_DRAND48_PROTO 2720 extern double drand48 (void); 2721 #endif 2722 2723 PP(pp_rand) 2724 390198 { 2725 390198 dSP; dTARGET; 2726 390198 NV value; 2727 390198 if (MAXARG < 1) 2728 48367 value = 1.0; 2729 else 2730 341831 value = POPn; 2731 390198 if (value == 0.0) 2732 1 value = 1.0; 2733 390198 if (!PL_srand_called) { 2734 35 (void)seedDrand01((Rand_seed_t)seed()); 2735 35 PL_srand_called = TRUE; 2736 } 2737 390198 value *= Drand01(); 2738 390198 XPUSHn(value); 2739 390198 RETURN; 2740 } 2741 2742 PP(pp_srand) 2743 21 { 2744 21 dSP; 2745 21 UV anum; 2746 21 if (MAXARG < 1) 2747 4 anum = seed(); 2748 else 2749 17 anum = POPu; 2750 21 (void)seedDrand01((Rand_seed_t)anum); 2751 21 PL_srand_called = TRUE; 2752 21 EXTEND(SP, 1); 2753 21 RETPUSHYES; 2754 } 2755 2756 PP(pp_exp) 2757 1039 { 2758 1039 dSP; dTARGET; tryAMAGICun(exp); 2759 { 2760 959 NV value; 2761 959 value = POPn; 2762 959 value = Perl_exp(value); 2763 959 XPUSHn(value); 2764 959 RETURN; 2765 } 2766 } 2767 2768 PP(pp_log) 2769 860 { 2770 860 dSP; dTARGET; tryAMAGICun(log); 2771 { 2772 860 const NV value = POPn; 2773 860 if (value <= 0.0) { 2774 2 SET_NUMERIC_STANDARD(); 2775 2 DIE(aTHX_ "Can't take log of %"NVgf, value); 2776 } 2777 858 XPUSHn(Perl_log(value)); 2778 858 RETURN; 2779 } 2780 } 2781 2782 PP(pp_sqrt) 2783 1320229 { 2784 1320229 dSP; dTARGET; tryAMAGICun(sqrt); 2785 { 2786 1320218 const NV value = POPn; 2787 1320218 if (value < 0.0) { 2788 ###### SET_NUMERIC_STANDARD(); 2789 ###### DIE(aTHX_ "Can't take sqrt of %"NVgf, value); 2790 } 2791 1320218 XPUSHn(Perl_sqrt(value)); 2792 1320218 RETURN; 2793 } 2794 } 2795 2796 PP(pp_int) 2797 831612 { 2798 831612 dSP; dTARGET; tryAMAGICun(int); 2799 { 2800 831554 const IV iv = TOPi; /* attempt to convert to IV if possible. */ 2801 /* XXX it's arguable that compiler casting to IV might be subtly 2802 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which 2803 else preferring IV has introduced a subtle behaviour change bug. OTOH 2804 relying on floating point to be accurate is a bug. */ 2805 2806 831554 if (!SvOK(TOPs)) 2807 1 SETu(0); 2808 831553 else if (SvIOK(TOPs)) { 2809 210821 if (SvIsUV(TOPs)) { 2810 62 const UV uv = TOPu; 2811 62 SETu(uv); 2812 } else 2813 210759 SETi(iv); 2814 } else { 2815 620732 const NV value = TOPn; 2816 620732 if (value >= 0.0) { 2817 620223 if (value < (NV)UV_MAX + 0.5) { 2818 619585 SETu(U_V(value)); 2819 } else { 2820 638 SETn(Perl_floor(value)); 2821 } 2822 } 2823 else { 2824 509 if (value > (NV)IV_MIN - 0.5) { 2825 508 SETi(I_V(value)); 2826 } else { 2827 1 SETn(Perl_ceil(value)); 2828 } 2829 } 2830 } 2831 } 2832 831554 RETURN; 2833 } 2834 2835 PP(pp_abs) 2836 7520 { 2837 7520 dSP; dTARGET; tryAMAGICun(abs); 2838 { 2839 /* This will cache the NV value if string isn't actually integer */ 2840 6726 const IV iv = TOPi; 2841 2842 6726 if (!SvOK(TOPs)) 2843 1 SETu(0); 2844 6725 else if (SvIOK(TOPs)) { 2845 /* IVX is precise */ 2846 6426 if (SvIsUV(TOPs)) { 2847 ###### SETu(TOPu); /* force it to be numeric only */ 2848 } else { 2849 6426 if (iv >= 0) { 2850 5725 SETi(iv); 2851 } else { 2852 701 if (iv != IV_MIN) { 2853 701 SETi(-iv); 2854 } else { 2855 /* 2s complement assumption. Also, not really needed as 2856 IV_MIN and -IV_MIN should both be %100...00 and NV-able */ 2857 ###### SETu(IV_MIN); 2858 } 2859 } 2860 } 2861 } else{ 2862 299 const NV value = TOPn; 2863 299 if (value < 0.0) 2864 56 SETn(value); 2865 else 2866 243 SETn(-value); 2867 } 2868 } 2869 6726 RETURN; 2870 } 2871 2872 2873 PP(pp_hex) 2874 1901780 { 2875 1901780 dSP; dTARGET; 2876 1901780 const char *tmps; 2877 1901780 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES; 2878 1901780 STRLEN len; 2879 1901780 NV result_nv; 2880 1901780 UV result_uv; 2881 1901780 SV* const sv = POPs; 2882 2883 1901780 tmps = (SvPV_const(sv, len)); 2884 1901780 if (DO_UTF8(sv)) { 2885 /* If Unicode, try to downgrade 2886 * If not possible, croak. */ 2887 499 SV* const tsv = sv_2mortal(newSVsv(sv)); 2888 2889 499 SvUTF8_on(tsv); 2890 499 sv_utf8_downgrade(tsv, FALSE); 2891 498 tmps = SvPV_const(tsv, len); 2892 } 2893 1901779 result_uv = grok_hex (tmps, &len, &flags, &result_nv); 2894 1901779 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) { 2895 4 XPUSHn(result_nv); 2896 } 2897 else { 2898 1901775 XPUSHu(result_uv); 2899 } 2900 1901779 RETURN; 2901 } 2902 2903 PP(pp_oct) 2904 2965 { 2905 2965 dSP; dTARGET; 2906 2965 const char *tmps; 2907 2965 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES; 2908 2965 STRLEN len; 2909 2965 NV result_nv; 2910 2965 UV result_uv; 2911 2965 SV* const sv = POPs; 2912 2913 2965 tmps = (SvPV_const(sv, len)); 2914 2965 if (DO_UTF8(sv)) { 2915 /* If Unicode, try to downgrade 2916 * If not possible, croak. */ 2917 1 SV* const tsv = sv_2mortal(newSVsv(sv)); 2918 2919 1 SvUTF8_on(tsv); 2920 1 sv_utf8_downgrade(tsv, FALSE); 2921 ###### tmps = SvPV_const(tsv, len); 2922 } 2923 3291 while (*tmps && len && isSPACE(*tmps)) 2924 327 tmps++, len--; 2925 2964 if (*tmps == '0') 2926 2676 tmps++, len--; 2927 2964 if (*tmps == 'x') 2928 29 result_uv = grok_hex (tmps, &len, &flags, &result_nv); 2929 2935 else if (*tmps == 'b') 2930 1754 result_uv = grok_bin (tmps, &len, &flags, &result_nv); 2931 else 2932 1181 result_uv = grok_oct (tmps, &len, &flags, &result_nv); 2933 2934 2964 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) { 2935 23 XPUSHn(result_nv); 2936 } 2937 else { 2938 2941 XPUSHu(result_uv); 2939 } 2940 2964 RETURN; 2941 } 2942 2943 /* String stuff. */ 2944 2945 PP(pp_length) 2946 4759384 { 2947 4759384 dSP; dTARGET; 2948 4759384 SV *sv = TOPs; 2949 2950 4759384 if (DO_UTF8(sv)) 2951 45456 SETi(sv_len_utf8(sv)); 2952 else 2953 4713928 SETi(sv_len(sv)); 2954 4759384 RETURN; 2955 } 2956 2957 PP(pp_substr) 2958 4326917 { 2959 4326917 dSP; dTARGET; 2960 4326917 SV *sv; 2961 4326917 I32 len = 0; 2962 4326917 STRLEN curlen; 2963 4326917 STRLEN utf8_curlen; 2964 4326917 I32 pos; 2965 4326917 I32 rem; 2966 4326917 I32 fail; 2967 4326917 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET; 2968 4326917 const char *tmps; 2969 4326917 const I32 arybase = PL_curcop->cop_arybase; 2970 4326917 SV *repl_sv = NULL; 2971 4326917 const char *repl = 0; 2972 4326917 STRLEN repl_len; 2973 4326917 const int num_args = PL_op->op_private & 7; 2974 4326917 bool repl_need_utf8_upgrade = FALSE; 2975 4326917 bool repl_is_utf8 = FALSE; 2976 2977 4326917 SvTAINTED_off(TARG); /* decontaminate */ 2978 4326917 SvUTF8_off(TARG); /* decontaminate */ 2979 4326917 if (num_args > 2) { 2980 2736248 if (num_args > 3) { 2981 7971 repl_sv = POPs; 2982 7971 repl = SvPV_const(repl_sv, repl_len); 2983 7971 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv); 2984 } 2985 2736248 len = POPi; 2986 } 2987 4326917 pos = POPi; 2988 4326917 sv = POPs; 2989 4326917 PUTBACK; 2990 4326917 if (repl_sv) { 2991 7971 if (repl_is_utf8) { 2992 13 if (!DO_UTF8(sv)) 2993 6 sv_utf8_upgrade(sv); 2994 } 2995 7958 else if (DO_UTF8(sv)) 2996 145 repl_need_utf8_upgrade = TRUE; 2997 } 2998 4326917 tmps = SvPV_const(sv, curlen); 2999 4326917 if (DO_UTF8(sv)) { 3000 4605 utf8_curlen = sv_len_utf8(sv); 3001 4605 if (utf8_curlen == curlen) 3002 36 utf8_curlen = 0; 3003 else 3004 4569 curlen = utf8_curlen; 3005 } 3006 else 3007 4322312 utf8_curlen = 0; 3008 3009 4326917 if (pos >= arybase) { 3010 2772769 pos -= arybase; 3011 2772769 rem = curlen-pos; 3012 2772769 fail = rem; 3013 2772769 if (num_args > 2) { 3014 1319007 if (len < 0) { 3015 2388 rem += len; 3016 2388 if (rem < 0) 3017 15 rem = 0; 3018 } 3019 1316619 else if (rem > len) 3020 1309786 rem = len; 3021 } 3022 } 3023 else { 3024 1554148 pos += curlen; 3025 1554148 if (num_args < 3) 3026 136907 rem = curlen; 3027 1417241 else if (len >= 0) { 3028 1417223 rem = pos+len; 3029 1417223 if (rem > (I32)curlen) 3030 4 rem = curlen; 3031 } 3032 else { 3033 18 rem = curlen+len; 3034 18 if (rem < pos) 3035 4 rem = pos; 3036 } 3037 1554148 if (pos < 0) 3038 2190 pos = 0; 3039 1554148 fail = rem; 3040 1554148 rem -= pos; 3041 } 3042 4326917 if (fail < 0) { 3043 41 if (lvalue || repl) 3044 19 Perl_croak(aTHX_ "substr outside of string"); 3045 22 if (ckWARN(WARN_SUBSTR)) 3046 18 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string"); 3047 22 RETPUSHUNDEF; 3048 } 3049 else { 3050 4326876 const I32 upos = pos; 3051 4326876 const I32 urem = rem; 3052 4326876 if (utf8_curlen) 3053 4569 sv_pos_u2b(sv, &pos, &rem); 3054 4326876 tmps += pos; 3055 /* we either return a PV or an LV. If the TARG hasn't been used 3056 * before, or is of that type, reuse it; otherwise use a mortal 3057 * instead. Note that LVs can have an extended lifetime, so also 3058 * dont reuse if refcount > 1 (bug #20933) */ 3059 4326876 if (SvTYPE(TARG) > SVt_NULL) { 3060 4323324 if ( (SvTYPE(TARG) == SVt_PVLV) 3061 ? (!lvalue || SvREFCNT(TARG) > 1) 3062 : lvalue) 3063 { 3064 1 TARG = sv_newmortal(); 3065 } 3066 } 3067 3068 4326876 sv_setpvn(TARG, tmps, rem); 3069 #ifdef USE_LOCALE_COLLATE 3070 4326876 sv_unmagic(TARG, PERL_MAGIC_collxfrm); 3071 #endif 3072 4326876 if (utf8_curlen) 3073 4569 SvUTF8_on(TARG); 3074 4326876 if (repl) { 3075 7969 SV* repl_sv_copy = NULL; 3076 3077 7969 if (repl_need_utf8_upgrade) { 3078 145 repl_sv_copy = newSVsv(repl_sv); 3079 145 sv_utf8_upgrade(repl_sv_copy); 3080 145 repl = SvPV_const(repl_sv_copy, repl_len); 3081 145 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv); 3082 } 3083 7969 sv_insert(sv, pos, rem, repl, repl_len); 3084 7969 if (repl_is_utf8) 3085 149 SvUTF8_on(sv); 3086 7969 if (repl_sv_copy) 3087 145 SvREFCNT_dec(repl_sv_copy); 3088 } 3089 4318907 else if (lvalue) { /* it's an lvalue! */ 3090 22839 if (!SvGMAGICAL(sv)) { 3091 22819 if (SvROK(sv)) { 3092 2 SvPV_force_nolen(sv); 3093 2 if (ckWARN(WARN_SUBSTR)) 3094 2 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), 3095 "Attempt to use reference as lvalue in substr"); 3096 } 3097 22819 if (SvOK(sv)) /* is it defined ? */ 3098 22815 (void)SvPOK_only_UTF8(sv); 3099 else 3100 4 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */ 3101 } 3102 3103 22839 if (SvTYPE(TARG) < SVt_PVLV) { 3104 502 sv_upgrade(TARG, SVt_PVLV); 3105 502 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0); 3106 } 3107 else 3108 22337 SvOK_off(TARG); 3109 3110 22839 LvTYPE(TARG) = 'x'; 3111 22839 if (LvTARG(TARG) != sv) { 3112 19583 if (LvTARG(TARG)) 3113 19081 SvREFCNT_dec(LvTARG(TARG)); 3114 19583 LvTARG(TARG) = SvREFCNT_inc(sv); 3115 } 3116 22839 LvTARGOFF(TARG) = upos; 3117 22839 LvTARGLEN(TARG) = urem; 3118 } 3119 } 3120 4326876 SPAGAIN; 3121 4326876 PUSHs(TARG); /* avoid SvSETMAGIC here */ 3122 4326876 RETURN; 3123 } 3124 3125 PP(pp_vec) 3126 2308098 { 3127 2308098 dSP; dTARGET; 3128 2308098 register const IV size = POPi; 3129 2308098 register const IV offset = POPi; 3130 2308098 register SV * const src = POPs; 3131 2308098 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET; 3132 3133 2308098 SvTAINTED_off(TARG); /* decontaminate */ 3134 2308098 if (lvalue) { /* it's an lvalue! */ 3135 1937940 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */ 3136 1 TARG = sv_newmortal(); 3137 1937940 if (SvTYPE(TARG) < SVt_PVLV) { 3138 9073 sv_upgrade(TARG, SVt_PVLV); 3139 9073 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0); 3140 } 3141 1937940 LvTYPE(TARG) = 'v'; 3142 1937940 if (LvTARG(TARG) != src) { 3143 224597 if (LvTARG(TARG)) 3144 215524 SvREFCNT_dec(LvTARG(TARG)); 3145 224597 LvTARG(TARG) = SvREFCNT_inc(src); 3146 } 3147 1937940 LvTARGOFF(TARG) = offset; 3148 1937940 LvTARGLEN(TARG) = size; 3149 } 3150 3151 2308098 sv_setuv(TARG, do_vecget(src, offset, size)); 3152 2308093 PUSHs(TARG); 3153 2308093 RETURN; 3154 } 3155 3156 PP(pp_index) 3157 636005 { 3158 636005 dSP; dTARGET; 3159 636005 SV *big; 3160 636005 SV *little; 3161 636005 SV *temp = Nullsv; 3162 636005 I32 offset; 3163 636005 I32 retval; 3164 636005 const char *tmps; 3165 636005 const char *tmps2; 3166 636005 STRLEN biglen; 3167 636005 const I32 arybase = PL_curcop->cop_arybase; 3168 636005 int big_utf8; 3169 636005 int little_utf8; 3170 3171 636005 if (MAXARG < 3) 3172 322045 offset = 0; 3173 else 3174 313960 offset = POPi - arybase; 3175 636005 little = POPs; 3176 636005 big = POPs; 3177 636005 big_utf8 = DO_UTF8(big); 3178 636005 little_utf8 = DO_UTF8(little); 3179 636005 if (big_utf8 ^ little_utf8) { 3180 /* One needs to be upgraded. */ 3181 19 SV * const bytes = little_utf8 ? big : little; 3182 19 STRLEN len; 3183 19 const char * const p = SvPV_const(bytes, len); 3184 3185 19 temp = newSVpvn(p, len); 3186 3187 19 if (PL_encoding) { 3188 ###### sv_recode_to_utf8(temp, PL_encoding); 3189 } else { 3190 19 sv_utf8_upgrade(temp); 3191 } 3192 19 if (little_utf8) { 3193 2 big = temp; 3194 2 big_utf8 = TRUE; 3195 } else { 3196 17 little = temp; 3197 } 3198 } 3199 636005 if (big_utf8 && offset > 0) 3200 8 sv_pos_u2b(big, &offset, 0); 3201 636005 tmps = SvPV_const(big, biglen); 3202 636005 if (offset < 0) 3203 1 offset = 0; 3204 636004 else if (offset > (I32)biglen) 3205 2 offset = biglen; 3206 636005 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset, 3207 (unsigned char*)tmps + biglen, little, 0))) 3208 173427 retval = -1; 3209 else 3210 462578 retval = tmps2 - tmps; 3211 636005 if (retval > 0 && big_utf8) 3212 26 sv_pos_b2u(big, &retval); 3213 636005 if (temp) 3214 19 SvREFCNT_dec(temp); 3215 636005 PUSHi(retval + arybase); 3216 636005 RETURN; 3217 } 3218 3219 PP(pp_rindex) 3220 286 { 3221 286 dSP; dTARGET; 3222 286 SV *big; 3223 286 SV *little; 3224 286 SV *temp = Nullsv; 3225 286 STRLEN blen; 3226 286 STRLEN llen; 3227 286 I32 offset; 3228 286 I32 retval; 3229 286 const char *tmps; 3230 286 const char *tmps2; 3231 286 const I32 arybase = PL_curcop->cop_arybase; 3232 286 int big_utf8; 3233 286 int little_utf8; 3234 3235 286 if (MAXARG >= 3) 3236 154 offset = POPi; 3237 286 little = POPs; 3238 286 big = POPs; 3239 286 big_utf8 = DO_UTF8(big); 3240 286 little_utf8 = DO_UTF8(little); 3241 286 if (big_utf8 ^ little_utf8) { 3242 /* One needs to be upgraded. */ 3243 17 SV * const bytes = little_utf8 ? big : little; 3244 17 STRLEN len; 3245 17 const char *p = SvPV_const(bytes, len); 3246 3247 17 temp = newSVpvn(p, len); 3248 3249 17 if (PL_encoding) { 3250 ###### sv_recode_to_utf8(temp, PL_encoding); 3251 } else { 3252 17 sv_utf8_upgrade(temp); 3253 } 3254 17 if (little_utf8) { 3255 2 big = temp; 3256 2 big_utf8 = TRUE; 3257 } else { 3258 15 little = temp; 3259 } 3260 } 3261 286 tmps2 = SvPV_const(little, llen); 3262 286 tmps = SvPV_const(big, blen); 3263 3264 286 if (MAXARG < 3) 3265 132 offset = blen; 3266 else { 3267 154 if (offset > 0 && big_utf8) 3268 7 sv_pos_u2b(big, &offset, 0); 3269 154 offset = offset - arybase + llen; 3270 } 3271 286 if (offset < 0) 3272 ###### offset = 0; 3273 286 else if (offset > (I32)blen) 3274 3 offset = blen; 3275 286 if (!(tmps2 = rninstr(tmps, tmps + offset, 3276 tmps2, tmps2 + llen))) 3277 30 retval = -1; 3278 else 3279 256 retval = tmps2 - tmps; 3280 286 if (retval > 0 && big_utf8) 3281 16 sv_pos_b2u(big, &retval); 3282 286 if (temp) 3283 17 SvREFCNT_dec(temp); 3284 286 PUSHi(retval + arybase); 3285 286 RETURN; 3286 } 3287 3288 PP(pp_sprintf) 3289 357264 { 3290 357264 dSP; dMARK; dORIGMARK; dTARGET; 3291 357264 do_sprintf(TARG, SP-MARK, MARK+1); 3292 357264 TAINT_IF(SvTAINTED(TARG)); 3293 357264 if (DO_UTF8(*(MARK+1))) 3294 12 SvUTF8_on(TARG); 3295 357264 SP = ORIGMARK; 3296 357264 PUSHTARG; 3297 357264 RETURN; 3298 } 3299 3300 PP(pp_ord) 3301 702891 { 3302 702891 dSP; dTARGET; 3303 702891 SV *argsv = POPs; 3304 702891 STRLEN len; 3305 702891 const U8 *s = (U8*)SvPV_const(argsv, len); 3306 702891 SV *tmpsv; 3307 3308 702891 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) { 3309 1 tmpsv = sv_2mortal(newSVsv(argsv)); 3310 1 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding); 3311 1 argsv = tmpsv; 3312 } 3313 3314 XPUSHu(DO_UTF8(argsv) ? 3315 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) : 3316 702891 (*s & 0xff)); 3317 3318 702891 RETURN; 3319 } 3320 3321 PP(pp_chr) 3322 1563274 { 3323 1563274 dSP; dTARGET; 3324 1563274 char *tmps; 3325 1563274 UV value; 3326 3327 1563274 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0) 3328 || 3329 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) { 3330 8 if (IN_BYTES) { 3331 4 value = POPu; /* chr(-1) eq chr(0xff), etc. */ 3332 } else { 3333 4 (void) POPs; /* Ignore the argument value. */ 3334 4 value = UNICODE_REPLACEMENT; 3335 } 3336 } else { 3337 1563266 value = POPu; 3338 } 3339 3340 1563274 SvUPGRADE(TARG,SVt_PV); 3341 3342 1563274 if (value > 255 && !IN_BYTES) { 3343 818082 SvGROW(TARG, (STRLEN)UNISKIP(value)+1); 3344 818082 tmps = (char*)uvchr_to_utf8_flags