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((U8*)SvPVX(TARG), value, 0); 3345 818082 SvCUR_set(TARG, tmps - SvPVX_const(TARG)); 3346 818082 *tmps = '\0'; 3347 818082 (void)SvPOK_only(TARG); 3348 818082 SvUTF8_on(TARG); 3349 818082 XPUSHs(TARG); 3350 818082 RETURN; 3351 } 3352 3353 745192 SvGROW(TARG,2); 3354 745192 SvCUR_set(TARG, 1); 3355 745192 tmps = SvPVX(TARG); 3356 745192 *tmps++ = (char)value; 3357 745192 *tmps = '\0'; 3358 745192 (void)SvPOK_only(TARG); 3359 745192 if (PL_encoding && !IN_BYTES) { 3360 13 sv_recode_to_utf8(TARG, PL_encoding); 3361 13 tmps = SvPVX(TARG); 3362 13 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) || 3363 memEQ(tmps, "\xef\xbf\xbd\0", 4)) { 3364 6 SvGROW(TARG, 3); 3365 6 tmps = SvPVX(TARG); 3366 6 SvCUR_set(TARG, 2); 3367 6 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value); 3368 6 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value); 3369 6 *tmps = '\0'; 3370 6 SvUTF8_on(TARG); 3371 } 3372 } 3373 745192 XPUSHs(TARG); 3374 745192 RETURN; 3375 } 3376 3377 PP(pp_crypt) 3378 8 { 3379 #ifdef HAS_CRYPT 3380 8 dSP; dTARGET; 3381 8 dPOPTOPssrl; 3382 8 STRLEN len; 3383 8 const char *tmps = SvPV_const(left, len); 3384 3385 8 if (DO_UTF8(left)) { 3386 /* If Unicode, try to downgrade. 3387 * If not possible, croak. 3388 * Yes, we made this up. */ 3389 2 SV* const tsv = sv_2mortal(newSVsv(left)); 3390 3391 2 SvUTF8_on(tsv); 3392 2 sv_utf8_downgrade(tsv, FALSE); 3393 1 tmps = SvPV_const(tsv, len); 3394 } 3395 # ifdef USE_ITHREADS 3396 # ifdef HAS_CRYPT_R 3397 if (!PL_reentrant_buffer->_crypt_struct_buffer) { 3398 /* This should be threadsafe because in ithreads there is only 3399 * one thread per interpreter. If this would not be true, 3400 * we would need a mutex to protect this malloc. */ 3401 PL_reentrant_buffer->_crypt_struct_buffer = 3402 (struct crypt_data *)safemalloc(sizeof(struct crypt_data)); 3403 #if defined(__GLIBC__) || defined(__EMX__) 3404 if (PL_reentrant_buffer->_crypt_struct_buffer) { 3405 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0; 3406 /* work around glibc-2.2.5 bug */ 3407 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0; 3408 } 3409 #endif 3410 } 3411 # endif /* HAS_CRYPT_R */ 3412 # endif /* USE_ITHREADS */ 3413 # ifdef FCRYPT 3414 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right))); 3415 # else 3416 7 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right))); 3417 # endif 3418 7 SETs(TARG); 3419 7 RETURN; 3420 #else 3421 DIE(aTHX_ 3422 "The crypt() function is unimplemented due to excessive paranoia."); 3423 #endif 3424 } 3425 3426 PP(pp_ucfirst) 3427 5720 { 3428 5720 dSP; 3429 5720 SV *sv = TOPs; 3430 5720 const U8 *s; 3431 5720 STRLEN slen; 3432 3433 5720 SvGETMAGIC(sv); 3434 5720 if (DO_UTF8(sv) && 3435 (s = (const U8*)SvPV_nomg_const(sv, slen)) && slen && 3436 UTF8_IS_START(*s)) { 3437 936 U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; 3438 936 STRLEN ulen; 3439 936 STRLEN tculen; 3440 3441 936 utf8_to_uvchr(s, &ulen); 3442 936 toTITLE_utf8(s, tmpbuf, &tculen); 3443 936 utf8_to_uvchr(tmpbuf, 0); 3444 3445 936 if (!SvPADTMP(sv) || SvREADONLY(sv)) { 3446 936 dTARGET; 3447 /* slen is the byte length of the whole SV. 3448 * ulen is the byte length of the original Unicode character 3449 * stored as UTF-8 at s. 3450 * tculen is the byte length of the freshly titlecased 3451 * Unicode character stored as UTF-8 at tmpbuf. 3452 * We first set the result to be the titlecased character, 3453 * and then append the rest of the SV data. */ 3454 936 sv_setpvn(TARG, (char*)tmpbuf, tculen); 3455 936 if (slen > ulen) 3456 5 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen); 3457 936 SvUTF8_on(TARG); 3458 936 SETs(TARG); 3459 } 3460 else { 3461 ###### s = (U8*)SvPV_force_nomg(sv, slen); 3462 ###### Copy(tmpbuf, s, tculen, U8); 3463 } 3464 } 3465 else { 3466 4784 U8 *s1; 3467 4784 if (!SvPADTMP(sv) || SvREADONLY(sv)) { 3468 1417 dTARGET; 3469 1417 SvUTF8_off(TARG); /* decontaminate */ 3470 1417 sv_setsv_nomg(TARG, sv); 3471 1417 sv = TARG; 3472 1417 SETs(sv); 3473 } 3474 4784 s1 = (U8*)SvPV_force_nomg(sv, slen); 3475 4784 if (*s1) { 3476 4780 if (IN_LOCALE_RUNTIME) { 3477 3 TAINT; 3478 3 SvTAINTED_on(sv); 3479 3 *s1 = toUPPER_LC(*s1); 3480 } 3481 else 3482 4777 *s1 = toUPPER(*s1); 3483 } 3484 } 3485 5720 SvSETMAGIC(sv); 3486 5720 RETURN; 3487 } 3488 3489 PP(pp_lcfirst) 3490 242 { 3491 242 dSP; 3492 242 SV *sv = TOPs; 3493 242 const U8 *s; 3494 242 STRLEN slen; 3495 3496 242 SvGETMAGIC(sv); 3497 242 if (DO_UTF8(sv) && 3498 (s = (const U8*)SvPV_nomg_const(sv, slen)) && slen && 3499 UTF8_IS_START(*s)) { 3500 5 STRLEN ulen; 3501 5 U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; 3502 5 U8 *tend; 3503 5 UV uv; 3504 3505 5 toLOWER_utf8(s, tmpbuf, &ulen); 3506 5 uv = utf8_to_uvchr(tmpbuf, 0); 3507 5 tend = uvchr_to_utf8(tmpbuf, uv); 3508 3509 5 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) { 3510 5 dTARGET; 3511 5 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf); 3512 5 if (slen > ulen) 3513 5 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen); 3514 5 SvUTF8_on(TARG); 3515 5 SETs(TARG); 3516 } 3517 else { 3518 ###### s = (U8*)SvPV_force_nomg(sv, slen); 3519 ###### Copy(tmpbuf, s, ulen, U8); 3520 } 3521 } 3522 else { 3523 237 U8 *s1; 3524 237 if (!SvPADTMP(sv) || SvREADONLY(sv)) { 3525 237 dTARGET; 3526 237 SvUTF8_off(TARG); /* decontaminate */ 3527 237 sv_setsv_nomg(TARG, sv); 3528 237 sv = TARG; 3529 237 SETs(sv); 3530 } 3531 237 s1 = (U8*)SvPV_force_nomg(sv, slen); 3532 237 if (*s1) { 3533 235 if (IN_LOCALE_RUNTIME) { 3534 3 TAINT; 3535 3 SvTAINTED_on(sv); 3536 3 *s1 = toLOWER_LC(*s1); 3537 } 3538 else 3539 232 *s1 = toLOWER(*s1); 3540 } 3541 } 3542 242 SvSETMAGIC(sv); 3543 242 RETURN; 3544 } 3545 3546 PP(pp_uc) 3547 950581 { 3548 950581 dSP; 3549 950581 SV *sv = TOPs; 3550 950581 STRLEN len; 3551 3552 950581 SvGETMAGIC(sv); 3553 950581 if (DO_UTF8(sv)) { 3554 1059 dTARGET; 3555 1059 STRLEN ulen; 3556 1059 register U8 *d; 3557 1059 const U8 *s; 3558 1059 const U8 *send; 3559 1059 U8 tmpbuf[UTF8_MAXBYTES+1]; 3560 3561 1059 s = (const U8*)SvPV_nomg_const(sv,len); 3562 1059 if (!len) { 3563 ###### SvUTF8_off(TARG); /* decontaminate */ 3564 ###### sv_setpvn(TARG, "", 0); 3565 ###### SETs(TARG); 3566 } 3567 else { 3568 1059 STRLEN min = len + 1; 3569 3570 1059 SvUPGRADE(TARG, SVt_PV); 3571 1059 SvGROW(TARG, min); 3572 1059 (void)SvPOK_only(TARG); 3573 1059 d = (U8*)SvPVX(TARG); 3574 1059 send = s + len; 3575 2165 while (s < send) { 3576 1106 STRLEN u = UTF8SKIP(s); 3577 3578 1106 toUPPER_utf8(s, tmpbuf, &ulen); 3579 1106 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) { 3580 /* If the eventually required minimum size outgrows 3581 * the available space, we need to grow. */ 3582 1 UV o = d - (U8*)SvPVX_const(TARG); 3583 3584 /* If someone uppercases one million U+03B0s we 3585 * SvGROW() one million times. Or we could try 3586 * guessing how much to allocate without allocating 3587 * too much. Such is life. */ 3588 1 SvGROW(TARG, min); 3589 1 d = (U8*)SvPVX(TARG) + o; 3590 } 3591 1106 Copy(tmpbuf, d, ulen, U8); 3592 1106 d += ulen; 3593 1106 s += u; 3594 } 3595 1059 *d = '\0'; 3596 1059 SvUTF8_on(TARG); 3597 1059 SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG)); 3598 1059 SETs(TARG); 3599 } 3600 } 3601 else { 3602 949522 U8 *s; 3603 949522 if (!SvPADTMP(sv) || SvREADONLY(sv)) { 3604 948085 dTARGET; 3605 948085 SvUTF8_off(TARG); /* decontaminate */ 3606 948085 sv_setsv_nomg(TARG, sv); 3607 948085 sv = TARG; 3608 948085 SETs(sv); 3609 } 3610 949522 s = (U8*)SvPV_force_nomg(sv, len); 3611 949522 if (len) { 3612 949451 const register U8 *send = s + len; 3613 3614 949451 if (IN_LOCALE_RUNTIME) { 3615 896071 TAINT; 3616 896071 SvTAINTED_on(sv); 3617 2688245 for (; s < send; s++) 3618 896087 *s = toUPPER_LC(*s); 3619 } 3620 else { 3621 829882 for (; s < send; s++) 3622 388251 *s = toUPPER(*s); 3623 } 3624 } 3625 } 3626 950581 SvSETMAGIC(sv); 3627 950581 RETURN; 3628 } 3629 3630 PP(pp_lc) 3631 1097176 { 3632 1097176 dSP; 3633 1097176 SV *sv = TOPs; 3634 1097176 STRLEN len; 3635 3636 1097176 SvGETMAGIC(sv); 3637 1097176 if (DO_UTF8(sv)) { 3638 1011 dTARGET; 3639 1011 const U8 *s; 3640 1011 STRLEN ulen; 3641 1011 register U8 *d; 3642 1011 const U8 *send; 3643 1011 U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; 3644 3645 1011 s = (const U8*)SvPV_nomg_const(sv,len); 3646 1011 if (!len) { 3647 ###### SvUTF8_off(TARG); /* decontaminate */ 3648 ###### sv_setpvn(TARG, "", 0); 3649 ###### SETs(TARG); 3650 } 3651 else { 3652 1011 STRLEN min = len + 1; 3653 3654 1011 SvUPGRADE(TARG, SVt_PV); 3655 1011 SvGROW(TARG, min); 3656 1011 (void)SvPOK_only(TARG); 3657 1011 d = (U8*)SvPVX(TARG); 3658 1011 send = s + len; 3659 2357 while (s < send) { 3660 1346 const STRLEN u = UTF8SKIP(s); 3661 1346 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen); 3662 3663 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */ 3664 1346 if (uv == GREEK_CAPITAL_LETTER_SIGMA) { 3665 /* 3666 * Now if the sigma is NOT followed by 3667 * /$ignorable_sequence$cased_letter/; 3668 * and it IS preceded by 3669 * /$cased_letter$ignorable_sequence/; 3670 * where $ignorable_sequence is 3671 * [\x{2010}\x{AD}\p{Mn}]* 3672 * and $cased_letter is 3673 * [\p{Ll}\p{Lo}\p{Lt}] 3674 * then it should be mapped to 0x03C2, 3675 * (GREEK SMALL LETTER FINAL SIGMA), 3676 * instead of staying 0x03A3. 3677 * "should be": in other words, 3678 * this is not implemented yet. 3679 * See lib/unicore/SpecialCasing.txt. 3680 */ 3681 } 3682 1346 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) { 3683 /* If the eventually required minimum size outgrows 3684 * the available space, we need to grow. */ 3685 ###### UV o = d - (U8*)SvPVX_const(TARG); 3686 3687 /* If someone lowercases one million U+0130s we 3688 * SvGROW() one million times. Or we could try 3689 * guessing how much to allocate without allocating. 3690 * too much. Such is life. */ 3691 ###### SvGROW(TARG, min); 3692 ###### d = (U8*)SvPVX(TARG) + o; 3693 } 3694 1346 Copy(tmpbuf, d, ulen, U8); 3695 1346 d += ulen; 3696 1346 s += u; 3697 } 3698 1011 *d = '\0'; 3699 1011 SvUTF8_on(TARG); 3700 1011 SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG)); 3701 1011 SETs(TARG); 3702 } 3703 } 3704 else { 3705 1096165 U8 *s; 3706 1096165 if (!SvPADTMP(sv) || SvREADONLY(sv)) { 3707 1095013 dTARGET; 3708 1095013 SvUTF8_off(TARG); /* decontaminate */ 3709 1095013 sv_setsv_nomg(TARG, sv); 3710 1095013 sv = TARG; 3711 1095013 SETs(sv); 3712 } 3713 3714 1096165 s = (U8*)SvPV_force_nomg(sv, len); 3715 1096165 if (len) { 3716 1095730 register const U8 * const send = s + len; 3717 3718 1095730 if (IN_LOCALE_RUNTIME) { 3719 898170 TAINT; 3720 898170 SvTAINTED_on(sv); 3721 2699428 for (; s < send; s++) 3722 900629 *s = toLOWER_LC(*s); 3723 } 3724 else { 3725 4095216 for (; s < send; s++) 3726 1948828 *s = toLOWER(*s); 3727 } 3728 } 3729 } 3730 1097176 SvSETMAGIC(sv); 3731 1097176 RETURN; 3732 } 3733 3734 PP(pp_quotemeta) 3735 6860 { 3736 6860 dSP; dTARGET; 3737 6860 SV * const sv = TOPs; 3738 6860 STRLEN len; 3739 6860 const register char *s = SvPV_const(sv,len); 3740 3741 6860 SvUTF8_off(TARG); /* decontaminate */ 3742 6860 if (len) { 3743 6746 register char *d; 3744 6746 SvUPGRADE(TARG, SVt_PV); 3745 6746 SvGROW(TARG, (len * 2) + 1); 3746 6746 d = SvPVX(TARG); 3747 6746 if (DO_UTF8(sv)) { 3748 24 while (len) { 3749 18 if (UTF8_IS_CONTINUED(*s)) { 3750 10 STRLEN ulen = UTF8SKIP(s); 3751 10 if (ulen > len) 3752 ###### ulen = len; 3753 10 len -= ulen; 3754 32 while (ulen--) 3755 22 *d++ = *s++; 3756 } 3757 else { 3758 8 if (!isALNUM(*s)) 3759 ###### *d++ = '\\'; 3760 8 *d++ = *s++; 3761 8 len--; 3762 } 3763 } 3764 6 SvUTF8_on(TARG); 3765 } 3766 else { 3767 130596 while (len--) { 3768 123856 if (!isALNUM(*s)) 3769 47602 *d++ = '\\'; 3770 123856 *d++ = *s++; 3771 } 3772 } 3773 6746 *d = '\0'; 3774 6746 SvCUR_set(TARG, d - SvPVX_const(TARG)); 3775 6746 (void)SvPOK_only_UTF8(TARG); 3776 } 3777 else 3778 114 sv_setpvn(TARG, s, len); 3779 6860 SETs(TARG); 3780 6860 if (SvSMAGICAL(TARG)) 3781 ###### mg_set(TARG); 3782 6860 RETURN; 3783 } 3784 3785 /* Arrays. */ 3786 3787 PP(pp_aslice) 3788 45886 { 3789 45886 dSP; dMARK; dORIGMARK; 3790 45886 register AV* const av = (AV*)POPs; 3791 45886 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET); 3792 3793 45886 if (SvTYPE(av) == SVt_PVAV) { 3794 45886 const I32 arybase = PL_curcop->cop_arybase; 3795 45886 if (lval && PL_op->op_private & OPpLVAL_INTRO) { 3796 1 register SV **svp; 3797 1 I32 max = -1; 3798 3 for (svp = MARK + 1; svp <= SP; svp++) { 3799 2 const I32 elem = SvIVx(*svp); 3800 2 if (elem > max) 3801 2 max = elem; 3802 } 3803 1 if (max > AvMAX(av)) 3804 1 av_extend(av, max); 3805 } 3806 230288 while (++MARK <= SP) { 3807 184402 register SV **svp; 3808 184402 I32 elem = SvIVx(*MARK); 3809 3810 184402 if (elem > 0) 3811 85275 elem -= arybase; 3812 184402 svp = av_fetch(av, elem, lval); 3813 184402 if (lval) { 3814 22670 if (!svp || *svp == &PL_sv_undef) 3815 ###### DIE(aTHX_ PL_no_aelem, elem); 3816 22670 if (PL_op->op_private & OPpLVAL_INTRO) 3817 2 save_aelem(av, elem, svp); 3818 } 3819 184402 *MARK = svp ? *svp : &PL_sv_undef; 3820 } 3821 } 3822 45886 if (GIMME != G_ARRAY) { 3823 114 MARK = ORIGMARK; 3824 114 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef; 3825 114 SP = MARK; 3826 } 3827 45886 RETURN; 3828 } 3829 3830 /* Associative arrays. */ 3831 3832 PP(pp_each) 3833 50348 { 3834 50348 dSP; 3835 50348 HV * const hash = (HV*)POPs; 3836 50348 HE *entry; 3837 50348 const I32 gimme = GIMME_V; 3838 3839 50348 PUTBACK; 3840 /* might clobber stack_sp */ 3841 50348 entry = hv_iternext(hash); 3842 50348 SPAGAIN; 3843 3844 50348 EXTEND(SP, 2); 3845 50348 if (entry) { 3846 45206 SV* const sv = hv_iterkeysv(entry); 3847 45206 PUSHs(sv); /* won't clobber stack_sp */ 3848 45206 if (gimme == G_ARRAY) { 3849 44054 SV *val; 3850 44054 PUTBACK; 3851 /* might clobber stack_sp */ 3852 44054 val = hv_iterval(hash, entry); 3853 44054 SPAGAIN; 3854 44054 PUSHs(val); 3855 } 3856 } 3857 5142 else if (gimme == G_SCALAR) 3858 940 RETPUSHUNDEF; 3859 3860 49408 RETURN; 3861 } 3862 3863 PP(pp_values) 3864 19001 { 3865 19001 return do_kv(); 3866 } 3867 3868 PP(pp_keys) 3869 79373 { 3870 79373 return do_kv(); 3871 } 3872 3873 PP(pp_delete) 3874 123569 { 3875 123569 dSP; 3876 123569 const I32 gimme = GIMME_V; 3877 123569 const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0; 3878 3879 123569 if (PL_op->op_private & OPpSLICE) { 3880 1111 dMARK; dORIGMARK; 3881 1111 HV * const hv = (HV*)POPs; 3882 1111 const U32 hvtype = SvTYPE(hv); 3883 1111 if (hvtype == SVt_PVHV) { /* hash element */ 3884 4425 while (++MARK <= SP) { 3885 3316 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0); 3886 3316 *MARK = sv ? sv : &PL_sv_undef; 3887 } 3888 } 3889 2 else if (hvtype == SVt_PVAV) { /* array element */ 3890 2 if (PL_op->op_flags & OPf_SPECIAL) { 3891 6 while (++MARK <= SP) { 3892 4 SV * const sv = av_delete((AV*)hv, SvIV(*MARK), discard); 3893 4 *MARK = sv ? sv : &PL_sv_undef; 3894 } 3895 } 3896 } 3897 else 3898 ###### DIE(aTHX_ "Not a HASH reference"); 3899 1111 if (discard) 3900 1108 SP = ORIGMARK; 3901 3 else if (gimme == G_SCALAR) { 3902 1 MARK = ORIGMARK; 3903 1 if (SP > MARK) 3904 ###### *++MARK = *SP; 3905 else 3906 1 *++MARK = &PL_sv_undef; 3907 1 SP = MARK; 3908 } 3909 } 3910 else { 3911 122458 SV *keysv = POPs; 3912 122458 HV * const hv = (HV*)POPs; 3913 122458 SV *sv; 3914 122458 if (SvTYPE(hv) == SVt_PVHV) 3915 122429 sv = hv_delete_ent(hv, keysv, discard, 0); 3916 29 else if (SvTYPE(hv) == SVt_PVAV) { 3917 29 if (PL_op->op_flags & OPf_SPECIAL) 3918 29 sv = av_delete((AV*)hv, SvIV(keysv), discard); 3919 else 3920 ###### DIE(aTHX_ "panic: avhv_delete no longer supported"); 3921 } 3922 else 3923 ###### DIE(aTHX_ "Not a HASH reference"); 3924 122452 if (!sv) 3925 115783 sv = &PL_sv_undef; 3926 122452 if (!discard) 3927 72992 PUSHs(sv); 3928 } 3929 123563 RETURN; 3930 } 3931 3932 PP(pp_exists) 3933 966270 { 3934 966270 dSP; 3935 966270 SV *tmpsv; 3936 966270 HV *hv; 3937 3938 966270 if (PL_op->op_private & OPpEXISTS_SUB) { 3939 3776 GV *gv; 3940 3776 SV *sv = POPs; 3941 3776 CV * const cv = sv_2cv(sv, &hv, &gv, FALSE); 3942 3776 if (cv) 3943 1599 RETPUSHYES; 3944 2177 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv)) 3945 ###### RETPUSHYES; 3946 2177 RETPUSHNO; 3947 } 3948 962494 tmpsv = POPs; 3949 962494 hv = (HV*)POPs; 3950 962494 if (SvTYPE(hv) == SVt_PVHV) { 3951 962370 if (hv_exists_ent(hv, tmpsv, 0)) 3952 687354 RETPUSHYES; 3953 } 3954 124 else if (SvTYPE(hv) == SVt_PVAV) { 3955 124 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */ 3956 124 if (av_exists((AV*)hv, SvIV(tmpsv))) 3957 101 RETPUSHYES; 3958 } 3959 } 3960 else { 3961 ###### DIE(aTHX_ "Not a HASH reference"); 3962 } 3963 275039 RETPUSHNO; 3964 } 3965 3966 PP(pp_hslice) 3967 52303 { 3968 52303 dSP; dMARK; dORIGMARK; 3969 52303 register HV * const hv = (HV*)POPs; 3970 52303 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET); 3971 52303 const bool localizing = PL_op->op_private & OPpLVAL_INTRO; 3972 52303 bool other_magic = FALSE; 3973 3974 52303 if (localizing) { 3975 757 MAGIC *mg; 3976 757 HV *stash; 3977 3978 757 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) || 3979 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied)) 3980 /* Try to preserve the existenceness of a tied hash 3981 * element by using EXISTS and DELETE if possible. 3982 * Fallback to FETCH and STORE otherwise */ 3983 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg)))) 3984 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE) 3985 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)); 3986 } 3987 3988 223364 while (++MARK <= SP) { 3989 171061 SV * const keysv = *MARK; 3990 171061 SV **svp; 3991 171061 HE *he; 3992 171061 bool preeminent = FALSE; 3993 3994 171061 if (localizing) { 3995 1117 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 : 3996 hv_exists_ent(hv, keysv, 0); 3997 } 3998 3999 171061 he = hv_fetch_ent(hv, keysv, lval, 0); 4000 171061 svp = he ? &HeVAL(he) : 0; 4001 4002 171061 if (lval) { 4003 136197 if (!svp || *svp == &PL_sv_undef) { 4004 ###### DIE(aTHX_ PL_no_helem_sv, keysv); 4005 } 4006 136197 if (localizing) { 4007 1117 if (preeminent) 4008 1107 save_helem(hv, keysv, svp); 4009 else { 4010 10 STRLEN keylen; 4011 10 const char *key = SvPV_const(keysv, keylen); 4012 10 SAVEDELETE(hv, savepvn(key,keylen), keylen); 4013 } 4014 } 4015 } 4016 171061 *MARK = svp ? *svp : &PL_sv_undef; 4017 } 4018 52303 if (GIMME != G_ARRAY) { 4019 588 MARK = ORIGMARK; 4020 588 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef; 4021 588 SP = MARK; 4022 } 4023 52303 RETURN; 4024 } 4025 4026 /* List operators. */ 4027 4028 PP(pp_list) 4029 1165678 { 4030 1165678 dSP; dMARK; 4031 1165678 if (GIMME != G_ARRAY) { 4032 893807 if (++MARK <= SP) 4033 891451 *MARK = *SP; /* unwanted list, return last item */ 4034 else 4035 2356 *MARK = &PL_sv_undef; 4036 893807 SP = MARK; 4037 } 4038 1165678 RETURN; 4039 } 4040 4041 PP(pp_lslice) 4042 84224 { 4043 84224 dSP; 4044 84224 SV ** const lastrelem = PL_stack_sp; 4045 84224 SV ** const lastlelem = PL_stack_base + POPMARK; 4046 84224 SV ** const firstlelem = PL_stack_base + POPMARK + 1; 4047 84224 register SV ** const firstrelem = lastlelem + 1; 4048 84224 const I32 arybase = PL_curcop->cop_arybase; 4049 84224 I32 is_something_there = PL_op->op_flags & OPf_MOD; 4050 4051 84224 register const I32 max = lastrelem - lastlelem; 4052 84224 register SV **lelem; 4053 4054 84224 if (GIMME != G_ARRAY) { 4055 81434 I32 ix = SvIVx(*lastlelem); 4056 81434 if (ix < 0) 4057 5 ix += max; 4058 else 4059 81429 ix -= arybase; 4060 81434 if (ix < 0 || ix >= max) 4061 1127 *firstlelem = &PL_sv_undef; 4062 else 4063 80307 *firstlelem = firstrelem[ix]; 4064 81434 SP = firstlelem; 4065 81434 RETURN; 4066 } 4067 4068 2790 if (max == 0) { 4069 6 SP = firstlelem - 1; 4070 6 RETURN; 4071 } 4072 4073 8134 for (lelem = firstlelem; lelem <= lastlelem; lelem++) { 4074 5350 I32 ix = SvIVx(*lelem); 4075 5350 if (ix < 0) 4076 1 ix += max; 4077 else 4078 5349 ix -= arybase; 4079 5350 if (ix < 0 || ix >= max) 4080 2 *lelem = &PL_sv_undef; 4081 else { 4082 5348 is_something_there = TRUE; 4083 5348 if (!(*lelem = firstrelem[ix])) 4084 ###### *lelem = &PL_sv_undef; 4085 } 4086 } 4087 2784 if (is_something_there) 4088 2782 SP = lastlelem; 4089 else 4090 2 SP = firstlelem - 1; 4091 2784 RETURN; 4092 } 4093 4094 PP(pp_anonlist) 4095 1199280 { 4096 1199280 dSP; dMARK; dORIGMARK; 4097 1199280 const I32 items = SP - MARK; 4098 1199280 SV * const av = sv_2mortal((SV*)av_make(items, MARK+1)); 4099 1199280 SP = ORIGMARK; /* av_make() might realloc stack_sp */ 4100 1199280 XPUSHs(av); 4101 1199280 RETURN; 4102 } 4103 4104 PP(pp_anonhash) 4105 965882 { 4106 965882 dSP; dMARK; dORIGMARK; 4107 965882 HV* const hv = (HV*)sv_2mortal((SV*)newHV()); 4108 4109 1883688 while (MARK < SP) { 4110 917830 SV * const key = *++MARK; 4111 917830 SV * const val = NEWSV(46, 0); 4112 917830 if (MARK < SP) 4113 917802 sv_setsv(val, *++MARK); 4114 28 else if (ckWARN(WARN_MISC)) 4115 26 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash"); 4116 917806 (void)hv_store_ent(hv,key,val,0); 4117 } 4118 965858 SP = ORIGMARK; 4119 965858 XPUSHs((SV*)hv); 4120 965858 RETURN; 4121 } 4122 4123 PP(pp_splice) 4124 36817 { 4125 36817 dVAR; dSP; dMARK; dORIGMARK; 4126 36817 register AV *ary = (AV*)*++MARK; 4127 36817 register SV **src; 4128 36817 register SV **dst; 4129 36817 register I32 i; 4130 36817 register I32 offset; 4131 36817 register I32 length; 4132 36817 I32 newlen; 4133 36817 I32 after; 4134 36817 I32 diff; 4135 36817 SV **tmparyval = 0; 4136 36817 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied); 4137 4138 36817 if (mg) { 4139 417 *MARK-- = SvTIED_obj((SV*)ary, mg); 4140 417 PUSHMARK(MARK); 4141 417 PUTBACK; 4142 417 ENTER; 4143 417 call_method("SPLICE",GIMME_V); 4144 414 LEAVE; 4145 414 SPAGAIN; 4146 414 RETURN; 4147 } 4148 4149 36400 SP++; 4150 4151 36400 if (++MARK < SP) { 4152 36393 offset = i = SvIVx(*MARK); 4153 36393 if (offset < 0) 4154 7894 offset += AvFILLp(ary) + 1; 4155 else 4156 28499 offset -= PL_curcop->cop_arybase; 4157 36393 if (offset < 0) 4158 ###### DIE(aTHX_ PL_no_aelem, i); 4159 36393 if (++MARK < SP) { 4160 17552 length = SvIVx(*MARK++); 4161 17552 if (length < 0) { 4162 2 length += AvFILLp(ary) - offset + 1; 4163 2 if (length < 0) 4164 ###### length = 0; 4165 } 4166 } 4167 else 4168 18841 length = AvMAX(ary) + 1; /* close enough to infinity */ 4169 } 4170 else { 4171 7 offset = 0; 4172 7 length = AvMAX(ary) + 1; 4173 } 4174 36400 if (offset > AvFILLp(ary) + 1) { 4175 ###### if (ckWARN(WARN_MISC)) 4176 ###### Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" ); 4177 ###### offset = AvFILLp(ary) + 1; 4178 } 4179 36400 after = AvFILLp(ary) + 1 - (offset + length); 4180 36400 if (after < 0) { /* not that much array */ 4181 19918 length += after; /* offset+length now in array */ 4182 19918 after = 0; 4183 19918 if (!AvALLOC(ary)) 4184 ###### av_extend(ary, 0); 4185 } 4186 4187 /* At this point, MARK .. SP-1 is our new LIST */ 4188 4189 36400 newlen = SP - MARK; 4190 36400 diff = newlen - length; 4191 36400 if (newlen && !AvREAL(ary) && AvREIFY(ary)) 4192 13 av_reify(ary); 4193 4194 /* make new elements SVs now: avoid problems if they're from the array */ 4195 41246 for (dst = MARK, i = newlen; i; i--) { 4196 4846 SV * const h = *dst; 4197 4846 *dst++ = newSVsv(h); 4198 } 4199 4200 36400 if (diff < 0) { /* shrinking the area */ 4201 31289 if (newlen) { 4202 153 New(451, tmparyval, newlen, SV*); /* so remember insertion */ 4203 153 Copy(MARK, tmparyval, newlen, SV*); 4204 } 4205 4206 31289 MARK = ORIGMARK + 1; 4207 31289 if (GIMME == G_ARRAY) { /* copy return vals to stack */ 4208 16546 MEXTEND(MARK, length); 4209 16546 Copy(AvARRAY(ary)+offset, MARK, length, SV*); 4210 16546 if (AvREAL(ary)) { 4211 7170 EXTEND_MORTAL(length); 4212 25710 for (i = length, dst = MARK; i; i--) { 4213 18540 sv_2mortal(*dst); /* free them eventualy */ 4214 18540 dst++; 4215 } 4216 } 4217 16546 MARK += length - 1; 4218 } 4219 else { 4220 14743 *MARK = AvARRAY(ary)[offset+length-1]; 4221 14743 if (AvREAL(ary)) { 4222 14736 sv_2mortal(*MARK); 4223 41682 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--) 4224 26946 SvREFCNT_dec(*dst++); /* free them now */ 4225 } 4226 } 4227 31289 AvFILLp(ary) += diff; 4228 4229 /* pull up or down? */ 4230 4231 31289 if (offset < after) { /* easier to pull up */ 4232 6998 if (offset) { /* esp. if nothing to pull */ 4233 29 src = &AvARRAY(ary)[offset-1]; 4234 29 dst = src - diff; /* diff is negative */ 4235 70 for (i = offset; i > 0; i--) /* can't trust Copy */ 4236 41 *dst-- = *src--; 4237 } 4238 6998 dst = AvARRAY(ary); 4239 6998 SvPV_set(ary, (char*)(AvARRAY(ary) - diff)); /* diff is negative */ 4240 6998 AvMAX(ary) += diff; 4241 } 4242 else { 4243 24291 if (after) { /* anything to pull down? */ 4244 9 src = AvARRAY(ary) + offset + length; 4245 9 dst = src + diff; /* diff is negative */ 4246 9 Move(src, dst, after, SV*); 4247 } 4248 24291 dst = &AvARRAY(ary)[AvFILLp(ary)+1]; 4249 /* avoid later double free */ 4250 } 4251 31289 i = -diff; 4252 115142 while (i) 4253 83853 dst[--i] = &PL_sv_undef; 4254 4255 31289 if (newlen) { 4256 153 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* ); 4257 153 Safefree(tmparyval); 4258 } 4259 } 4260 else { /* no, expanding (or same) */ 4261 5111 if (length) { 4262 544 New(452, tmparyval, length, SV*); /* so remember deletion */ 4263 544 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*); 4264 } 4265 4266 5111 if (diff > 0) { /* expanding */ 4267 4268 /* push up or down? */ 4269 4270 3450 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) { 4271 35 if (offset) { 4272 27 src = AvARRAY(ary); 4273 27 dst = src - diff; 4274 27 Move(src, dst, offset, SV*); 4275 } 4276 35 SvPV_set(ary, (char*)(AvARRAY(ary) - diff));/* diff is positive */ 4277 35 AvMAX(ary) += diff; 4278 35 AvFILLp(ary) += diff; 4279 } 4280 else { 4281 3415 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */ 4282 148 av_extend(ary, AvFILLp(ary) + diff); 4283 3415 AvFILLp(ary) += diff; 4284 4285 3415 if (after) { 4286 2165 dst = AvARRAY(ary) + AvFILLp(ary); 4287 2165 src = dst - diff; 4288 19143 for (i = after; i; i--) { 4289 16978 *dst-- = *src--; 4290 } 4291 } 4292 } 4293 } 4294 4295 5111 if (newlen) { 4296 3863 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* ); 4297 } 4298 4299 5111 MARK = ORIGMARK + 1; 4300 5111 if (GIMME == G_ARRAY) { /* copy return vals to stack */ 4301 836 if (length) { 4302 6 Copy(tmparyval, MARK, length, SV*); 4303 6 if (AvREAL(ary)) { 4304 6 EXTEND_MORTAL(length); 4305 12 for (i = length, dst = MARK; i; i--) { 4306 6 sv_2mortal(*dst); /* free them eventualy */ 4307 6 dst++; 4308 } 4309 } 4310 6 Safefree(tmparyval); 4311 } 4312 836 MARK += length - 1; 4313 } 4314 4275 else if (length--) { 4315 538 *MARK = tmparyval[length]; 4316 538 if (AvREAL(ary)) { 4317 538 sv_2mortal(*MARK); 4318 984 while (length-- > 0) 4319 446 SvREFCNT_dec(tmparyval[length]); 4320 } 4321 538 Safefree(tmparyval); 4322 } 4323 else 4324 3737 *MARK = &PL_sv_undef; 4325 } 4326 36400 SP = MARK; 4327 36400 RETURN; 4328 } 4329 4330 PP(pp_push) 4331 1438019 { 4332 1438019 dVAR; dSP; dMARK; dORIGMARK; dTARGET; 4333 1438019 register AV *ary = (AV*)*++MARK; 4334 1438019 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied); 4335 4336 1438019 if (mg) { 4337 17 *MARK-- = SvTIED_obj((SV*)ary, mg); 4338 17 PUSHMARK(MARK); 4339 17 PUTBACK; 4340 17 ENTER; 4341 17 call_method("PUSH",G_SCALAR|G_DISCARD); 4342 17 LEAVE; 4343 17 SPAGAIN; 4344 } 4345 else { 4346 /* Why no pre-extend of ary here ? */ 4347 2957121 for (++MARK; MARK <= SP; MARK++) { 4348 1519119 SV * const sv = NEWSV(51, 0); 4349 1519119 if (*MARK) 4350 1519119 sv_setsv(sv, *MARK); 4351 1519119 av_push(ary, sv); 4352 } 4353 } 4354 1438019 SP = ORIGMARK; 4355 1438019 PUSHi( AvFILL(ary) + 1 ); 4356 1438019 RETURN; 4357 } 4358 4359 PP(pp_pop) 4360 66590 { 4361 66590 dSP; 4362 66590 AV * const av = (AV*)POPs; 4363 66590 SV * const sv = av_pop(av); 4364 66590 if (AvREAL(av)) 4365 58086 (void)sv_2mortal(sv); 4366 66590 PUSHs(sv); 4367 66590 RETURN; 4368 } 4369 4370 PP(pp_shift) 4371 16002986 { 4372 16002986 dSP; 4373 16002986 AV * const av = (AV*)POPs; 4374 16002986 SV * const sv = av_shift(av); 4375 16002986 EXTEND(SP, 1); 4376 16002986 if (!sv) 4377 ###### RETPUSHUNDEF; 4378 16002986 if (AvREAL(av)) 4379 67774 (void)sv_2mortal(sv); 4380 16002986 PUSHs(sv); 4381 16002986 RETURN; 4382 } 4383 4384 PP(pp_unshift) 4385 49699 { 4386 49699 dVAR; dSP; dMARK; dORIGMARK; dTARGET; 4387 49699 register AV *ary = (AV*)*++MARK; 4388 49699 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied); 4389 4390 49699 if (mg) { 4391 7 *MARK-- = SvTIED_obj((SV*)ary, mg); 4392 7 PUSHMARK(MARK); 4393 7 PUTBACK; 4394 7 ENTER; 4395 7 call_method("UNSHIFT",G_SCALAR|G_DISCARD); 4396 7 LEAVE; 4397 7 SPAGAIN; 4398 } 4399 else { 4400 49692 register I32 i = 0; 4401 49692 av_unshift(ary, SP - MARK); 4402 110506 while (MARK < SP) { 4403 60814 SV * const sv = newSVsv(*++MARK); 4404 60814 (void)av_store(ary, i++, sv); 4405 } 4406 } 4407 49699 SP = ORIGMARK; 4408 49699 PUSHi( AvFILL(ary) + 1 ); 4409 49699 RETURN; 4410 } 4411 4412 PP(pp_reverse) 4413 70232 { 4414 70232 dSP; dMARK; 4415 70232 SV ** const oldsp = SP; 4416 4417 70232 if (GIMME == G_ARRAY) { 4418 13699 MARK++; 4419 52957 while (MARK < SP) { 4420 39258 register SV * const tmp = *MARK; 4421 39258 *MARK++ = *SP; 4422 39258 *SP-- = tmp; 4423 } 4424 /* safe as long as stack cannot get extended in the above */ 4425 13699 SP = oldsp; 4426 } 4427 else { 4428 56533 register char *up; 4429 56533 register char *down; 4430 56533 register I32 tmp; 4431 56533 dTARGET; 4432 56533 STRLEN len; 4433 56533 I32 padoff_du; 4434 4435 56533 SvUTF8_off(TARG); /* decontaminate */ 4436 56533 if (SP - MARK > 1) 4437 21 do_join(TARG, &PL_sv_no, MARK, SP); 4438 else 4439 sv_setsv(TARG, (SP > MARK) 4440 ? *SP 4441 : (padoff_du = find_rundefsvoffset(), 4442 (padoff_du == NOT_IN_PAD || PAD_COMPNAME_FLAGS(padoff_du) & SVpad_OUR) 4443 56512 ? DEFSV : PAD_SVl(padoff_du))); 4444 56533 up = SvPV_force(TARG, len); 4445 56533 if (len > 1) { 4446 35403 if (DO_UTF8(TARG)) { /* first reverse each character */ 4447 6 U8* s = (U8*)SvPVX(TARG); 4448 6 const U8* send = (U8*)(s + len); 4449 41 while (s < send) { 4450 35 if (UTF8_IS_INVARIANT(*s)) { 4451 24 s++; 4452 24 continue; 4453 } 4454 else { 4455 11 if (!utf8_to_uvchr(s, 0)) 4456 ###### break; 4457 11 up = (char*)s; 4458 11 s += UTF8SKIP(s); 4459 11 down = (char*)(s - 1); 4460 /* reverse this character */ 4461 22 while (down > up) { 4462 11 tmp = *up; 4463 11 *up++ = *down; 4464 11 *down-- = (char)tmp; 4465 } 4466 } 4467 } 4468 6 up = SvPVX(TARG); 4469 } 4470 35403 down = SvPVX(TARG) + len - 1; 4471 71768 while (down > up) { 4472 36365 tmp = *up; 4473 36365 *up++ = *down; 4474 36365 *down-- = (char)tmp; 4475 } 4476 35403 (void)SvPOK_only_UTF8(TARG); 4477 } 4478 56533 SP = MARK + 1; 4479 56533 SETTARG; 4480 } 4481 70232 RETURN; 4482 } 4483 4484 PP(pp_split) 4485 453235 { 4486 453235 dVAR; dSP; dTARG; 4487 453235 AV *ary; 4488 453235 register IV limit = POPi; /* note, negative is forever */ 4489 453235 SV * const sv = POPs; 4490 453235 STRLEN len; 4491 453235 register const char *s = SvPV_const(sv, len); 4492 453235 const bool do_utf8 = DO_UTF8(sv); 4493 453235 const char *strend = s + len; 4494 453235 register PMOP *pm; 4495 453235 register REGEXP *rx; 4496 453235 register SV *dstr; 4497 453235 register const char *m; 4498 453235 I32 iters = 0; 4499 453235 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s); 4500 453235 I32 maxiters = slen + 10; 4501 453235 const char *orig; 4502 453235 const I32 origlimit = limit; 4503 453235 I32 realarray = 0; 4504 453235 I32 base; 4505 453235 const I32 gimme = GIMME_V; 4506 453235 const I32 oldsave = PL_savestack_ix; 4507 453235 I32 make_mortal = 1; 4508 453235 bool multiline = 0; 4509 453235 MAGIC *mg = (MAGIC *) NULL; 4510 4511 #ifdef DEBUGGING 4512 453235 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*); 4513 #else 4514 pm = (PMOP*)POPs; 4515 #endif 4516 453235 if (!pm || !s) 4517 ###### DIE(aTHX_ "panic: pp_split"); 4518 453235 rx = PM_GETRE(pm); 4519 4520 TAINT_IF((pm->op_pmflags & PMf_LOCALE) && 4521 453235 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE))); 4522 4523 453235 RX_MATCH_UTF8_set(rx, do_utf8); 4524 4525 453235 if (pm->op_pmreplroot) { 4526 #ifdef USE_ITHREADS 4527 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot))); 4528 #else 4529 269 ary = GvAVn((GV*)pm->op_pmreplroot); 4530 #endif 4531 } 4532 452966 else if (gimme != G_ARRAY) 4533 21 ary = GvAVn(PL_defgv); 4534 else 4535 452945 ary = Nullav; 4536 453235 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) { 4537 290 realarray = 1; 4538 290 PUTBACK; 4539 290 av_extend(ary,0); 4540 290 av_clear(ary); 4541 290 SPAGAIN; 4542 290 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) { 4543 1 PUSHMARK(SP); 4544 1 XPUSHs(SvTIED_obj((SV*)ary, mg)); 4545 } 4546 else { 4547 289 if (!AvREAL(ary)) { 4548 1 I32 i; 4549 1 AvREAL_on(ary); 4550 1 AvREIFY_off(ary); 4551 1 for (i = AvFILLp(ary); i >= 0; i--) 4552 ###### AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */ 4553 } 4554 /* temporarily switch stacks */ 4555 289 SAVESWITCHSTACK(PL_curstack, ary); 4556 289 make_mortal = 0; 4557 } 4558 } 4559 453235 base = SP - PL_stack_base; 4560 453235 orig = s; 4561 453235 if (pm->op_pmflags & PMf_SKIPWHITE) { 4562 7176 if (pm->op_pmflags & PMf_LOCALE) { 4563 ###### while (isSPACE_LC(*s)) 4564 ###### s++; 4565 } 4566 else { 4567 11171 while (isSPACE(*s)) 4568 3995 s++; 4569 } 4570 } 4571 453235 if (pm->op_pmflags & PMf_MULTILINE) { 4572 12682 multiline = 1; 4573 } 4574 4575 453235 if (!limit) 4576 312006 limit = maxiters + 2; 4577 453235 if (pm->op_pmflags & PMf_WHITE) { 4578 17791 while (--limit) { 4579 17071 m = s; 4580 140398 while (m < strend && 4581 !((pm->op_pmflags & PMf_LOCALE) 4582 ? isSPACE_LC(*m) : isSPACE(*m))) 4583 123327 ++m; 4584 17071 if (m >= strend) 4585 6523 break; 4586 4587 10548 dstr = newSVpvn(s, m-s); 4588 10548 if (make_mortal) 4589 10545 sv_2mortal(dstr); 4590 10548 if (do_utf8) 4591 ###### (void)SvUTF8_on(dstr); 4592 10548 XPUSHs(dstr); 4593 4594 10548 s = m + 1; 4595 13945 while (s < strend && 4596 ((pm->op_pmflags & PMf_LOCALE) 4597 ? isSPACE_LC(*s) : isSPACE(*s))) 4598 3397 ++s; 4599 } 4600 } 4601 445992 else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') { 4602 275262 while (--limit) { 4603 275262 for (m = s; m < strend && *m != '\n'; m++) 4604 ; 4605 275262 m++; 4606 275262 if (m >= strend) 4607 12696 break; 4608 262566 dstr = newSVpvn(s, m-s); 4609 262566 if (make_mortal) 4610 262566 sv_2mortal(dstr); 4611 262566 if (do_utf8) 4612 ###### (void)SvUTF8_on(dstr); 4613 262566 XPUSHs(dstr); 4614 262566 s = m; 4615 } 4616 } 4617 433296 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) && 4618 (rx->reganch & RE_USE_INTUIT) && !rx->nparens 4619 && (rx->reganch & ROPT_CHECK_ALL) 4620 && !(rx->reganch & ROPT_ANCH)) { 4621 347431 const int tail = (rx->reganch & RE_INTUIT_TAIL); 4622 347431 SV * const csv = CALLREG_INTUIT_STRING(aTHX_ rx); 4623 4624 347431 len = rx->minlen; 4625 347431 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) { 4626 324087 const char c = *SvPV_nolen_const(csv); 4627 421144 while (--limit) { 4628 419547 for (m = s; m < strend && *m != c; m++) 4629 ; 4630 419547 if (m >= strend) 4631 322490 break; 4632 97057 dstr = newSVpvn(s, m-s); 4633 97057 if (make_mortal) 4634 96756 sv_2mortal(dstr); 4635 97057 if (do_utf8) 4636 ###### (void)SvUTF8_on(dstr); 4637 97057 XPUSHs(dstr); 4638 /* The rx->minlen is in characters but we want to step 4639 * s ahead by bytes. */ 4640 97057 if (do_utf8) 4641 ###### s = (char*)utf8_hop((U8*)m, len); 4642 else 4643 97057 s = m + len; /* Fake \n at the end */ 4644 } 4645 } 4646 else { 4647 30182 while (s < strend && --limit && 4648 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend, 4649 csv, multiline ? FBMrf_MULTILINE : 0)) ) 4650 { 4651 6838 dstr = newSVpvn(s, m-s); 4652 6838 if (make_mortal) 4653 6739 sv_2mortal(dstr); 4654 6838 if (do_utf8) 4655 2 (void)SvUTF8_on(dstr); 4656 6838 XPUSHs(dstr); 4657 /* The rx->minlen is in characters but we want to step 4658 * s ahead by bytes. */ 4659 6838 if (do_utf8) 4660 2 s = (char*)utf8_hop((U8*)m, len); 4661 else 4662 6836 s = m + len; /* Fake \n at the end */ 4663 } 4664 } 4665 } 4666 else { 4667 85865 maxiters += slen * rx->nparens; 4668 571911 while (s < strend && --limit) 4669 { 4670 539867 I32 rex_return; 4671 539867 PUTBACK; 4672 539867 rex_return = CALLREGEXEC(aTHX_ rx, (char*)s, (char*)strend, (char*)orig, 1 , 4673 sv, NULL, 0); 4674 539867 SPAGAIN; 4675 539867 if (rex_return == 0) 4676 53821 break; 4677 486046 TAINT_IF(RX_MATCH_TAINTED(rx)); 4678 486046 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) { 4679 ###### m = s; 4680 ###### s = orig; 4681 ###### orig = rx->subbeg; 4682 ###### s = orig + (m - s); 4683 ###### strend = s + (strend - m); 4684 } 4685 486046 m = rx->startp[0] + orig; 4686 486046 dstr = newSVpvn(s, m-s); 4687 486046 if (make_mortal) 4688 485995 sv_2mortal(dstr); 4689 486046 if (do_utf8) 4690 210 (void)SvUTF8_on(dstr); 4691 486046 XPUSHs(dstr); 4692 486046 if (rx->nparens) { 4693 9386 I32 i; 4694 18772 for (i = 1; i <= (I32)rx->nparens; i++) { 4695 9386 s = rx->startp[i] + orig; 4696 9386 m = rx->endp[i] + orig; 4697 4698 /* japhy (07/27/01) -- the (m && s) test doesn't catch 4699 parens that didn't match -- they should be set to 4700 undef, not the empty string */ 4701 9386 if (m >= orig && s >= orig) { 4702 9373 dstr = newSVpvn(s, m-s); 4703 } 4704 else 4705 13 dstr = &PL_sv_undef; /* undef, not "" */ 4706 9386 if (make_mortal) 4707 9383 sv_2mortal(dstr); 4708 9386 if (do_utf8) 4709 32 (void)SvUTF8_on(dstr); 4710 9386 XPUSHs(dstr); 4711 } 4712 } 4713 486046 s = rx->endp[0] + orig; 4714 } 4715 } 4716 4717 453235 iters = (SP - PL_stack_base) - base; 4718 453235 if (iters > maxiters) 4719 ###### DIE(aTHX_ "Split loop"); 4720 4721 /* keep field after final delim? */ 4722 453235 if (s < strend || (iters && origlimit)) { 4723 440532 const STRLEN l = strend - s; 4724 440532 dstr = newSVpvn(s, l); 4725 440532 if (make_mortal) 4726 440266 sv_2mortal(dstr); 4727 440532 if (do_utf8) 4728 14 (void)SvUTF8_on(dstr); 4729 440532 XPUSHs(dstr); 4730 440532 iters++; 4731 } 4732 12703 else if (!origlimit) { 4733 61073 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) { 4734 50021 if (TOPs && !make_mortal) 4735 7 sv_2mortal(TOPs); 4736 50021 iters--; 4737 50021 *SP-- = &PL_sv_undef; 4738 } 4739 } 4740 4741 453235 PUTBACK; 4742 453235 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */ 4743 453235 SPAGAIN; 4744 453235 if (realarray) { 4745 290 if (!mg) { 4746 289 if (SvSMAGICAL(ary)) { 4747 ###### PUTBACK; 4748 ###### mg_set((SV*)ary); 4749 ###### SPAGAIN; 4750 } 4751 289 if (gimme == G_ARRAY) { 4752 1 EXTEND(SP, iters); 4753 1 Copy(AvARRAY(ary), SP + 1, iters, SV*); 4754 1 SP += iters; 4755 1 RETURN; 4756 } 4757 } 4758 else { 4759 1 PUTBACK; 4760 1 ENTER; 4761 1 call_method("PUSH",G_SCALAR|G_DISCARD); 4762 1 LEAVE; 4763 1 SPAGAIN; 4764 1 if (gimme == G_ARRAY) { 4765 ###### I32 i; 4766 /* EXTEND should not be needed - we just popped them */ 4767 ###### EXTEND(SP, iters); 4768 ###### for (i=0; i < iters; i++) { 4769 ###### SV **svp = av_fetch(ary, i, FALSE); 4770 ###### PUSHs((svp) ? *svp : &PL_sv_undef); 4771 } 4772 ###### RETURN; 4773 } 4774 } 4775 } 4776 else { 4777 452945 if (gimme == G_ARRAY) 4778 452945 RETURN; 4779 } 4780 4781 289 GETTARGET; 4782 289 PUSHi(iters); 4783 289 RETURN; 4784 } 4785 4786 PP(pp_lock) 4787 1 { 4788 1 dSP; 4789 1 dTOPss; 4790 1 SV *retsv = sv; 4791 1 SvLOCK(sv); 4792 1 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV 4793 || SvTYPE(retsv) == SVt_PVCV) { 4794 1 retsv = refto(retsv); 4795 } 4796 1 SETs(retsv); 4797 1 RETURN; 4798 } 4799 4800 PP(pp_threadsv) 4801 ###### { 4802 ###### DIE(aTHX_ "tried to access per-thread data in non-threaded perl"); 4803 } 4804 4805 /* 4806 * Local variables: 4807 * c-indentation-style: bsd 4808 * c-basic-offset: 4 4809 * indent-tabs-mode: t 4810 * End: 4811 * 4812 * ex: set ts=8 sts=4 sw=4 noet: 4813 */