1 /* pp.c 2 * 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others 5 * 6 * You may distribute under the terms of either the GNU General Public 7 * License or the Artistic License, as specified in the README file. 8 * 9 */ 10 11 /* 12 * 'It's a big house this, and very peculiar. Always a bit more 13 * to discover, and no knowing what you'll find round a corner. 14 * And Elves, sir!' --Samwise Gamgee 15 * 16 * [p.225 of _The Lord of the Rings_, II/i: "Many Meetings"] 17 */ 18 19 /* This file contains general pp ("push/pop") functions that execute the 20 * opcodes that make up a perl program. A typical pp function expects to 21 * find its arguments on the stack, and usually pushes its results onto 22 * the stack, hence the 'pp' terminology. Each OP structure contains 23 * a pointer to the relevant pp_foo() function. 24 */ 25 26 #include "EXTERN.h" 27 #define PERL_IN_PP_C 28 #include "perl.h" 29 #include "keywords.h" 30 31 #include "invlist_inline.h" 32 #include "reentr.h" 33 #include "regcharclass.h" 34 35 /* variations on pp_null */ 36 37 PP(pp_stub) 38 { 39 dSP; 40 if (GIMME_V == G_SCALAR) 41 XPUSHs(&PL_sv_undef); 42 RETURN; 43 } 44 45 /* Pushy stuff. */ 46 47 48 49 PP(pp_padcv) 50 { 51 dSP; dTARGET; 52 assert(SvTYPE(TARG) == SVt_PVCV); 53 XPUSHs(TARG); 54 RETURN; 55 } 56 57 PP(pp_introcv) 58 { 59 dTARGET; 60 SvPADSTALE_off(TARG); 61 return NORMAL; 62 } 63 64 PP(pp_clonecv) 65 { 66 dTARGET; 67 CV * const protocv = PadnamePROTOCV( 68 PadlistNAMESARRAY(CvPADLIST(find_runcv(NULL)))[ARGTARG] 69 ); 70 assert(SvTYPE(TARG) == SVt_PVCV); 71 assert(protocv); 72 if (CvISXSUB(protocv)) { /* constant */ 73 /* XXX Should we clone it here? */ 74 /* If this changes to use SAVECLEARSV, we can move the SAVECLEARSV 75 to introcv and remove the SvPADSTALE_off. */ 76 SAVEPADSVANDMORTALIZE(ARGTARG); 77 PAD_SVl(ARGTARG) = SvREFCNT_inc_simple_NN(protocv); 78 } 79 else { 80 if (CvROOT(protocv)) { 81 assert(CvCLONE(protocv)); 82 assert(!CvCLONED(protocv)); 83 } 84 cv_clone_into(protocv,(CV *)TARG); 85 SAVECLEARSV(PAD_SVl(ARGTARG)); 86 } 87 return NORMAL; 88 } 89 90 /* Translations. */ 91 92 /* In some cases this function inspects PL_op. If this function is called 93 for new op types, more bool parameters may need to be added in place of 94 the checks. 95 96 When noinit is true, the absence of a gv will cause a retval of undef. 97 This is unrelated to the cv-to-gv assignment case. 98 */ 99 100 static SV * 101 S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict, 102 const bool noinit) 103 { 104 if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv); 105 if (SvROK(sv)) { 106 if (SvAMAGIC(sv)) { 107 sv = amagic_deref_call(sv, to_gv_amg); 108 } 109 wasref: 110 sv = SvRV(sv); 111 if (SvTYPE(sv) == SVt_PVIO) { 112 GV * const gv = MUTABLE_GV(sv_newmortal()); 113 gv_init(gv, 0, "__ANONIO__", 10, 0); 114 GvIOp(gv) = MUTABLE_IO(sv); 115 SvREFCNT_inc_void_NN(sv); 116 sv = MUTABLE_SV(gv); 117 } 118 else if (!isGV_with_GP(sv)) { 119 Perl_die(aTHX_ "Not a GLOB reference"); 120 } 121 } 122 else { 123 if (!isGV_with_GP(sv)) { 124 if (!SvOK(sv)) { 125 /* If this is a 'my' scalar and flag is set then vivify 126 * NI-S 1999/05/07 127 */ 128 if (vivify_sv && sv != &PL_sv_undef) { 129 GV *gv; 130 HV *stash; 131 if (SvREADONLY(sv)) 132 Perl_croak_no_modify(); 133 gv = MUTABLE_GV(newSV(0)); 134 stash = CopSTASH(PL_curcop); 135 if (SvTYPE(stash) != SVt_PVHV) stash = NULL; 136 if (cUNOP->op_targ) { 137 SV * const namesv = PAD_SV(cUNOP->op_targ); 138 gv_init_sv(gv, stash, namesv, 0); 139 } 140 else { 141 gv_init_pv(gv, stash, "__ANONIO__", 0); 142 } 143 prepare_SV_for_RV(sv); 144 SvRV_set(sv, MUTABLE_SV(gv)); 145 SvROK_on(sv); 146 SvSETMAGIC(sv); 147 goto wasref; 148 } 149 if (PL_op->op_flags & OPf_REF || strict) { 150 Perl_die(aTHX_ PL_no_usym, "a symbol"); 151 } 152 if (ckWARN(WARN_UNINITIALIZED)) 153 report_uninit(sv); 154 return &PL_sv_undef; 155 } 156 if (noinit) 157 { 158 if (!(sv = MUTABLE_SV(gv_fetchsv_nomg( 159 sv, GV_ADDMG, SVt_PVGV 160 )))) 161 return &PL_sv_undef; 162 } 163 else { 164 if (strict) { 165 Perl_die(aTHX_ 166 PL_no_symref_sv, 167 sv, 168 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), 169 "a symbol" 170 ); 171 } 172 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV)) 173 == OPpDONT_INIT_GV) { 174 /* We are the target of a coderef assignment. Return 175 the scalar unchanged, and let pp_sasssign deal with 176 things. */ 177 return sv; 178 } 179 sv = MUTABLE_SV(gv_fetchsv_nomg(sv, GV_ADD, SVt_PVGV)); 180 } 181 /* FAKE globs in the symbol table cause weird bugs (#77810) */ 182 SvFAKE_off(sv); 183 } 184 } 185 if (SvFAKE(sv) && !(PL_op->op_private & OPpALLOW_FAKE)) { 186 SV *newsv = sv_newmortal(); 187 sv_setsv_flags(newsv, sv, 0); 188 SvFAKE_off(newsv); 189 sv = newsv; 190 } 191 return sv; 192 } 193 194 PP(pp_rv2gv) 195 { 196 dSP; dTOPss; 197 198 sv = S_rv2gv(aTHX_ 199 sv, PL_op->op_private & OPpDEREF, 200 PL_op->op_private & HINT_STRICT_REFS, 201 ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD)) 202 || PL_op->op_type == OP_READLINE 203 ); 204 if (PL_op->op_private & OPpLVAL_INTRO) 205 save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL)); 206 SETs(sv); 207 RETURN; 208 } 209 210 /* Helper function for pp_rv2sv and pp_rv2av */ 211 GV * 212 Perl_softref2xv(pTHX_ SV *const sv, const char *const what, 213 const svtype type, SV ***spp) 214 { 215 GV *gv; 216 217 PERL_ARGS_ASSERT_SOFTREF2XV; 218 219 if (PL_op->op_private & HINT_STRICT_REFS) { 220 if (SvOK(sv)) 221 Perl_die(aTHX_ PL_no_symref_sv, sv, 222 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what); 223 else 224 Perl_die(aTHX_ PL_no_usym, what); 225 } 226 if (!SvOK(sv)) { 227 if ( 228 PL_op->op_flags & OPf_REF 229 ) 230 Perl_die(aTHX_ PL_no_usym, what); 231 if (ckWARN(WARN_UNINITIALIZED)) 232 report_uninit(sv); 233 if (type != SVt_PV && GIMME_V == G_ARRAY) { 234 (*spp)--; 235 return NULL; 236 } 237 **spp = &PL_sv_undef; 238 return NULL; 239 } 240 if ((PL_op->op_flags & OPf_SPECIAL) && 241 !(PL_op->op_flags & OPf_MOD)) 242 { 243 if (!(gv = gv_fetchsv_nomg(sv, GV_ADDMG, type))) 244 { 245 **spp = &PL_sv_undef; 246 return NULL; 247 } 248 } 249 else { 250 gv = gv_fetchsv_nomg(sv, GV_ADD, type); 251 } 252 return gv; 253 } 254 255 PP(pp_rv2sv) 256 { 257 dSP; dTOPss; 258 GV *gv = NULL; 259 260 SvGETMAGIC(sv); 261 if (SvROK(sv)) { 262 if (SvAMAGIC(sv)) { 263 sv = amagic_deref_call(sv, to_sv_amg); 264 } 265 266 sv = SvRV(sv); 267 if (SvTYPE(sv) >= SVt_PVAV) 268 DIE(aTHX_ "Not a SCALAR reference"); 269 } 270 else { 271 gv = MUTABLE_GV(sv); 272 273 if (!isGV_with_GP(gv)) { 274 gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp); 275 if (!gv) 276 RETURN; 277 } 278 sv = GvSVn(gv); 279 } 280 if (PL_op->op_flags & OPf_MOD) { 281 if (PL_op->op_private & OPpLVAL_INTRO) { 282 if (cUNOP->op_first->op_type == OP_NULL) 283 sv = save_scalar(MUTABLE_GV(TOPs)); 284 else if (gv) 285 sv = save_scalar(gv); 286 else 287 Perl_croak(aTHX_ "%s", PL_no_localize_ref); 288 } 289 else if (PL_op->op_private & OPpDEREF) 290 sv = vivify_ref(sv, PL_op->op_private & OPpDEREF); 291 } 292 SPAGAIN; /* in case chasing soft refs reallocated the stack */ 293 SETs(sv); 294 RETURN; 295 } 296 297 PP(pp_av2arylen) 298 { 299 dSP; 300 AV * const av = MUTABLE_AV(TOPs); 301 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET; 302 if (lvalue) { 303 SV ** const svp = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av)); 304 if (!*svp) { 305 *svp = newSV_type(SVt_PVMG); 306 sv_magic(*svp, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0); 307 } 308 SETs(*svp); 309 } else { 310 SETs(sv_2mortal(newSViv(AvFILL(MUTABLE_AV(av))))); 311 } 312 RETURN; 313 } 314 315 PP(pp_pos) 316 { 317 dSP; dTOPss; 318 319 if (PL_op->op_flags & OPf_MOD || LVRET) { 320 SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));/* Not TARG RT#67838 */ 321 sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0); 322 LvTYPE(ret) = '.'; 323 LvTARG(ret) = SvREFCNT_inc_simple(sv); 324 SETs(ret); /* no SvSETMAGIC */ 325 } 326 else { 327 const MAGIC * const mg = mg_find_mglob(sv); 328 if (mg && mg->mg_len != -1) { 329 STRLEN i = mg->mg_len; 330 if (PL_op->op_private & OPpTRUEBOOL) 331 SETs(i ? &PL_sv_yes : &PL_sv_zero); 332 else { 333 dTARGET; 334 if (mg->mg_flags & MGf_BYTES && DO_UTF8(sv)) 335 i = sv_pos_b2u_flags(sv, i, SV_GMAGIC|SV_CONST_RETURN); 336 SETu(i); 337 } 338 return NORMAL; 339 } 340 SETs(&PL_sv_undef); 341 } 342 return NORMAL; 343 } 344 345 PP(pp_rv2cv) 346 { 347 dSP; 348 GV *gv; 349 HV *stash_unused; 350 const I32 flags = (PL_op->op_flags & OPf_SPECIAL) 351 ? GV_ADDMG 352 : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT)) 353 == OPpMAY_RETURN_CONSTANT) 354 ? GV_ADD|GV_NOEXPAND 355 : GV_ADD; 356 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */ 357 /* (But not in defined().) */ 358 359 CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags); 360 if (cv) NOOP; 361 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) { 362 cv = SvTYPE(SvRV(gv)) == SVt_PVCV 363 ? MUTABLE_CV(SvRV(gv)) 364 : MUTABLE_CV(gv); 365 } 366 else 367 cv = MUTABLE_CV(&PL_sv_undef); 368 SETs(MUTABLE_SV(cv)); 369 return NORMAL; 370 } 371 372 PP(pp_prototype) 373 { 374 dSP; 375 CV *cv; 376 HV *stash; 377 GV *gv; 378 SV *ret = &PL_sv_undef; 379 380 if (SvGMAGICAL(TOPs)) SETs(sv_mortalcopy(TOPs)); 381 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) { 382 const char * s = SvPVX_const(TOPs); 383 if (memBEGINs(s, SvCUR(TOPs), "CORE::")) { 384 const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1); 385 if (!code) 386 DIE(aTHX_ "Can't find an opnumber for \"%" UTF8f "\"", 387 UTF8fARG(SvFLAGS(TOPs) & SVf_UTF8, SvCUR(TOPs)-6, s+6)); 388 { 389 SV * const sv = core_prototype(NULL, s + 6, code, NULL); 390 if (sv) ret = sv; 391 } 392 goto set; 393 } 394 } 395 cv = sv_2cv(TOPs, &stash, &gv, 0); 396 if (cv && SvPOK(cv)) 397 ret = newSVpvn_flags( 398 CvPROTO(cv), CvPROTOLEN(cv), SVs_TEMP | SvUTF8(cv) 399 ); 400 set: 401 SETs(ret); 402 RETURN; 403 } 404 405 PP(pp_anoncode) 406 { 407 dSP; 408 CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ)); 409 if (CvCLONE(cv)) 410 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv)))); 411 EXTEND(SP,1); 412 PUSHs(MUTABLE_SV(cv)); 413 RETURN; 414 } 415 416 PP(pp_srefgen) 417 { 418 dSP; 419 *SP = refto(*SP); 420 return NORMAL; 421 } 422 423 PP(pp_refgen) 424 { 425 dSP; dMARK; 426 if (GIMME_V != G_ARRAY) { 427 if (++MARK <= SP) 428 *MARK = *SP; 429 else 430 { 431 MEXTEND(SP, 1); 432 *MARK = &PL_sv_undef; 433 } 434 *MARK = refto(*MARK); 435 SP = MARK; 436 RETURN; 437 } 438 EXTEND_MORTAL(SP - MARK); 439 while (++MARK <= SP) 440 *MARK = refto(*MARK); 441 RETURN; 442 } 443 444 STATIC SV* 445 S_refto(pTHX_ SV *sv) 446 { 447 SV* rv; 448 449 PERL_ARGS_ASSERT_REFTO; 450 451 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') { 452 if (LvTARGLEN(sv)) 453 vivify_defelem(sv); 454 if (!(sv = LvTARG(sv))) 455 sv = &PL_sv_undef; 456 else 457 SvREFCNT_inc_void_NN(sv); 458 } 459 else if (SvTYPE(sv) == SVt_PVAV) { 460 if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv)) 461 av_reify(MUTABLE_AV(sv)); 462 SvTEMP_off(sv); 463 SvREFCNT_inc_void_NN(sv); 464 } 465 else if (SvPADTMP(sv)) { 466 sv = newSVsv(sv); 467 } 468 else if (UNLIKELY(SvSMAGICAL(sv) && mg_find(sv, PERL_MAGIC_nonelem))) 469 sv_unmagic(SvREFCNT_inc_simple_NN(sv), PERL_MAGIC_nonelem); 470 else { 471 SvTEMP_off(sv); 472 SvREFCNT_inc_void_NN(sv); 473 } 474 rv = sv_newmortal(); 475 sv_upgrade(rv, SVt_IV); 476 SvRV_set(rv, sv); 477 SvROK_on(rv); 478 return rv; 479 } 480 481 PP(pp_ref) 482 { 483 dSP; 484 SV * const sv = TOPs; 485 486 SvGETMAGIC(sv); 487 if (!SvROK(sv)) { 488 SETs(&PL_sv_no); 489 return NORMAL; 490 } 491 492 /* op is in boolean context? */ 493 if ( (PL_op->op_private & OPpTRUEBOOL) 494 || ( (PL_op->op_private & OPpMAYBE_TRUEBOOL) 495 && block_gimme() == G_VOID)) 496 { 497 /* refs are always true - unless it's to an object blessed into a 498 * class with a false name, i.e. "0". So we have to check for 499 * that remote possibility. The following is is basically an 500 * unrolled SvTRUE(sv_reftype(rv)) */ 501 SV * const rv = SvRV(sv); 502 if (SvOBJECT(rv)) { 503 HV *stash = SvSTASH(rv); 504 HEK *hek = HvNAME_HEK(stash); 505 if (hek) { 506 I32 len = HEK_LEN(hek); 507 /* bail out and do it the hard way? */ 508 if (UNLIKELY( 509 len == HEf_SVKEY 510 || (len == 1 && HEK_KEY(hek)[0] == '0') 511 )) 512 goto do_sv_ref; 513 } 514 } 515 SETs(&PL_sv_yes); 516 return NORMAL; 517 } 518 519 do_sv_ref: 520 { 521 dTARGET; 522 SETs(TARG); 523 sv_ref(TARG, SvRV(sv), TRUE); 524 SvSETMAGIC(TARG); 525 return NORMAL; 526 } 527 528 } 529 530 531 PP(pp_bless) 532 { 533 dSP; 534 HV *stash; 535 536 if (MAXARG == 1) 537 { 538 curstash: 539 stash = CopSTASH(PL_curcop); 540 if (SvTYPE(stash) != SVt_PVHV) 541 Perl_croak(aTHX_ "Attempt to bless into a freed package"); 542 } 543 else { 544 SV * const ssv = POPs; 545 STRLEN len; 546 const char *ptr; 547 548 if (!ssv) goto curstash; 549 SvGETMAGIC(ssv); 550 if (SvROK(ssv)) { 551 if (!SvAMAGIC(ssv)) { 552 frog: 553 Perl_croak(aTHX_ "Attempt to bless into a reference"); 554 } 555 /* SvAMAGIC is on here, but it only means potentially overloaded, 556 so after stringification: */ 557 ptr = SvPV_nomg_const(ssv,len); 558 /* We need to check the flag again: */ 559 if (!SvAMAGIC(ssv)) goto frog; 560 } 561 else ptr = SvPV_nomg_const(ssv,len); 562 if (len == 0) 563 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), 564 "Explicit blessing to '' (assuming package main)"); 565 stash = gv_stashpvn(ptr, len, GV_ADD|SvUTF8(ssv)); 566 } 567 568 (void)sv_bless(TOPs, stash); 569 RETURN; 570 } 571 572 PP(pp_gelem) 573 { 574 dSP; 575 576 SV *sv = POPs; 577 STRLEN len; 578 const char * const elem = SvPV_const(sv, len); 579 GV * const gv = MUTABLE_GV(TOPs); 580 SV * tmpRef = NULL; 581 582 sv = NULL; 583 if (elem) { 584 /* elem will always be NUL terminated. */ 585 switch (*elem) { 586 case 'A': 587 if (memEQs(elem, len, "ARRAY")) 588 { 589 tmpRef = MUTABLE_SV(GvAV(gv)); 590 if (tmpRef && !AvREAL((const AV *)tmpRef) 591 && AvREIFY((const AV *)tmpRef)) 592 av_reify(MUTABLE_AV(tmpRef)); 593 } 594 break; 595 case 'C': 596 if (memEQs(elem, len, "CODE")) 597 tmpRef = MUTABLE_SV(GvCVu(gv)); 598 break; 599 case 'F': 600 if (memEQs(elem, len, "FILEHANDLE")) { 601 tmpRef = MUTABLE_SV(GvIOp(gv)); 602 } 603 else 604 if (memEQs(elem, len, "FORMAT")) 605 tmpRef = MUTABLE_SV(GvFORM(gv)); 606 break; 607 case 'G': 608 if (memEQs(elem, len, "GLOB")) 609 tmpRef = MUTABLE_SV(gv); 610 break; 611 case 'H': 612 if (memEQs(elem, len, "HASH")) 613 tmpRef = MUTABLE_SV(GvHV(gv)); 614 break; 615 case 'I': 616 if (memEQs(elem, len, "IO")) 617 tmpRef = MUTABLE_SV(GvIOp(gv)); 618 break; 619 case 'N': 620 if (memEQs(elem, len, "NAME")) 621 sv = newSVhek(GvNAME_HEK(gv)); 622 break; 623 case 'P': 624 if (memEQs(elem, len, "PACKAGE")) { 625 const HV * const stash = GvSTASH(gv); 626 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL; 627 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__"); 628 } 629 break; 630 case 'S': 631 if (memEQs(elem, len, "SCALAR")) 632 tmpRef = GvSVn(gv); 633 break; 634 } 635 } 636 if (tmpRef) 637 sv = newRV(tmpRef); 638 if (sv) 639 sv_2mortal(sv); 640 else 641 sv = &PL_sv_undef; 642 SETs(sv); 643 RETURN; 644 } 645 646 /* Pattern matching */ 647 648 PP(pp_study) 649 { 650 dSP; dTOPss; 651 STRLEN len; 652 653 (void)SvPV(sv, len); 654 if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) { 655 /* Historically, study was skipped in these cases. */ 656 SETs(&PL_sv_no); 657 return NORMAL; 658 } 659 660 /* Make study a no-op. It's no longer useful and its existence 661 complicates matters elsewhere. */ 662 SETs(&PL_sv_yes); 663 return NORMAL; 664 } 665 666 667 /* also used for: pp_transr() */ 668 669 PP(pp_trans) 670 { 671 dSP; 672 SV *sv; 673 674 if (PL_op->op_flags & OPf_STACKED) 675 sv = POPs; 676 else { 677 EXTEND(SP,1); 678 if (ARGTARG) 679 sv = PAD_SV(ARGTARG); 680 else { 681 sv = DEFSV; 682 } 683 } 684 if(PL_op->op_type == OP_TRANSR) { 685 STRLEN len; 686 const char * const pv = SvPV(sv,len); 687 SV * const newsv = newSVpvn_flags(pv, len, SVs_TEMP|SvUTF8(sv)); 688 do_trans(newsv); 689 PUSHs(newsv); 690 } 691 else { 692 Size_t i = do_trans(sv); 693 mPUSHi((UV)i); 694 } 695 RETURN; 696 } 697 698 /* Lvalue operators. */ 699 700 static size_t 701 S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping) 702 { 703 STRLEN len; 704 char *s; 705 size_t count = 0; 706 707 PERL_ARGS_ASSERT_DO_CHOMP; 708 709 if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs))) 710 return 0; 711 if (SvTYPE(sv) == SVt_PVAV) { 712 I32 i; 713 AV *const av = MUTABLE_AV(sv); 714 const I32 max = AvFILL(av); 715 716 for (i = 0; i <= max; i++) { 717 sv = MUTABLE_SV(av_fetch(av, i, FALSE)); 718 if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef)) 719 count += do_chomp(retval, sv, chomping); 720 } 721 return count; 722 } 723 else if (SvTYPE(sv) == SVt_PVHV) { 724 HV* const hv = MUTABLE_HV(sv); 725 HE* entry; 726 (void)hv_iterinit(hv); 727 while ((entry = hv_iternext(hv))) 728 count += do_chomp(retval, hv_iterval(hv,entry), chomping); 729 return count; 730 } 731 else if (SvREADONLY(sv)) { 732 Perl_croak_no_modify(); 733 } 734 735 s = SvPV(sv, len); 736 if (chomping) { 737 if (s && len) { 738 char *temp_buffer = NULL; 739 SV *svrecode = NULL; 740 s += --len; 741 if (RsPARA(PL_rs)) { 742 if (*s != '\n') 743 goto nope_free_nothing; 744 ++count; 745 while (len && s[-1] == '\n') { 746 --len; 747 --s; 748 ++count; 749 } 750 } 751 else { 752 STRLEN rslen, rs_charlen; 753 const char *rsptr = SvPV_const(PL_rs, rslen); 754 755 rs_charlen = SvUTF8(PL_rs) 756 ? sv_len_utf8(PL_rs) 757 : rslen; 758 759 if (SvUTF8(PL_rs) != SvUTF8(sv)) { 760 /* Assumption is that rs is shorter than the scalar. */ 761 if (SvUTF8(PL_rs)) { 762 /* RS is utf8, scalar is 8 bit. */ 763 bool is_utf8 = TRUE; 764 temp_buffer = (char*)bytes_from_utf8((U8*)rsptr, 765 &rslen, &is_utf8); 766 if (is_utf8) { 767 /* Cannot downgrade, therefore cannot possibly match. 768 At this point, temp_buffer is not alloced, and 769 is the buffer inside PL_rs, so dont free it. 770 */ 771 assert (temp_buffer == rsptr); 772 goto nope_free_sv; 773 } 774 rsptr = temp_buffer; 775 } 776 else { 777 /* RS is 8 bit, scalar is utf8. */ 778 temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen); 779 rsptr = temp_buffer; 780 } 781 } 782 if (rslen == 1) { 783 if (*s != *rsptr) 784 goto nope_free_all; 785 ++count; 786 } 787 else { 788 if (len < rslen - 1) 789 goto nope_free_all; 790 len -= rslen - 1; 791 s -= rslen - 1; 792 if (memNE(s, rsptr, rslen)) 793 goto nope_free_all; 794 count += rs_charlen; 795 } 796 } 797 SvPV_force_nomg_nolen(sv); 798 SvCUR_set(sv, len); 799 *SvEND(sv) = '\0'; 800 SvNIOK_off(sv); 801 SvSETMAGIC(sv); 802 803 nope_free_all: 804 Safefree(temp_buffer); 805 nope_free_sv: 806 SvREFCNT_dec(svrecode); 807 nope_free_nothing: ; 808 } 809 } else { 810 if (len && (!SvPOK(sv) || SvIsCOW(sv))) 811 s = SvPV_force_nomg(sv, len); 812 if (DO_UTF8(sv)) { 813 if (s && len) { 814 char * const send = s + len; 815 char * const start = s; 816 s = send - 1; 817 while (s > start && UTF8_IS_CONTINUATION(*s)) 818 s--; 819 if (is_utf8_string((U8*)s, send - s)) { 820 sv_setpvn(retval, s, send - s); 821 *s = '\0'; 822 SvCUR_set(sv, s - start); 823 SvNIOK_off(sv); 824 SvUTF8_on(retval); 825 } 826 } 827 else 828 SvPVCLEAR(retval); 829 } 830 else if (s && len) { 831 s += --len; 832 sv_setpvn(retval, s, 1); 833 *s = '\0'; 834 SvCUR_set(sv, len); 835 SvUTF8_off(sv); 836 SvNIOK_off(sv); 837 } 838 else 839 SvPVCLEAR(retval); 840 SvSETMAGIC(sv); 841 } 842 return count; 843 } 844 845 846 /* also used for: pp_schomp() */ 847 848 PP(pp_schop) 849 { 850 dSP; dTARGET; 851 const bool chomping = PL_op->op_type == OP_SCHOMP; 852 853 const size_t count = do_chomp(TARG, TOPs, chomping); 854 if (chomping) 855 sv_setiv(TARG, count); 856 SETTARG; 857 return NORMAL; 858 } 859 860 861 /* also used for: pp_chomp() */ 862 863 PP(pp_chop) 864 { 865 dSP; dMARK; dTARGET; dORIGMARK; 866 const bool chomping = PL_op->op_type == OP_CHOMP; 867 size_t count = 0; 868 869 while (MARK < SP) 870 count += do_chomp(TARG, *++MARK, chomping); 871 if (chomping) 872 sv_setiv(TARG, count); 873 SP = ORIGMARK; 874 XPUSHTARG; 875 RETURN; 876 } 877 878 PP(pp_undef) 879 { 880 dSP; 881 SV *sv; 882 883 if (!PL_op->op_private) { 884 EXTEND(SP, 1); 885 RETPUSHUNDEF; 886 } 887 888 sv = TOPs; 889 if (!sv) 890 { 891 SETs(&PL_sv_undef); 892 return NORMAL; 893 } 894 895 if (SvTHINKFIRST(sv)) 896 sv_force_normal_flags(sv, SV_COW_DROP_PV|SV_IMMEDIATE_UNREF); 897 898 switch (SvTYPE(sv)) { 899 case SVt_NULL: 900 break; 901 case SVt_PVAV: 902 av_undef(MUTABLE_AV(sv)); 903 break; 904 case SVt_PVHV: 905 hv_undef(MUTABLE_HV(sv)); 906 break; 907 case SVt_PVCV: 908 if (cv_const_sv((const CV *)sv)) 909 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), 910 "Constant subroutine %" SVf " undefined", 911 SVfARG(CvANON((const CV *)sv) 912 ? newSVpvs_flags("(anonymous)", SVs_TEMP) 913 : sv_2mortal(newSVhek( 914 CvNAMED(sv) 915 ? CvNAME_HEK((CV *)sv) 916 : GvENAME_HEK(CvGV((const CV *)sv)) 917 )) 918 )); 919 /* FALLTHROUGH */ 920 case SVt_PVFM: 921 /* let user-undef'd sub keep its identity */ 922 cv_undef_flags(MUTABLE_CV(sv), CV_UNDEF_KEEP_NAME); 923 break; 924 case SVt_PVGV: 925 assert(isGV_with_GP(sv)); 926 assert(!SvFAKE(sv)); 927 { 928 GP *gp; 929 HV *stash; 930 931 /* undef *Pkg::meth_name ... */ 932 bool method_changed 933 = GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv)) 934 && HvENAME_get(stash); 935 /* undef *Foo:: */ 936 if((stash = GvHV((const GV *)sv))) { 937 if(HvENAME_get(stash)) 938 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash)); 939 else stash = NULL; 940 } 941 942 SvREFCNT_inc_simple_void_NN(sv_2mortal(sv)); 943 gp_free(MUTABLE_GV(sv)); 944 Newxz(gp, 1, GP); 945 GvGP_set(sv, gp_ref(gp)); 946 #ifndef PERL_DONT_CREATE_GVSV 947 GvSV(sv) = newSV(0); 948 #endif 949 GvLINE(sv) = CopLINE(PL_curcop); 950 GvEGV(sv) = MUTABLE_GV(sv); 951 GvMULTI_on(sv); 952 953 if(stash) 954 mro_package_moved(NULL, stash, (const GV *)sv, 0); 955 stash = NULL; 956 /* undef *Foo::ISA */ 957 if( strEQ(GvNAME((const GV *)sv), "ISA") 958 && (stash = GvSTASH((const GV *)sv)) 959 && (method_changed || HvENAME(stash)) ) 960 mro_isa_changed_in(stash); 961 else if(method_changed) 962 mro_method_changed_in( 963 GvSTASH((const GV *)sv) 964 ); 965 966 break; 967 } 968 default: 969 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) { 970 SvPV_free(sv); 971 SvPV_set(sv, NULL); 972 SvLEN_set(sv, 0); 973 } 974 SvOK_off(sv); 975 SvSETMAGIC(sv); 976 } 977 978 SETs(&PL_sv_undef); 979 return NORMAL; 980 } 981 982 983 /* common "slow" code for pp_postinc and pp_postdec */ 984 985 static OP * 986 S_postincdec_common(pTHX_ SV *sv, SV *targ) 987 { 988 dSP; 989 const bool inc = 990 PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC; 991 992 if (SvROK(sv)) 993 TARG = sv_newmortal(); 994 sv_setsv(TARG, sv); 995 if (inc) 996 sv_inc_nomg(sv); 997 else 998 sv_dec_nomg(sv); 999 SvSETMAGIC(sv); 1000 /* special case for undef: see thread at 2003-03/msg00536.html in archive */ 1001 if (inc && !SvOK(TARG)) 1002 sv_setiv(TARG, 0); 1003 SETTARG; 1004 return NORMAL; 1005 } 1006 1007 1008 /* also used for: pp_i_postinc() */ 1009 1010 PP(pp_postinc) 1011 { 1012 dSP; dTARGET; 1013 SV *sv = TOPs; 1014 1015 /* special-case sv being a simple integer */ 1016 if (LIKELY(((sv->sv_flags & 1017 (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV| 1018 SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK)) 1019 == SVf_IOK)) 1020 && SvIVX(sv) != IV_MAX) 1021 { 1022 IV iv = SvIVX(sv); 1023 SvIV_set(sv, iv + 1); 1024 TARGi(iv, 0); /* arg not GMG, so can't be tainted */ 1025 SETs(TARG); 1026 return NORMAL; 1027 } 1028 1029 return S_postincdec_common(aTHX_ sv, TARG); 1030 } 1031 1032 1033 /* also used for: pp_i_postdec() */ 1034 1035 PP(pp_postdec) 1036 { 1037 dSP; dTARGET; 1038 SV *sv = TOPs; 1039 1040 /* special-case sv being a simple integer */ 1041 if (LIKELY(((sv->sv_flags & 1042 (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV| 1043 SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK)) 1044 == SVf_IOK)) 1045 && SvIVX(sv) != IV_MIN) 1046 { 1047 IV iv = SvIVX(sv); 1048 SvIV_set(sv, iv - 1); 1049 TARGi(iv, 0); /* arg not GMG, so can't be tainted */ 1050 SETs(TARG); 1051 return NORMAL; 1052 } 1053 1054 return S_postincdec_common(aTHX_ sv, TARG); 1055 } 1056 1057 1058 /* Ordinary operators. */ 1059 1060 PP(pp_pow) 1061 { 1062 dSP; dATARGET; SV *svl, *svr; 1063 #ifdef PERL_PRESERVE_IVUV 1064 bool is_int = 0; 1065 #endif 1066 tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric); 1067 svr = TOPs; 1068 svl = TOPm1s; 1069 #ifdef PERL_PRESERVE_IVUV 1070 /* For integer to integer power, we do the calculation by hand wherever 1071 we're sure it is safe; otherwise we call pow() and try to convert to 1072 integer afterwards. */ 1073 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) { 1074 UV power; 1075 bool baseuok; 1076 UV baseuv; 1077 1078 if (SvUOK(svr)) { 1079 power = SvUVX(svr); 1080 } else { 1081 const IV iv = SvIVX(svr); 1082 if (iv >= 0) { 1083 power = iv; 1084 } else { 1085 goto float_it; /* Can't do negative powers this way. */ 1086 } 1087 } 1088 1089 baseuok = SvUOK(svl); 1090 if (baseuok) { 1091 baseuv = SvUVX(svl); 1092 } else { 1093 const IV iv = SvIVX(svl); 1094 if (iv >= 0) { 1095 baseuv = iv; 1096 baseuok = TRUE; /* effectively it's a UV now */ 1097 } else { 1098 baseuv = -iv; /* abs, baseuok == false records sign */ 1099 } 1100 } 1101 /* now we have integer ** positive integer. */ 1102 is_int = 1; 1103 1104 /* foo & (foo - 1) is zero only for a power of 2. */ 1105 if (!(baseuv & (baseuv - 1))) { 1106 /* We are raising power-of-2 to a positive integer. 1107 The logic here will work for any base (even non-integer 1108 bases) but it can be less accurate than 1109 pow (base,power) or exp (power * log (base)) when the 1110 intermediate values start to spill out of the mantissa. 1111 With powers of 2 we know this can't happen. 1112 And powers of 2 are the favourite thing for perl 1113 programmers to notice ** not doing what they mean. */ 1114 NV result = 1.0; 1115 NV base = baseuok ? baseuv : -(NV)baseuv; 1116 1117 if (power & 1) { 1118 result *= base; 1119 } 1120 while (power >>= 1) { 1121 base *= base; 1122 if (power & 1) { 1123 result *= base; 1124 } 1125 } 1126 SP--; 1127 SETn( result ); 1128 SvIV_please_nomg(svr); 1129 RETURN; 1130 } else { 1131 unsigned int highbit = 8 * sizeof(UV); 1132 unsigned int diff = 8 * sizeof(UV); 1133 while (diff >>= 1) { 1134 highbit -= diff; 1135 if (baseuv >> highbit) { 1136 highbit += diff; 1137 } 1138 } 1139 /* we now have baseuv < 2 ** highbit */ 1140 if (power * highbit <= 8 * sizeof(UV)) { 1141 /* result will definitely fit in UV, so use UV math 1142 on same algorithm as above */ 1143 UV result = 1; 1144 UV base = baseuv; 1145 const bool odd_power = cBOOL(power & 1); 1146 if (odd_power) { 1147 result *= base; 1148 } 1149 while (power >>= 1) { 1150 base *= base; 1151 if (power & 1) { 1152 result *= base; 1153 } 1154 } 1155 SP--; 1156 if (baseuok || !odd_power) 1157 /* answer is positive */ 1158 SETu( result ); 1159 else if (result <= (UV)IV_MAX) 1160 /* answer negative, fits in IV */ 1161 SETi( -(IV)result ); 1162 else if (result == (UV)IV_MIN) 1163 /* 2's complement assumption: special case IV_MIN */ 1164 SETi( IV_MIN ); 1165 else 1166 /* answer negative, doesn't fit */ 1167 SETn( -(NV)result ); 1168 RETURN; 1169 } 1170 } 1171 } 1172 float_it: 1173 #endif 1174 { 1175 NV right = SvNV_nomg(svr); 1176 NV left = SvNV_nomg(svl); 1177 (void)POPs; 1178 1179 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG) 1180 /* 1181 We are building perl with long double support and are on an AIX OS 1182 afflicted with a powl() function that wrongly returns NaNQ for any 1183 negative base. This was reported to IBM as PMR #23047-379 on 1184 03/06/2006. The problem exists in at least the following versions 1185 of AIX and the libm fileset, and no doubt others as well: 1186 1187 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50 1188 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29 1189 AIX 5.2.0 bos.adt.libm 5.2.0.85 1190 1191 So, until IBM fixes powl(), we provide the following workaround to 1192 handle the problem ourselves. Our logic is as follows: for 1193 negative bases (left), we use fmod(right, 2) to check if the 1194 exponent is an odd or even integer: 1195 1196 - if odd, powl(left, right) == -powl(-left, right) 1197 - if even, powl(left, right) == powl(-left, right) 1198 1199 If the exponent is not an integer, the result is rightly NaNQ, so 1200 we just return that (as NV_NAN). 1201 */ 1202 1203 if (left < 0.0) { 1204 NV mod2 = Perl_fmod( right, 2.0 ); 1205 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */ 1206 SETn( -Perl_pow( -left, right) ); 1207 } else if (mod2 == 0.0) { /* even integer */ 1208 SETn( Perl_pow( -left, right) ); 1209 } else { /* fractional power */ 1210 SETn( NV_NAN ); 1211 } 1212 } else { 1213 SETn( Perl_pow( left, right) ); 1214 } 1215 #else 1216 SETn( Perl_pow( left, right) ); 1217 #endif /* HAS_AIX_POWL_NEG_BASE_BUG */ 1218 1219 #ifdef PERL_PRESERVE_IVUV 1220 if (is_int) 1221 SvIV_please_nomg(svr); 1222 #endif 1223 RETURN; 1224 } 1225 } 1226 1227 PP(pp_multiply) 1228 { 1229 dSP; dATARGET; SV *svl, *svr; 1230 tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric); 1231 svr = TOPs; 1232 svl = TOPm1s; 1233 1234 #ifdef PERL_PRESERVE_IVUV 1235 1236 /* special-case some simple common cases */ 1237 if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) { 1238 IV il, ir; 1239 U32 flags = (svl->sv_flags & svr->sv_flags); 1240 if (flags & SVf_IOK) { 1241 /* both args are simple IVs */ 1242 UV topl, topr; 1243 il = SvIVX(svl); 1244 ir = SvIVX(svr); 1245 do_iv: 1246 topl = ((UV)il) >> (UVSIZE * 4 - 1); 1247 topr = ((UV)ir) >> (UVSIZE * 4 - 1); 1248 1249 /* if both are in a range that can't under/overflow, do a 1250 * simple integer multiply: if the top halves(*) of both numbers 1251 * are 00...00 or 11...11, then it's safe. 1252 * (*) for 32-bits, the "top half" is the top 17 bits, 1253 * for 64-bits, its 33 bits */ 1254 if (!( 1255 ((topl+1) | (topr+1)) 1256 & ( (((UV)1) << (UVSIZE * 4 + 1)) - 2) /* 11..110 */ 1257 )) { 1258 SP--; 1259 TARGi(il * ir, 0); /* args not GMG, so can't be tainted */ 1260 SETs(TARG); 1261 RETURN; 1262 } 1263 goto generic; 1264 } 1265 else if (flags & SVf_NOK) { 1266 /* both args are NVs */ 1267 NV nl = SvNVX(svl); 1268 NV nr = SvNVX(svr); 1269 NV result; 1270 1271 if ( 1272 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) 1273 !Perl_isnan(nl) && nl == (NV)(il = (IV)nl) 1274 && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr) 1275 #else 1276 nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr) 1277 #endif 1278 ) 1279 /* nothing was lost by converting to IVs */ 1280 goto do_iv; 1281 SP--; 1282 result = nl * nr; 1283 # if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16 1284 if (Perl_isinf(result)) { 1285 Zero((U8*)&result + 8, 8, U8); 1286 } 1287 # endif 1288 TARGn(result, 0); /* args not GMG, so can't be tainted */ 1289 SETs(TARG); 1290 RETURN; 1291 } 1292 } 1293 1294 generic: 1295 1296 if (SvIV_please_nomg(svr)) { 1297 /* Unless the left argument is integer in range we are going to have to 1298 use NV maths. Hence only attempt to coerce the right argument if 1299 we know the left is integer. */ 1300 /* Left operand is defined, so is it IV? */ 1301 if (SvIV_please_nomg(svl)) { 1302 bool auvok = SvUOK(svl); 1303 bool buvok = SvUOK(svr); 1304 const UV topmask = (~ (UV)0) << (4 * sizeof (UV)); 1305 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV))); 1306 UV alow; 1307 UV ahigh; 1308 UV blow; 1309 UV bhigh; 1310 1311 if (auvok) { 1312 alow = SvUVX(svl); 1313 } else { 1314 const IV aiv = SvIVX(svl); 1315 if (aiv >= 0) { 1316 alow = aiv; 1317 auvok = TRUE; /* effectively it's a UV now */ 1318 } else { 1319 /* abs, auvok == false records sign; Using 0- here and 1320 * later to silence bogus warning from MS VC */ 1321 alow = (UV) (0 - (UV) aiv); 1322 } 1323 } 1324 if (buvok) { 1325 blow = SvUVX(svr); 1326 } else { 1327 const IV biv = SvIVX(svr); 1328 if (biv >= 0) { 1329 blow = biv; 1330 buvok = TRUE; /* effectively it's a UV now */ 1331 } else { 1332 /* abs, buvok == false records sign */ 1333 blow = (UV) (0 - (UV) biv); 1334 } 1335 } 1336 1337 /* If this does sign extension on unsigned it's time for plan B */ 1338 ahigh = alow >> (4 * sizeof (UV)); 1339 alow &= botmask; 1340 bhigh = blow >> (4 * sizeof (UV)); 1341 blow &= botmask; 1342 if (ahigh && bhigh) { 1343 NOOP; 1344 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000 1345 which is overflow. Drop to NVs below. */ 1346 } else if (!ahigh && !bhigh) { 1347 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001 1348 so the unsigned multiply cannot overflow. */ 1349 const UV product = alow * blow; 1350 if (auvok == buvok) { 1351 /* -ve * -ve or +ve * +ve gives a +ve result. */ 1352 SP--; 1353 SETu( product ); 1354 RETURN; 1355 } else if (product <= (UV)IV_MIN) { 1356 /* 2s complement assumption that (UV)-IV_MIN is correct. */ 1357 /* -ve result, which could overflow an IV */ 1358 SP--; 1359 /* can't negate IV_MIN, but there are aren't two 1360 * integers such that !ahigh && !bhigh, where the 1361 * product equals 0x800....000 */ 1362 assert(product != (UV)IV_MIN); 1363 SETi( -(IV)product ); 1364 RETURN; 1365 } /* else drop to NVs below. */ 1366 } else { 1367 /* One operand is large, 1 small */ 1368 UV product_middle; 1369 if (bhigh) { 1370 /* swap the operands */ 1371 ahigh = bhigh; 1372 bhigh = blow; /* bhigh now the temp var for the swap */ 1373 blow = alow; 1374 alow = bhigh; 1375 } 1376 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow) 1377 multiplies can't overflow. shift can, add can, -ve can. */ 1378 product_middle = ahigh * blow; 1379 if (!(product_middle & topmask)) { 1380 /* OK, (ahigh * blow) won't lose bits when we shift it. */ 1381 UV product_low; 1382 product_middle <<= (4 * sizeof (UV)); 1383 product_low = alow * blow; 1384 1385 /* as for pp_add, UV + something mustn't get smaller. 1386 IIRC ANSI mandates this wrapping *behaviour* for 1387 unsigned whatever the actual representation*/ 1388 product_low += product_middle; 1389 if (product_low >= product_middle) { 1390 /* didn't overflow */ 1391 if (auvok == buvok) { 1392 /* -ve * -ve or +ve * +ve gives a +ve result. */ 1393 SP--; 1394 SETu( product_low ); 1395 RETURN; 1396 } else if (product_low <= (UV)IV_MIN) { 1397 /* 2s complement assumption again */ 1398 /* -ve result, which could overflow an IV */ 1399 SP--; 1400 SETi(product_low == (UV)IV_MIN 1401 ? IV_MIN : -(IV)product_low); 1402 RETURN; 1403 } /* else drop to NVs below. */ 1404 } 1405 } /* product_middle too large */ 1406 } /* ahigh && bhigh */ 1407 } /* SvIOK(svl) */ 1408 } /* SvIOK(svr) */ 1409 #endif 1410 { 1411 NV right = SvNV_nomg(svr); 1412 NV left = SvNV_nomg(svl); 1413 NV result = left * right; 1414 1415 (void)POPs; 1416 #if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16 1417 if (Perl_isinf(result)) { 1418 Zero((U8*)&result + 8, 8, U8); 1419 } 1420 #endif 1421 SETn(result); 1422 RETURN; 1423 } 1424 } 1425 1426 PP(pp_divide) 1427 { 1428 dSP; dATARGET; SV *svl, *svr; 1429 tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric); 1430 svr = TOPs; 1431 svl = TOPm1s; 1432 /* Only try to do UV divide first 1433 if ((SLOPPYDIVIDE is true) or 1434 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large 1435 to preserve)) 1436 The assumption is that it is better to use floating point divide 1437 whenever possible, only doing integer divide first if we can't be sure. 1438 If NV_PRESERVES_UV is true then we know at compile time that no UV 1439 can be too large to preserve, so don't need to compile the code to 1440 test the size of UVs. */ 1441 1442 #if defined(SLOPPYDIVIDE) || (defined(PERL_PRESERVE_IVUV) && !defined(NV_PRESERVES_UV)) 1443 # define PERL_TRY_UV_DIVIDE 1444 /* ensure that 20./5. == 4. */ 1445 #endif 1446 1447 #ifdef PERL_TRY_UV_DIVIDE 1448 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) { 1449 bool left_non_neg = SvUOK(svl); 1450 bool right_non_neg = SvUOK(svr); 1451 UV left; 1452 UV right; 1453 1454 if (right_non_neg) { 1455 right = SvUVX(svr); 1456 } 1457 else { 1458 const IV biv = SvIVX(svr); 1459 if (biv >= 0) { 1460 right = biv; 1461 right_non_neg = TRUE; /* effectively it's a UV now */ 1462 } 1463 else { 1464 right = -(UV)biv; 1465 } 1466 } 1467 /* historically undef()/0 gives a "Use of uninitialized value" 1468 warning before dieing, hence this test goes here. 1469 If it were immediately before the second SvIV_please, then 1470 DIE() would be invoked before left was even inspected, so 1471 no inspection would give no warning. */ 1472 if (right == 0) 1473 DIE(aTHX_ "Illegal division by zero"); 1474 1475 if (left_non_neg) { 1476 left = SvUVX(svl); 1477 } 1478 else { 1479 const IV aiv = SvIVX(svl); 1480 if (aiv >= 0) { 1481 left = aiv; 1482 left_non_neg = TRUE; /* effectively it's a UV now */ 1483 } 1484 else { 1485 left = -(UV)aiv; 1486 } 1487 } 1488 1489 if (left >= right 1490 #ifdef SLOPPYDIVIDE 1491 /* For sloppy divide we always attempt integer division. */ 1492 #else 1493 /* Otherwise we only attempt it if either or both operands 1494 would not be preserved by an NV. If both fit in NVs 1495 we fall through to the NV divide code below. However, 1496 as left >= right to ensure integer result here, we know that 1497 we can skip the test on the right operand - right big 1498 enough not to be preserved can't get here unless left is 1499 also too big. */ 1500 1501 && (left > ((UV)1 << NV_PRESERVES_UV_BITS)) 1502 #endif 1503 ) { 1504 /* Integer division can't overflow, but it can be imprecise. */ 1505 1506 /* Modern compilers optimize division followed by 1507 * modulo into a single div instruction */ 1508 const UV result = left / right; 1509 if (left % right == 0) { 1510 SP--; /* result is valid */ 1511 if (left_non_neg == right_non_neg) { 1512 /* signs identical, result is positive. */ 1513 SETu( result ); 1514 RETURN; 1515 } 1516 /* 2s complement assumption */ 1517 if (result <= (UV)IV_MIN) 1518 SETi(result == (UV)IV_MIN ? IV_MIN : -(IV)result); 1519 else { 1520 /* It's exact but too negative for IV. */ 1521 SETn( -(NV)result ); 1522 } 1523 RETURN; 1524 } /* tried integer divide but it was not an integer result */ 1525 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */ 1526 } /* one operand wasn't SvIOK */ 1527 #endif /* PERL_TRY_UV_DIVIDE */ 1528 { 1529 NV right = SvNV_nomg(svr); 1530 NV left = SvNV_nomg(svl); 1531 (void)POPs;(void)POPs; 1532 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) 1533 if (! Perl_isnan(right) && right == 0.0) 1534 #else 1535 if (right == 0.0) 1536 #endif 1537 DIE(aTHX_ "Illegal division by zero"); 1538 PUSHn( left / right ); 1539 RETURN; 1540 } 1541 } 1542 1543 PP(pp_modulo) 1544 { 1545 dSP; dATARGET; 1546 tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric); 1547 { 1548 UV left = 0; 1549 UV right = 0; 1550 bool left_neg = FALSE; 1551 bool right_neg = FALSE; 1552 bool use_double = FALSE; 1553 bool dright_valid = FALSE; 1554 NV dright = 0.0; 1555 NV dleft = 0.0; 1556 SV * const svr = TOPs; 1557 SV * const svl = TOPm1s; 1558 if (SvIV_please_nomg(svr)) { 1559 right_neg = !SvUOK(svr); 1560 if (!right_neg) { 1561 right = SvUVX(svr); 1562 } else { 1563 const IV biv = SvIVX(svr); 1564 if (biv >= 0) { 1565 right = biv; 1566 right_neg = FALSE; /* effectively it's a UV now */ 1567 } else { 1568 right = (UV) (0 - (UV) biv); 1569 } 1570 } 1571 } 1572 else { 1573 dright = SvNV_nomg(svr); 1574 right_neg = dright < 0; 1575 if (right_neg) 1576 dright = -dright; 1577 if (dright < UV_MAX_P1) { 1578 right = U_V(dright); 1579 dright_valid = TRUE; /* In case we need to use double below. */ 1580 } else { 1581 use_double = TRUE; 1582 } 1583 } 1584 1585 /* At this point use_double is only true if right is out of range for 1586 a UV. In range NV has been rounded down to nearest UV and 1587 use_double false. */ 1588 if (!use_double && SvIV_please_nomg(svl)) { 1589 left_neg = !SvUOK(svl); 1590 if (!left_neg) { 1591 left = SvUVX(svl); 1592 } else { 1593 const IV aiv = SvIVX(svl); 1594 if (aiv >= 0) { 1595 left = aiv; 1596 left_neg = FALSE; /* effectively it's a UV now */ 1597 } else { 1598 left = (UV) (0 - (UV) aiv); 1599 } 1600 } 1601 } 1602 else { 1603 dleft = SvNV_nomg(svl); 1604 left_neg = dleft < 0; 1605 if (left_neg) 1606 dleft = -dleft; 1607 1608 /* This should be exactly the 5.6 behaviour - if left and right are 1609 both in range for UV then use U_V() rather than floor. */ 1610 if (!use_double) { 1611 if (dleft < UV_MAX_P1) { 1612 /* right was in range, so is dleft, so use UVs not double. 1613 */ 1614 left = U_V(dleft); 1615 } 1616 /* left is out of range for UV, right was in range, so promote 1617 right (back) to double. */ 1618 else { 1619 /* The +0.5 is used in 5.6 even though it is not strictly 1620 consistent with the implicit +0 floor in the U_V() 1621 inside the #if 1. */ 1622 dleft = Perl_floor(dleft + 0.5); 1623 use_double = TRUE; 1624 if (dright_valid) 1625 dright = Perl_floor(dright + 0.5); 1626 else 1627 dright = right; 1628 } 1629 } 1630 } 1631 sp -= 2; 1632 if (use_double) { 1633 NV dans; 1634 1635 if (!dright) 1636 DIE(aTHX_ "Illegal modulus zero"); 1637 1638 dans = Perl_fmod(dleft, dright); 1639 if ((left_neg != right_neg) && dans) 1640 dans = dright - dans; 1641 if (right_neg) 1642 dans = -dans; 1643 sv_setnv(TARG, dans); 1644 } 1645 else { 1646 UV ans; 1647 1648 if (!right) 1649 DIE(aTHX_ "Illegal modulus zero"); 1650 1651 ans = left % right; 1652 if ((left_neg != right_neg) && ans) 1653 ans = right - ans; 1654 if (right_neg) { 1655 /* XXX may warn: unary minus operator applied to unsigned type */ 1656 /* could change -foo to be (~foo)+1 instead */ 1657 if (ans <= ~((UV)IV_MAX)+1) 1658 sv_setiv(TARG, ~ans+1); 1659 else 1660 sv_setnv(TARG, -(NV)ans); 1661 } 1662 else 1663 sv_setuv(TARG, ans); 1664 } 1665 PUSHTARG; 1666 RETURN; 1667 } 1668 } 1669 1670 PP(pp_repeat) 1671 { 1672 dSP; dATARGET; 1673 IV count; 1674 SV *sv; 1675 bool infnan = FALSE; 1676 const U8 gimme = GIMME_V; 1677 1678 if (gimme == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) { 1679 /* TODO: think of some way of doing list-repeat overloading ??? */ 1680 sv = POPs; 1681 SvGETMAGIC(sv); 1682 } 1683 else { 1684 if (UNLIKELY(PL_op->op_private & OPpREPEAT_DOLIST)) { 1685 /* The parser saw this as a list repeat, and there 1686 are probably several items on the stack. But we're 1687 in scalar/void context, and there's no pp_list to save us 1688 now. So drop the rest of the items -- robin@kitsite.com 1689 */ 1690 dMARK; 1691 if (MARK + 1 < SP) { 1692 MARK[1] = TOPm1s; 1693 MARK[2] = TOPs; 1694 } 1695 else { 1696 dTOPss; 1697 ASSUME(MARK + 1 == SP); 1698 MEXTEND(SP, 1); 1699 PUSHs(sv); 1700 MARK[1] = &PL_sv_undef; 1701 } 1702 SP = MARK + 2; 1703 } 1704 tryAMAGICbin_MG(repeat_amg, AMGf_assign); 1705 sv = POPs; 1706 } 1707 1708 if (SvIOKp(sv)) { 1709 if (SvUOK(sv)) { 1710 const UV uv = SvUV_nomg(sv); 1711 if (uv > IV_MAX) 1712 count = IV_MAX; /* The best we can do? */ 1713 else 1714 count = uv; 1715 } else { 1716 count = SvIV_nomg(sv); 1717 } 1718 } 1719 else if (SvNOKp(sv)) { 1720 const NV nv = SvNV_nomg(sv); 1721 infnan = Perl_isinfnan(nv); 1722 if (UNLIKELY(infnan)) { 1723 count = 0; 1724 } else { 1725 if (nv < 0.0) 1726 count = -1; /* An arbitrary negative integer */ 1727 else 1728 count = (IV)nv; 1729 } 1730 } 1731 else 1732 count = SvIV_nomg(sv); 1733 1734 if (infnan) { 1735 Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC), 1736 "Non-finite repeat count does nothing"); 1737 } else if (count < 0) { 1738 count = 0; 1739 Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC), 1740 "Negative repeat count does nothing"); 1741 } 1742 1743 if (gimme == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) { 1744 dMARK; 1745 const SSize_t items = SP - MARK; 1746 const U8 mod = PL_op->op_flags & OPf_MOD; 1747 1748 if (count > 1) { 1749 SSize_t max; 1750 1751 if ( items > SSize_t_MAX / count /* max would overflow */ 1752 /* repeatcpy would overflow */ 1753 || items > I32_MAX / (I32)sizeof(SV *) 1754 ) 1755 Perl_croak(aTHX_ "%s","Out of memory during list extend"); 1756 max = items * count; 1757 MEXTEND(MARK, max); 1758 1759 while (SP > MARK) { 1760 if (*SP) { 1761 if (mod && SvPADTMP(*SP)) { 1762 *SP = sv_mortalcopy(*SP); 1763 } 1764 SvTEMP_off((*SP)); 1765 } 1766 SP--; 1767 } 1768 MARK++; 1769 repeatcpy((char*)(MARK + items), (char*)MARK, 1770 items * sizeof(const SV *), count - 1); 1771 SP += max; 1772 } 1773 else if (count <= 0) 1774 SP = MARK; 1775 } 1776 else { /* Note: mark already snarfed by pp_list */ 1777 SV * const tmpstr = POPs; 1778 STRLEN len; 1779 bool isutf; 1780 1781 if (TARG != tmpstr) 1782 sv_setsv_nomg(TARG, tmpstr); 1783 SvPV_force_nomg(TARG, len); 1784 isutf = DO_UTF8(TARG); 1785 if (count != 1) { 1786 if (count < 1) 1787 SvCUR_set(TARG, 0); 1788 else { 1789 STRLEN max; 1790 1791 if ( len > (MEM_SIZE_MAX-1) / (UV)count /* max would overflow */ 1792 || len > (U32)I32_MAX /* repeatcpy would overflow */ 1793 ) 1794 Perl_croak(aTHX_ "%s", 1795 "Out of memory during string extend"); 1796 max = (UV)count * len + 1; 1797 SvGROW(TARG, max); 1798 1799 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1); 1800 SvCUR_set(TARG, SvCUR(TARG) * count); 1801 } 1802 *SvEND(TARG) = '\0'; 1803 } 1804 if (isutf) 1805 (void)SvPOK_only_UTF8(TARG); 1806 else 1807 (void)SvPOK_only(TARG); 1808 1809 PUSHTARG; 1810 } 1811 RETURN; 1812 } 1813 1814 PP(pp_subtract) 1815 { 1816 dSP; dATARGET; bool useleft; SV *svl, *svr; 1817 tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric); 1818 svr = TOPs; 1819 svl = TOPm1s; 1820 1821 #ifdef PERL_PRESERVE_IVUV 1822 1823 /* special-case some simple common cases */ 1824 if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) { 1825 IV il, ir; 1826 U32 flags = (svl->sv_flags & svr->sv_flags); 1827 if (flags & SVf_IOK) { 1828 /* both args are simple IVs */ 1829 UV topl, topr; 1830 il = SvIVX(svl); 1831 ir = SvIVX(svr); 1832 do_iv: 1833 topl = ((UV)il) >> (UVSIZE * 8 - 2); 1834 topr = ((UV)ir) >> (UVSIZE * 8 - 2); 1835 1836 /* if both are in a range that can't under/overflow, do a 1837 * simple integer subtract: if the top of both numbers 1838 * are 00 or 11, then it's safe */ 1839 if (!( ((topl+1) | (topr+1)) & 2)) { 1840 SP--; 1841 TARGi(il - ir, 0); /* args not GMG, so can't be tainted */ 1842 SETs(TARG); 1843 RETURN; 1844 } 1845 goto generic; 1846 } 1847 else if (flags & SVf_NOK) { 1848 /* both args are NVs */ 1849 NV nl = SvNVX(svl); 1850 NV nr = SvNVX(svr); 1851 1852 if ( 1853 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) 1854 !Perl_isnan(nl) && nl == (NV)(il = (IV)nl) 1855 && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr) 1856 #else 1857 nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr) 1858 #endif 1859 ) 1860 /* nothing was lost by converting to IVs */ 1861 goto do_iv; 1862 SP--; 1863 TARGn(nl - nr, 0); /* args not GMG, so can't be tainted */ 1864 SETs(TARG); 1865 RETURN; 1866 } 1867 } 1868 1869 generic: 1870 1871 useleft = USE_LEFT(svl); 1872 /* See comments in pp_add (in pp_hot.c) about Overflow, and how 1873 "bad things" happen if you rely on signed integers wrapping. */ 1874 if (SvIV_please_nomg(svr)) { 1875 /* Unless the left argument is integer in range we are going to have to 1876 use NV maths. Hence only attempt to coerce the right argument if 1877 we know the left is integer. */ 1878 UV auv = 0; 1879 bool auvok = FALSE; 1880 bool a_valid = 0; 1881 1882 if (!useleft) { 1883 auv = 0; 1884 a_valid = auvok = 1; 1885 /* left operand is undef, treat as zero. */ 1886 } else { 1887 /* Left operand is defined, so is it IV? */ 1888 if (SvIV_please_nomg(svl)) { 1889 if ((auvok = SvUOK(svl))) 1890 auv = SvUVX(svl); 1891 else { 1892 const IV aiv = SvIVX(svl); 1893 if (aiv >= 0) { 1894 auv = aiv; 1895 auvok = 1; /* Now acting as a sign flag. */ 1896 } else { 1897 auv = (UV) (0 - (UV) aiv); 1898 } 1899 } 1900 a_valid = 1; 1901 } 1902 } 1903 if (a_valid) { 1904 bool result_good = 0; 1905 UV result; 1906 UV buv; 1907 bool buvok = SvUOK(svr); 1908 1909 if (buvok) 1910 buv = SvUVX(svr); 1911 else { 1912 const IV biv = SvIVX(svr); 1913 if (biv >= 0) { 1914 buv = biv; 1915 buvok = 1; 1916 } else 1917 buv = (UV) (0 - (UV) biv); 1918 } 1919 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve, 1920 else "IV" now, independent of how it came in. 1921 if a, b represents positive, A, B negative, a maps to -A etc 1922 a - b => (a - b) 1923 A - b => -(a + b) 1924 a - B => (a + b) 1925 A - B => -(a - b) 1926 all UV maths. negate result if A negative. 1927 subtract if signs same, add if signs differ. */ 1928 1929 if (auvok ^ buvok) { 1930 /* Signs differ. */ 1931 result = auv + buv; 1932 if (result >= auv) 1933 result_good = 1; 1934 } else { 1935 /* Signs same */ 1936 if (auv >= buv) { 1937 result = auv - buv; 1938 /* Must get smaller */ 1939 if (result <= auv) 1940 result_good = 1; 1941 } else { 1942 result = buv - auv; 1943 if (result <= buv) { 1944 /* result really should be -(auv-buv). as its negation 1945 of true value, need to swap our result flag */ 1946 auvok = !auvok; 1947 result_good = 1; 1948 } 1949 } 1950 } 1951 if (result_good) { 1952 SP--; 1953 if (auvok) 1954 SETu( result ); 1955 else { 1956 /* Negate result */ 1957 if (result <= (UV)IV_MIN) 1958 SETi(result == (UV)IV_MIN 1959 ? IV_MIN : -(IV)result); 1960 else { 1961 /* result valid, but out of range for IV. */ 1962 SETn( -(NV)result ); 1963 } 1964 } 1965 RETURN; 1966 } /* Overflow, drop through to NVs. */ 1967 } 1968 } 1969 #else 1970 useleft = USE_LEFT(svl); 1971 #endif 1972 { 1973 NV value = SvNV_nomg(svr); 1974 (void)POPs; 1975 1976 if (!useleft) { 1977 /* left operand is undef, treat as zero - value */ 1978 SETn(-value); 1979 RETURN; 1980 } 1981 SETn( SvNV_nomg(svl) - value ); 1982 RETURN; 1983 } 1984 } 1985 1986 #define IV_BITS (IVSIZE * 8) 1987 1988 static UV S_uv_shift(UV uv, int shift, bool left) 1989 { 1990 if (shift < 0) { 1991 shift = -shift; 1992 left = !left; 1993 } 1994 if (shift >= IV_BITS) { 1995 return 0; 1996 } 1997 return left ? uv << shift : uv >> shift; 1998 } 1999 2000 static IV S_iv_shift(IV iv, int shift, bool left) 2001 { 2002 if (shift < 0) { 2003 shift = -shift; 2004 left = !left; 2005 } 2006 if (shift >= IV_BITS) { 2007 return iv < 0 && !left ? -1 : 0; 2008 } 2009 return left ? iv << shift : iv >> shift; 2010 } 2011 2012 #define UV_LEFT_SHIFT(uv, shift) S_uv_shift(uv, shift, TRUE) 2013 #define UV_RIGHT_SHIFT(uv, shift) S_uv_shift(uv, shift, FALSE) 2014 #define IV_LEFT_SHIFT(iv, shift) S_iv_shift(iv, shift, TRUE) 2015 #define IV_RIGHT_SHIFT(iv, shift) S_iv_shift(iv, shift, FALSE) 2016 2017 PP(pp_left_shift) 2018 { 2019 dSP; dATARGET; SV *svl, *svr; 2020 tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric); 2021 svr = POPs; 2022 svl = TOPs; 2023 { 2024 const IV shift = SvIV_nomg(svr); 2025 if (PL_op->op_private & HINT_INTEGER) { 2026 SETi(IV_LEFT_SHIFT(SvIV_nomg(svl), shift)); 2027 } 2028 else { 2029 SETu(UV_LEFT_SHIFT(SvUV_nomg(svl), shift)); 2030 } 2031 RETURN; 2032 } 2033 } 2034 2035 PP(pp_right_shift) 2036 { 2037 dSP; dATARGET; SV *svl, *svr; 2038 tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric); 2039 svr = POPs; 2040 svl = TOPs; 2041 { 2042 const IV shift = SvIV_nomg(svr); 2043 if (PL_op->op_private & HINT_INTEGER) { 2044 SETi(IV_RIGHT_SHIFT(SvIV_nomg(svl), shift)); 2045 } 2046 else { 2047 SETu(UV_RIGHT_SHIFT(SvUV_nomg(svl), shift)); 2048 } 2049 RETURN; 2050 } 2051 } 2052 2053 PP(pp_lt) 2054 { 2055 dSP; 2056 SV *left, *right; 2057 2058 tryAMAGICbin_MG(lt_amg, AMGf_numeric); 2059 right = POPs; 2060 left = TOPs; 2061 SETs(boolSV( 2062 (SvIOK_notUV(left) && SvIOK_notUV(right)) 2063 ? (SvIVX(left) < SvIVX(right)) 2064 : (do_ncmp(left, right) == -1) 2065 )); 2066 RETURN; 2067 } 2068 2069 PP(pp_gt) 2070 { 2071 dSP; 2072 SV *left, *right; 2073 2074 tryAMAGICbin_MG(gt_amg, AMGf_numeric); 2075 right = POPs; 2076 left = TOPs; 2077 SETs(boolSV( 2078 (SvIOK_notUV(left) && SvIOK_notUV(right)) 2079 ? (SvIVX(left) > SvIVX(right)) 2080 : (do_ncmp(left, right) == 1) 2081 )); 2082 RETURN; 2083 } 2084 2085 PP(pp_le) 2086 { 2087 dSP; 2088 SV *left, *right; 2089 2090 tryAMAGICbin_MG(le_amg, AMGf_numeric); 2091 right = POPs; 2092 left = TOPs; 2093 SETs(boolSV( 2094 (SvIOK_notUV(left) && SvIOK_notUV(right)) 2095 ? (SvIVX(left) <= SvIVX(right)) 2096 : (do_ncmp(left, right) <= 0) 2097 )); 2098 RETURN; 2099 } 2100 2101 PP(pp_ge) 2102 { 2103 dSP; 2104 SV *left, *right; 2105 2106 tryAMAGICbin_MG(ge_amg, AMGf_numeric); 2107 right = POPs; 2108 left = TOPs; 2109 SETs(boolSV( 2110 (SvIOK_notUV(left) && SvIOK_notUV(right)) 2111 ? (SvIVX(left) >= SvIVX(right)) 2112 : ( (do_ncmp(left, right) & 2) == 0) 2113 )); 2114 RETURN; 2115 } 2116 2117 PP(pp_ne) 2118 { 2119 dSP; 2120 SV *left, *right; 2121 2122 tryAMAGICbin_MG(ne_amg, AMGf_numeric); 2123 right = POPs; 2124 left = TOPs; 2125 SETs(boolSV( 2126 (SvIOK_notUV(left) && SvIOK_notUV(right)) 2127 ? (SvIVX(left) != SvIVX(right)) 2128 : (do_ncmp(left, right) != 0) 2129 )); 2130 RETURN; 2131 } 2132 2133 /* compare left and right SVs. Returns: 2134 * -1: < 2135 * 0: == 2136 * 1: > 2137 * 2: left or right was a NaN 2138 */ 2139 I32 2140 Perl_do_ncmp(pTHX_ SV* const left, SV * const right) 2141 { 2142 PERL_ARGS_ASSERT_DO_NCMP; 2143 #ifdef PERL_PRESERVE_IVUV 2144 /* Fortunately it seems NaN isn't IOK */ 2145 if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) { 2146 if (!SvUOK(left)) { 2147 const IV leftiv = SvIVX(left); 2148 if (!SvUOK(right)) { 2149 /* ## IV <=> IV ## */ 2150 const IV rightiv = SvIVX(right); 2151 return (leftiv > rightiv) - (leftiv < rightiv); 2152 } 2153 /* ## IV <=> UV ## */ 2154 if (leftiv < 0) 2155 /* As (b) is a UV, it's >=0, so it must be < */ 2156 return -1; 2157 { 2158 const UV rightuv = SvUVX(right); 2159 return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv); 2160 } 2161 } 2162 2163 if (SvUOK(right)) { 2164 /* ## UV <=> UV ## */ 2165 const UV leftuv = SvUVX(left); 2166 const UV rightuv = SvUVX(right); 2167 return (leftuv > rightuv) - (leftuv < rightuv); 2168 } 2169 /* ## UV <=> IV ## */ 2170 { 2171 const IV rightiv = SvIVX(right); 2172 if (rightiv < 0) 2173 /* As (a) is a UV, it's >=0, so it cannot be < */ 2174 return 1; 2175 { 2176 const UV leftuv = SvUVX(left); 2177 return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv); 2178 } 2179 } 2180 NOT_REACHED; /* NOTREACHED */ 2181 } 2182 #endif 2183 { 2184 NV const rnv = SvNV_nomg(right); 2185 NV const lnv = SvNV_nomg(left); 2186 2187 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) 2188 if (Perl_isnan(lnv) || Perl_isnan(rnv)) { 2189 return 2; 2190 } 2191 return (lnv > rnv) - (lnv < rnv); 2192 #else 2193 if (lnv < rnv) 2194 return -1; 2195 if (lnv > rnv) 2196 return 1; 2197 if (lnv == rnv) 2198 return 0; 2199 return 2; 2200 #endif 2201 } 2202 } 2203 2204 2205 PP(pp_ncmp) 2206 { 2207 dSP; 2208 SV *left, *right; 2209 I32 value; 2210 tryAMAGICbin_MG(ncmp_amg, AMGf_numeric); 2211 right = POPs; 2212 left = TOPs; 2213 value = do_ncmp(left, right); 2214 if (value == 2) { 2215 SETs(&PL_sv_undef); 2216 } 2217 else { 2218 dTARGET; 2219 SETi(value); 2220 } 2221 RETURN; 2222 } 2223 2224 2225 /* also used for: pp_sge() pp_sgt() pp_slt() */ 2226 2227 PP(pp_sle) 2228 { 2229 dSP; 2230 2231 int amg_type = sle_amg; 2232 int multiplier = 1; 2233 int rhs = 1; 2234 2235 switch (PL_op->op_type) { 2236 case OP_SLT: 2237 amg_type = slt_amg; 2238 /* cmp < 0 */ 2239 rhs = 0; 2240 break; 2241 case OP_SGT: 2242 amg_type = sgt_amg; 2243 /* cmp > 0 */ 2244 multiplier = -1; 2245 rhs = 0; 2246 break; 2247 case OP_SGE: 2248 amg_type = sge_amg; 2249 /* cmp >= 0 */ 2250 multiplier = -1; 2251 break; 2252 } 2253 2254 tryAMAGICbin_MG(amg_type, 0); 2255 { 2256 dPOPTOPssrl; 2257 const int cmp = 2258 #ifdef USE_LOCALE_COLLATE 2259 (IN_LC_RUNTIME(LC_COLLATE)) 2260 ? sv_cmp_locale_flags(left, right, 0) 2261 : 2262 #endif 2263 sv_cmp_flags(left, right, 0); 2264 SETs(boolSV(cmp * multiplier < rhs)); 2265 RETURN; 2266 } 2267 } 2268 2269 PP(pp_seq) 2270 { 2271 dSP; 2272 tryAMAGICbin_MG(seq_amg, 0); 2273 { 2274 dPOPTOPssrl; 2275 SETs(boolSV(sv_eq_flags(left, right, 0))); 2276 RETURN; 2277 } 2278 } 2279 2280 PP(pp_sne) 2281 { 2282 dSP; 2283 tryAMAGICbin_MG(sne_amg, 0); 2284 { 2285 dPOPTOPssrl; 2286 SETs(boolSV(!sv_eq_flags(left, right, 0))); 2287 RETURN; 2288 } 2289 } 2290 2291 PP(pp_scmp) 2292 { 2293 dSP; dTARGET; 2294 tryAMAGICbin_MG(scmp_amg, 0); 2295 { 2296 dPOPTOPssrl; 2297 const int cmp = 2298 #ifdef USE_LOCALE_COLLATE 2299 (IN_LC_RUNTIME(LC_COLLATE)) 2300 ? sv_cmp_locale_flags(left, right, 0) 2301 : 2302 #endif 2303 sv_cmp_flags(left, right, 0); 2304 SETi( cmp ); 2305 RETURN; 2306 } 2307 } 2308 2309 PP(pp_bit_and) 2310 { 2311 dSP; dATARGET; 2312 tryAMAGICbin_MG(band_amg, AMGf_assign); 2313 { 2314 dPOPTOPssrl; 2315 if (SvNIOKp(left) || SvNIOKp(right)) { 2316 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left); 2317 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right); 2318 if (PL_op->op_private & HINT_INTEGER) { 2319 const IV i = SvIV_nomg(left) & SvIV_nomg(right); 2320 SETi(i); 2321 } 2322 else { 2323 const UV u = SvUV_nomg(left) & SvUV_nomg(right); 2324 SETu(u); 2325 } 2326 if (left_ro_nonnum && left != TARG) SvNIOK_off(left); 2327 if (right_ro_nonnum) SvNIOK_off(right); 2328 } 2329 else { 2330 do_vop(PL_op->op_type, TARG, left, right); 2331 SETTARG; 2332 } 2333 RETURN; 2334 } 2335 } 2336 2337 PP(pp_nbit_and) 2338 { 2339 dSP; 2340 tryAMAGICbin_MG(band_amg, AMGf_assign|AMGf_numarg); 2341 { 2342 dATARGET; dPOPTOPssrl; 2343 if (PL_op->op_private & HINT_INTEGER) { 2344 const IV i = SvIV_nomg(left) & SvIV_nomg(right); 2345 SETi(i); 2346 } 2347 else { 2348 const UV u = SvUV_nomg(left) & SvUV_nomg(right); 2349 SETu(u); 2350 } 2351 } 2352 RETURN; 2353 } 2354 2355 PP(pp_sbit_and) 2356 { 2357 dSP; 2358 tryAMAGICbin_MG(sband_amg, AMGf_assign); 2359 { 2360 dATARGET; dPOPTOPssrl; 2361 do_vop(OP_BIT_AND, TARG, left, right); 2362 RETSETTARG; 2363 } 2364 } 2365 2366 /* also used for: pp_bit_xor() */ 2367 2368 PP(pp_bit_or) 2369 { 2370 dSP; dATARGET; 2371 const int op_type = PL_op->op_type; 2372 2373 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign); 2374 { 2375 dPOPTOPssrl; 2376 if (SvNIOKp(left) || SvNIOKp(right)) { 2377 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left); 2378 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right); 2379 if (PL_op->op_private & HINT_INTEGER) { 2380 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0); 2381 const IV r = SvIV_nomg(right); 2382 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r); 2383 SETi(result); 2384 } 2385 else { 2386 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0); 2387 const UV r = SvUV_nomg(right); 2388 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r); 2389 SETu(result); 2390 } 2391 if (left_ro_nonnum && left != TARG) SvNIOK_off(left); 2392 if (right_ro_nonnum) SvNIOK_off(right); 2393 } 2394 else { 2395 do_vop(op_type, TARG, left, right); 2396 SETTARG; 2397 } 2398 RETURN; 2399 } 2400 } 2401 2402 /* also used for: pp_nbit_xor() */ 2403 2404 PP(pp_nbit_or) 2405 { 2406 dSP; 2407 const int op_type = PL_op->op_type; 2408 2409 tryAMAGICbin_MG((op_type == OP_NBIT_OR ? bor_amg : bxor_amg), 2410 AMGf_assign|AMGf_numarg); 2411 { 2412 dATARGET; dPOPTOPssrl; 2413 if (PL_op->op_private & HINT_INTEGER) { 2414 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0); 2415 const IV r = SvIV_nomg(right); 2416 const IV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r); 2417 SETi(result); 2418 } 2419 else { 2420 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0); 2421 const UV r = SvUV_nomg(right); 2422 const UV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r); 2423 SETu(result); 2424 } 2425 } 2426 RETURN; 2427 } 2428 2429 /* also used for: pp_sbit_xor() */ 2430 2431 PP(pp_sbit_or) 2432 { 2433 dSP; 2434 const int op_type = PL_op->op_type; 2435 2436 tryAMAGICbin_MG((op_type == OP_SBIT_OR ? sbor_amg : sbxor_amg), 2437 AMGf_assign); 2438 { 2439 dATARGET; dPOPTOPssrl; 2440 do_vop(op_type == OP_SBIT_OR ? OP_BIT_OR : OP_BIT_XOR, TARG, left, 2441 right); 2442 RETSETTARG; 2443 } 2444 } 2445 2446 PERL_STATIC_INLINE bool 2447 S_negate_string(pTHX) 2448 { 2449 dTARGET; dSP; 2450 STRLEN len; 2451 const char *s; 2452 SV * const sv = TOPs; 2453 if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv))) 2454 return FALSE; 2455 s = SvPV_nomg_const(sv, len); 2456 if (isIDFIRST(*s)) { 2457 sv_setpvs(TARG, "-"); 2458 sv_catsv(TARG, sv); 2459 } 2460 else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) { 2461 sv_setsv_nomg(TARG, sv); 2462 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-'; 2463 } 2464 else return FALSE; 2465 SETTARG; 2466 return TRUE; 2467 } 2468 2469 PP(pp_negate) 2470 { 2471 dSP; dTARGET; 2472 tryAMAGICun_MG(neg_amg, AMGf_numeric); 2473 if (S_negate_string(aTHX)) return NORMAL; 2474 { 2475 SV * const sv = TOPs; 2476 2477 if (SvIOK(sv)) { 2478 /* It's publicly an integer */ 2479 oops_its_an_int: 2480 if (SvIsUV(sv)) { 2481 if (SvIVX(sv) == IV_MIN) { 2482 /* 2s complement assumption. */ 2483 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == 2484 IV_MIN */ 2485 return NORMAL; 2486 } 2487 else if (SvUVX(sv) <= IV_MAX) { 2488 SETi(-SvIVX(sv)); 2489 return NORMAL; 2490 } 2491 } 2492 else if (SvIVX(sv) != IV_MIN) { 2493 SETi(-SvIVX(sv)); 2494 return NORMAL; 2495 } 2496 #ifdef PERL_PRESERVE_IVUV 2497 else { 2498 SETu((UV)IV_MIN); 2499 return NORMAL; 2500 } 2501 #endif 2502 } 2503 if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv))) 2504 SETn(-SvNV_nomg(sv)); 2505 else if (SvPOKp(sv) && SvIV_please_nomg(sv)) 2506 goto oops_its_an_int; 2507 else 2508 SETn(-SvNV_nomg(sv)); 2509 } 2510 return NORMAL; 2511 } 2512 2513 PP(pp_not) 2514 { 2515 dSP; 2516 SV *sv; 2517 2518 tryAMAGICun_MG(not_amg, 0); 2519 sv = *PL_stack_sp; 2520 *PL_stack_sp = boolSV(!SvTRUE_nomg_NN(sv)); 2521 return NORMAL; 2522 } 2523 2524 static void 2525 S_scomplement(pTHX_ SV *targ, SV *sv) 2526 { 2527 U8 *tmps; 2528 I32 anum; 2529 STRLEN len; 2530 2531 sv_copypv_nomg(TARG, sv); 2532 tmps = (U8*)SvPV_nomg(TARG, len); 2533 2534 if (SvUTF8(TARG)) { 2535 if (len && ! utf8_to_bytes(tmps, &len)) { 2536 Perl_croak(aTHX_ FATAL_ABOVE_FF_MSG, PL_op_desc[PL_op->op_type]); 2537 } 2538 SvCUR(TARG) = len; 2539 SvUTF8_off(TARG); 2540 } 2541 2542 anum = len; 2543 2544 #ifdef LIBERAL 2545 { 2546 long *tmpl; 2547 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++) 2548 *tmps = ~*tmps; 2549 tmpl = (long*)tmps; 2550 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++) 2551 *tmpl = ~*tmpl; 2552 tmps = (U8*)tmpl; 2553 } 2554 #endif 2555 for ( ; anum > 0; anum--, tmps++) 2556 *tmps = ~*tmps; 2557 } 2558 2559 PP(pp_complement) 2560 { 2561 dSP; dTARGET; 2562 tryAMAGICun_MG(compl_amg, AMGf_numeric); 2563 { 2564 dTOPss; 2565 if (SvNIOKp(sv)) { 2566 if (PL_op->op_private & HINT_INTEGER) { 2567 const IV i = ~SvIV_nomg(sv); 2568 SETi(i); 2569 } 2570 else { 2571 const UV u = ~SvUV_nomg(sv); 2572 SETu(u); 2573 } 2574 } 2575 else { 2576 S_scomplement(aTHX_ TARG, sv); 2577 SETTARG; 2578 } 2579 return NORMAL; 2580 } 2581 } 2582 2583 PP(pp_ncomplement) 2584 { 2585 dSP; 2586 tryAMAGICun_MG(compl_amg, AMGf_numeric|AMGf_numarg); 2587 { 2588 dTARGET; dTOPss; 2589 if (PL_op->op_private & HINT_INTEGER) { 2590 const IV i = ~SvIV_nomg(sv); 2591 SETi(i); 2592 } 2593 else { 2594 const UV u = ~SvUV_nomg(sv); 2595 SETu(u); 2596 } 2597 } 2598 return NORMAL; 2599 } 2600 2601 PP(pp_scomplement) 2602 { 2603 dSP; 2604 tryAMAGICun_MG(scompl_amg, AMGf_numeric); 2605 { 2606 dTARGET; dTOPss; 2607 S_scomplement(aTHX_ TARG, sv); 2608 SETTARG; 2609 return NORMAL; 2610 } 2611 } 2612 2613 /* integer versions of some of the above */ 2614 2615 PP(pp_i_multiply) 2616 { 2617 dSP; dATARGET; 2618 tryAMAGICbin_MG(mult_amg, AMGf_assign); 2619 { 2620 dPOPTOPiirl_nomg; 2621 SETi( left * right ); 2622 RETURN; 2623 } 2624 } 2625 2626 PP(pp_i_divide) 2627 { 2628 IV num; 2629 dSP; dATARGET; 2630 tryAMAGICbin_MG(div_amg, AMGf_assign); 2631 { 2632 dPOPTOPssrl; 2633 IV value = SvIV_nomg(right); 2634 if (value == 0) 2635 DIE(aTHX_ "Illegal division by zero"); 2636 num = SvIV_nomg(left); 2637 2638 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */ 2639 if (value == -1) 2640 value = - num; 2641 else 2642 value = num / value; 2643 SETi(value); 2644 RETURN; 2645 } 2646 } 2647 2648 PP(pp_i_modulo) 2649 { 2650 /* This is the vanilla old i_modulo. */ 2651 dSP; dATARGET; 2652 tryAMAGICbin_MG(modulo_amg, AMGf_assign); 2653 { 2654 dPOPTOPiirl_nomg; 2655 if (!right) 2656 DIE(aTHX_ "Illegal modulus zero"); 2657 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */ 2658 if (right == -1) 2659 SETi( 0 ); 2660 else 2661 SETi( left % right ); 2662 RETURN; 2663 } 2664 } 2665 2666 #if defined(__GLIBC__) && IVSIZE == 8 \ 2667 && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8)) 2668 2669 PP(pp_i_modulo_glibc_bugfix) 2670 { 2671 /* This is the i_modulo with the workaround for the _moddi3 bug 2672 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround). 2673 * See below for pp_i_modulo. */ 2674 dSP; dATARGET; 2675 tryAMAGICbin_MG(modulo_amg, AMGf_assign); 2676 { 2677 dPOPTOPiirl_nomg; 2678 if (!right) 2679 DIE(aTHX_ "Illegal modulus zero"); 2680 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */ 2681 if (right == -1) 2682 SETi( 0 ); 2683 else 2684 SETi( left % PERL_ABS(right) ); 2685 RETURN; 2686 } 2687 } 2688 #endif 2689 2690 PP(pp_i_add) 2691 { 2692 dSP; dATARGET; 2693 tryAMAGICbin_MG(add_amg, AMGf_assign); 2694 { 2695 dPOPTOPiirl_ul_nomg; 2696 SETi( left + right ); 2697 RETURN; 2698 } 2699 } 2700 2701 PP(pp_i_subtract) 2702 { 2703 dSP; dATARGET; 2704 tryAMAGICbin_MG(subtr_amg, AMGf_assign); 2705 { 2706 dPOPTOPiirl_ul_nomg; 2707 SETi( left - right ); 2708 RETURN; 2709 } 2710 } 2711 2712 PP(pp_i_lt) 2713 { 2714 dSP; 2715 tryAMAGICbin_MG(lt_amg, 0); 2716 { 2717 dPOPTOPiirl_nomg; 2718 SETs(boolSV(left < right)); 2719 RETURN; 2720 } 2721 } 2722 2723 PP(pp_i_gt) 2724 { 2725 dSP; 2726 tryAMAGICbin_MG(gt_amg, 0); 2727 { 2728 dPOPTOPiirl_nomg; 2729 SETs(boolSV(left > right)); 2730 RETURN; 2731 } 2732 } 2733 2734 PP(pp_i_le) 2735 { 2736 dSP; 2737 tryAMAGICbin_MG(le_amg, 0); 2738 { 2739 dPOPTOPiirl_nomg; 2740 SETs(boolSV(left <= right)); 2741 RETURN; 2742 } 2743 } 2744 2745 PP(pp_i_ge) 2746 { 2747 dSP; 2748 tryAMAGICbin_MG(ge_amg, 0); 2749 { 2750 dPOPTOPiirl_nomg; 2751 SETs(boolSV(left >= right)); 2752 RETURN; 2753 } 2754 } 2755 2756 PP(pp_i_eq) 2757 { 2758 dSP; 2759 tryAMAGICbin_MG(eq_amg, 0); 2760 { 2761 dPOPTOPiirl_nomg; 2762 SETs(boolSV(left == right)); 2763 RETURN; 2764 } 2765 } 2766 2767 PP(pp_i_ne) 2768 { 2769 dSP; 2770 tryAMAGICbin_MG(ne_amg, 0); 2771 { 2772 dPOPTOPiirl_nomg; 2773 SETs(boolSV(left != right)); 2774 RETURN; 2775 } 2776 } 2777 2778 PP(pp_i_ncmp) 2779 { 2780 dSP; dTARGET; 2781 tryAMAGICbin_MG(ncmp_amg, 0); 2782 { 2783 dPOPTOPiirl_nomg; 2784 I32 value; 2785 2786 if (left > right) 2787 value = 1; 2788 else if (left < right) 2789 value = -1; 2790 else 2791 value = 0; 2792 SETi(value); 2793 RETURN; 2794 } 2795 } 2796 2797 PP(pp_i_negate) 2798 { 2799 dSP; dTARGET; 2800 tryAMAGICun_MG(neg_amg, 0); 2801 if (S_negate_string(aTHX)) return NORMAL; 2802 { 2803 SV * const sv = TOPs; 2804 IV const i = SvIV_nomg(sv); 2805 SETi(-i); 2806 return NORMAL; 2807 } 2808 } 2809 2810 /* High falutin' math. */ 2811 2812 PP(pp_atan2) 2813 { 2814 dSP; dTARGET; 2815 tryAMAGICbin_MG(atan2_amg, 0); 2816 { 2817 dPOPTOPnnrl_nomg; 2818 SETn(Perl_atan2(left, right)); 2819 RETURN; 2820 } 2821 } 2822 2823 2824 /* also used for: pp_cos() pp_exp() pp_log() pp_sqrt() */ 2825 2826 PP(pp_sin) 2827 { 2828 dSP; dTARGET; 2829 int amg_type = fallback_amg; 2830 const char *neg_report = NULL; 2831 const int op_type = PL_op->op_type; 2832 2833 switch (op_type) { 2834 case OP_SIN: amg_type = sin_amg; break; 2835 case OP_COS: amg_type = cos_amg; break; 2836 case OP_EXP: amg_type = exp_amg; break; 2837 case OP_LOG: amg_type = log_amg; neg_report = "log"; break; 2838 case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break; 2839 } 2840 2841 assert(amg_type != fallback_amg); 2842 2843 tryAMAGICun_MG(amg_type, 0); 2844 { 2845 SV * const arg = TOPs; 2846 const NV value = SvNV_nomg(arg); 2847 #ifdef NV_NAN 2848 NV result = NV_NAN; 2849 #else 2850 NV result = 0.0; 2851 #endif 2852 if (neg_report) { /* log or sqrt */ 2853 if ( 2854 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) 2855 ! Perl_isnan(value) && 2856 #endif 2857 (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0))) { 2858 SET_NUMERIC_STANDARD(); 2859 /* diag_listed_as: Can't take log of %g */ 2860 DIE(aTHX_ "Can't take %s of %" NVgf, neg_report, value); 2861 } 2862 } 2863 switch (op_type) { 2864 default: 2865 case OP_SIN: result = Perl_sin(value); break; 2866 case OP_COS: result = Perl_cos(value); break; 2867 case OP_EXP: result = Perl_exp(value); break; 2868 case OP_LOG: result = Perl_log(value); break; 2869 case OP_SQRT: result = Perl_sqrt(value); break; 2870 } 2871 SETn(result); 2872 return NORMAL; 2873 } 2874 } 2875 2876 /* Support Configure command-line overrides for rand() functions. 2877 After 5.005, perhaps we should replace this by Configure support 2878 for drand48(), random(), or rand(). For 5.005, though, maintain 2879 compatibility by calling rand() but allow the user to override it. 2880 See INSTALL for details. --Andy Dougherty 15 July 1998 2881 */ 2882 /* Now it's after 5.005, and Configure supports drand48() and random(), 2883 in addition to rand(). So the overrides should not be needed any more. 2884 --Jarkko Hietaniemi 27 September 1998 2885 */ 2886 2887 PP(pp_rand) 2888 { 2889 if (!PL_srand_called) { 2890 (void)seedDrand01((Rand_seed_t)seed()); 2891 PL_srand_called = TRUE; 2892 } 2893 { 2894 dSP; 2895 NV value; 2896 2897 if (MAXARG < 1) 2898 { 2899 EXTEND(SP, 1); 2900 value = 1.0; 2901 } 2902 else { 2903 SV * const sv = POPs; 2904 if(!sv) 2905 value = 1.0; 2906 else 2907 value = SvNV(sv); 2908 } 2909 /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */ 2910 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) 2911 if (! Perl_isnan(value) && value == 0.0) 2912 #else 2913 if (value == 0.0) 2914 #endif 2915 value = 1.0; 2916 { 2917 dTARGET; 2918 PUSHs(TARG); 2919 PUTBACK; 2920 value *= Drand01(); 2921 sv_setnv_mg(TARG, value); 2922 } 2923 } 2924 return NORMAL; 2925 } 2926 2927 PP(pp_srand) 2928 { 2929 dSP; dTARGET; 2930 UV anum; 2931 2932 if (MAXARG >= 1 && (TOPs || POPs)) { 2933 SV *top; 2934 char *pv; 2935 STRLEN len; 2936 int flags; 2937 2938 top = POPs; 2939 pv = SvPV(top, len); 2940 flags = grok_number(pv, len, &anum); 2941 2942 if (!(flags & IS_NUMBER_IN_UV)) { 2943 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW), 2944 "Integer overflow in srand"); 2945 anum = UV_MAX; 2946 } 2947 (void)srand48_deterministic((Rand_seed_t)anum); 2948 } 2949 else { 2950 anum = seed(); 2951 (void)seedDrand01((Rand_seed_t)anum); 2952 } 2953 2954 PL_srand_called = TRUE; 2955 if (anum) 2956 XPUSHu(anum); 2957 else { 2958 /* Historically srand always returned true. We can avoid breaking 2959 that like this: */ 2960 sv_setpvs(TARG, "0 but true"); 2961 XPUSHTARG; 2962 } 2963 RETURN; 2964 } 2965 2966 PP(pp_int) 2967 { 2968 dSP; dTARGET; 2969 tryAMAGICun_MG(int_amg, AMGf_numeric); 2970 { 2971 SV * const sv = TOPs; 2972 const IV iv = SvIV_nomg(sv); 2973 /* XXX it's arguable that compiler casting to IV might be subtly 2974 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which 2975 else preferring IV has introduced a subtle behaviour change bug. OTOH 2976 relying on floating point to be accurate is a bug. */ 2977 2978 if (!SvOK(sv)) { 2979 SETu(0); 2980 } 2981 else if (SvIOK(sv)) { 2982 if (SvIsUV(sv)) 2983 SETu(SvUV_nomg(sv)); 2984 else 2985 SETi(iv); 2986 } 2987 else { 2988 const NV value = SvNV_nomg(sv); 2989 if (UNLIKELY(Perl_isinfnan(value))) 2990 SETn(value); 2991 else if (value >= 0.0) { 2992 if (value < (NV)UV_MAX + 0.5) { 2993 SETu(U_V(value)); 2994 } else { 2995 SETn(Perl_floor(value)); 2996 } 2997 } 2998 else { 2999 if (value > (NV)IV_MIN - 0.5) { 3000 SETi(I_V(value)); 3001 } else { 3002 SETn(Perl_ceil(value)); 3003 } 3004 } 3005 } 3006 } 3007 return NORMAL; 3008 } 3009 3010 PP(pp_abs) 3011 { 3012 dSP; dTARGET; 3013 tryAMAGICun_MG(abs_amg, AMGf_numeric); 3014 { 3015 SV * const sv = TOPs; 3016 /* This will cache the NV value if string isn't actually integer */ 3017 const IV iv = SvIV_nomg(sv); 3018 3019 if (!SvOK(sv)) { 3020 SETu(0); 3021 } 3022 else if (SvIOK(sv)) { 3023 /* IVX is precise */ 3024 if (SvIsUV(sv)) { 3025 SETu(SvUV_nomg(sv)); /* force it to be numeric only */ 3026 } else { 3027 if (iv >= 0) { 3028 SETi(iv); 3029 } else { 3030 if (iv != IV_MIN) { 3031 SETi(-iv); 3032 } else { 3033 /* 2s complement assumption. Also, not really needed as 3034 IV_MIN and -IV_MIN should both be %100...00 and NV-able */ 3035 SETu((UV)IV_MIN); 3036 } 3037 } 3038 } 3039 } else{ 3040 const NV value = SvNV_nomg(sv); 3041 if (value < 0.0) 3042 SETn(-value); 3043 else 3044 SETn(value); 3045 } 3046 } 3047 return NORMAL; 3048 } 3049 3050 3051 /* also used for: pp_hex() */ 3052 3053 PP(pp_oct) 3054 { 3055 dSP; dTARGET; 3056 const char *tmps; 3057 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES; 3058 STRLEN len; 3059 NV result_nv; 3060 UV result_uv; 3061 SV* const sv = TOPs; 3062 3063 tmps = (SvPV_const(sv, len)); 3064 if (DO_UTF8(sv)) { 3065 /* If Unicode, try to downgrade 3066 * If not possible, croak. */ 3067 SV* const tsv = sv_2mortal(newSVsv(sv)); 3068 3069 SvUTF8_on(tsv); 3070 sv_utf8_downgrade(tsv, FALSE); 3071 tmps = SvPV_const(tsv, len); 3072 } 3073 if (PL_op->op_type == OP_HEX) 3074 goto hex; 3075 3076 while (*tmps && len && isSPACE(*tmps)) 3077 tmps++, len--; 3078 if (*tmps == '0') 3079 tmps++, len--; 3080 if (isALPHA_FOLD_EQ(*tmps, 'x')) { 3081 hex: 3082 result_uv = grok_hex (tmps, &len, &flags, &result_nv); 3083 } 3084 else if (isALPHA_FOLD_EQ(*tmps, 'b')) 3085 result_uv = grok_bin (tmps, &len, &flags, &result_nv); 3086 else 3087 result_uv = grok_oct (tmps, &len, &flags, &result_nv); 3088 3089 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) { 3090 SETn(result_nv); 3091 } 3092 else { 3093 SETu(result_uv); 3094 } 3095 return NORMAL; 3096 } 3097 3098 /* String stuff. */ 3099 3100 3101 PP(pp_length) 3102 { 3103 dSP; dTARGET; 3104 SV * const sv = TOPs; 3105 3106 U32 in_bytes = IN_BYTES; 3107 /* Simplest case shortcut: 3108 * set svflags to just the SVf_POK|SVs_GMG|SVf_UTF8 from the SV, 3109 * with the SVf_UTF8 flag inverted if under 'use bytes' (HINT_BYTES 3110 * set) 3111 */ 3112 U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8); 3113 3114 STATIC_ASSERT_STMT(SVf_UTF8 == (HINT_BYTES << 26)); 3115 SETs(TARG); 3116 3117 if (LIKELY(svflags == SVf_POK)) 3118 goto simple_pv; 3119 3120 if (svflags & SVs_GMG) 3121 mg_get(sv); 3122 3123 if (SvOK(sv)) { 3124 STRLEN len; 3125 if (!IN_BYTES) { /* reread to avoid using an C auto/register */ 3126 if ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == SVf_POK) 3127 goto simple_pv; 3128 if ( SvPOK(sv) && (PL_op->op_private & OPpTRUEBOOL)) { 3129 /* no need to convert from bytes to chars */ 3130 len = SvCUR(sv); 3131 goto return_bool; 3132 } 3133 len = sv_len_utf8_nomg(sv); 3134 } 3135 else { 3136 /* unrolled SvPV_nomg_const(sv,len) */ 3137 if (SvPOK_nog(sv)) { 3138 simple_pv: 3139 len = SvCUR(sv); 3140 if (PL_op->op_private & OPpTRUEBOOL) { 3141 return_bool: 3142 SETs(len ? &PL_sv_yes : &PL_sv_zero); 3143 return NORMAL; 3144 } 3145 } 3146 else { 3147 (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN); 3148 } 3149 } 3150 TARGi((IV)(len), 1); 3151 } 3152 else { 3153 if (!SvPADTMP(TARG)) { 3154 /* OPpTARGET_MY: targ is var in '$lex = length()' */ 3155 sv_set_undef(TARG); 3156 SvSETMAGIC(TARG); 3157 } 3158 else 3159 /* TARG is on stack at this point and is overwriten by SETs. 3160 * This branch is the odd one out, so put TARG by default on 3161 * stack earlier to let local SP go out of liveness sooner */ 3162 SETs(&PL_sv_undef); 3163 } 3164 return NORMAL; /* no putback, SP didn't move in this opcode */ 3165 } 3166 3167 3168 /* Returns false if substring is completely outside original string. 3169 No length is indicated by len_iv = 0 and len_is_uv = 0. len_is_uv must 3170 always be true for an explicit 0. 3171 */ 3172 bool 3173 Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv, 3174 bool pos1_is_uv, IV len_iv, 3175 bool len_is_uv, STRLEN *posp, 3176 STRLEN *lenp) 3177 { 3178 IV pos2_iv; 3179 int pos2_is_uv; 3180 3181 PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS; 3182 3183 if (!pos1_is_uv && pos1_iv < 0 && curlen) { 3184 pos1_is_uv = curlen-1 > ~(UV)pos1_iv; 3185 pos1_iv += curlen; 3186 } 3187 if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen) 3188 return FALSE; 3189 3190 if (len_iv || len_is_uv) { 3191 if (!len_is_uv && len_iv < 0) { 3192 pos2_iv = curlen + len_iv; 3193 if (curlen) 3194 pos2_is_uv = curlen-1 > ~(UV)len_iv; 3195 else 3196 pos2_is_uv = 0; 3197 } else { /* len_iv >= 0 */ 3198 if (!pos1_is_uv && pos1_iv < 0) { 3199 pos2_iv = pos1_iv + len_iv; 3200 pos2_is_uv = (UV)len_iv > (UV)IV_MAX; 3201 } else { 3202 if ((UV)len_iv > curlen-(UV)pos1_iv) 3203 pos2_iv = curlen; 3204 else 3205 pos2_iv = pos1_iv+len_iv; 3206 pos2_is_uv = 1; 3207 } 3208 } 3209 } 3210 else { 3211 pos2_iv = curlen; 3212 pos2_is_uv = 1; 3213 } 3214 3215 if (!pos2_is_uv && pos2_iv < 0) { 3216 if (!pos1_is_uv && pos1_iv < 0) 3217 return FALSE; 3218 pos2_iv = 0; 3219 } 3220 else if (!pos1_is_uv && pos1_iv < 0) 3221 pos1_iv = 0; 3222 3223 if ((UV)pos2_iv < (UV)pos1_iv) 3224 pos2_iv = pos1_iv; 3225 if ((UV)pos2_iv > curlen) 3226 pos2_iv = curlen; 3227 3228 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */ 3229 *posp = (STRLEN)( (UV)pos1_iv ); 3230 *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv ); 3231 3232 return TRUE; 3233 } 3234 3235 PP(pp_substr) 3236 { 3237 dSP; dTARGET; 3238 SV *sv; 3239 STRLEN curlen; 3240 STRLEN utf8_curlen; 3241 SV * pos_sv; 3242 IV pos1_iv; 3243 int pos1_is_uv; 3244 SV * len_sv; 3245 IV len_iv = 0; 3246 int len_is_uv = 0; 3247 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET; 3248 const bool rvalue = (GIMME_V != G_VOID); 3249 const char *tmps; 3250 SV *repl_sv = NULL; 3251 const char *repl = NULL; 3252 STRLEN repl_len; 3253 int num_args = PL_op->op_private & 7; 3254 bool repl_need_utf8_upgrade = FALSE; 3255 3256 if (num_args > 2) { 3257 if (num_args > 3) { 3258 if(!(repl_sv = POPs)) num_args--; 3259 } 3260 if ((len_sv = POPs)) { 3261 len_iv = SvIV(len_sv); 3262 len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1; 3263 } 3264 else num_args--; 3265 } 3266 pos_sv = POPs; 3267 pos1_iv = SvIV(pos_sv); 3268 pos1_is_uv = SvIOK_UV(pos_sv); 3269 sv = POPs; 3270 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) { 3271 assert(!repl_sv); 3272 repl_sv = POPs; 3273 } 3274 if (lvalue && !repl_sv) { 3275 SV * ret; 3276 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */ 3277 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0); 3278 LvTYPE(ret) = 'x'; 3279 LvTARG(ret) = SvREFCNT_inc_simple(sv); 3280 LvTARGOFF(ret) = 3281 pos1_is_uv || pos1_iv >= 0 3282 ? (STRLEN)(UV)pos1_iv 3283 : (LvFLAGS(ret) |= LVf_NEG_OFF, (STRLEN)(UV)-pos1_iv); 3284 LvTARGLEN(ret) = 3285 len_is_uv || len_iv > 0 3286 ? (STRLEN)(UV)len_iv 3287 : (LvFLAGS(ret) |= LVf_NEG_LEN, (STRLEN)(UV)-len_iv); 3288 3289 PUSHs(ret); /* avoid SvSETMAGIC here */ 3290 RETURN; 3291 } 3292 if (repl_sv) { 3293 repl = SvPV_const(repl_sv, repl_len); 3294 SvGETMAGIC(sv); 3295 if (SvROK(sv)) 3296 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), 3297 "Attempt to use reference as lvalue in substr" 3298 ); 3299 tmps = SvPV_force_nomg(sv, curlen); 3300 if (DO_UTF8(repl_sv) && repl_len) { 3301 if (!DO_UTF8(sv)) { 3302 /* Upgrade the dest, and recalculate tmps in case the buffer 3303 * got reallocated; curlen may also have been changed */ 3304 sv_utf8_upgrade_nomg(sv); 3305 tmps = SvPV_nomg(sv, curlen); 3306 } 3307 } 3308 else if (DO_UTF8(sv)) 3309 repl_need_utf8_upgrade = TRUE; 3310 } 3311 else tmps = SvPV_const(sv, curlen); 3312 if (DO_UTF8(sv)) { 3313 utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen); 3314 if (utf8_curlen == curlen) 3315 utf8_curlen = 0; 3316 else 3317 curlen = utf8_curlen; 3318 } 3319 else 3320 utf8_curlen = 0; 3321 3322 { 3323 STRLEN pos, len, byte_len, byte_pos; 3324 3325 if (!translate_substr_offsets( 3326 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len 3327 )) goto bound_fail; 3328 3329 byte_len = len; 3330 byte_pos = utf8_curlen 3331 ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos; 3332 3333 tmps += byte_pos; 3334 3335 if (rvalue) { 3336 SvTAINTED_off(TARG); /* decontaminate */ 3337 SvUTF8_off(TARG); /* decontaminate */ 3338 sv_setpvn(TARG, tmps, byte_len); 3339 #ifdef USE_LOCALE_COLLATE 3340 sv_unmagic(TARG, PERL_MAGIC_collxfrm); 3341 #endif 3342 if (utf8_curlen) 3343 SvUTF8_on(TARG); 3344 } 3345 3346 if (repl) { 3347 SV* repl_sv_copy = NULL; 3348 3349 if (repl_need_utf8_upgrade) { 3350 repl_sv_copy = newSVsv(repl_sv); 3351 sv_utf8_upgrade(repl_sv_copy); 3352 repl = SvPV_const(repl_sv_copy, repl_len); 3353 } 3354 if (!SvOK(sv)) 3355 SvPVCLEAR(sv); 3356 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0); 3357 SvREFCNT_dec(repl_sv_copy); 3358 } 3359 } 3360 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) 3361 SP++; 3362 else if (rvalue) { 3363 SvSETMAGIC(TARG); 3364 PUSHs(TARG); 3365 } 3366 RETURN; 3367 3368 bound_fail: 3369 if (repl) 3370 Perl_croak(aTHX_ "substr outside of string"); 3371 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string"); 3372 RETPUSHUNDEF; 3373 } 3374 3375 PP(pp_vec) 3376 { 3377 dSP; 3378 const IV size = POPi; 3379 SV* offsetsv = POPs; 3380 SV * const src = POPs; 3381 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET; 3382 SV * ret; 3383 UV retuv; 3384 STRLEN offset = 0; 3385 char errflags = 0; 3386 3387 /* extract a STRLEN-ranged integer value from offsetsv into offset, 3388 * or flag that its out of range */ 3389 { 3390 IV iv = SvIV(offsetsv); 3391 3392 /* avoid a large UV being wrapped to a negative value */ 3393 if (SvIOK_UV(offsetsv) && SvUVX(offsetsv) > (UV)IV_MAX) 3394 errflags = LVf_OUT_OF_RANGE; 3395 else if (iv < 0) 3396 errflags = (LVf_NEG_OFF|LVf_OUT_OF_RANGE); 3397 #if PTRSIZE < IVSIZE 3398 else if (iv > Size_t_MAX) 3399 errflags = LVf_OUT_OF_RANGE; 3400 #endif 3401 else 3402 offset = (STRLEN)iv; 3403 } 3404 3405 retuv = errflags ? 0 : do_vecget(src, offset, size); 3406 3407 if (lvalue) { /* it's an lvalue! */ 3408 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */ 3409 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0); 3410 LvTYPE(ret) = 'v'; 3411 LvTARG(ret) = SvREFCNT_inc_simple(src); 3412 LvTARGOFF(ret) = offset; 3413 LvTARGLEN(ret) = size; 3414 LvFLAGS(ret) = errflags; 3415 } 3416 else { 3417 dTARGET; 3418 SvTAINTED_off(TARG); /* decontaminate */ 3419 ret = TARG; 3420 } 3421 3422 sv_setuv(ret, retuv); 3423 if (!lvalue) 3424 SvSETMAGIC(ret); 3425 PUSHs(ret); 3426 RETURN; 3427 } 3428 3429 3430 /* also used for: pp_rindex() */ 3431 3432 PP(pp_index) 3433 { 3434 dSP; dTARGET; 3435 SV *big; 3436 SV *little; 3437 SV *temp = NULL; 3438 STRLEN biglen; 3439 STRLEN llen = 0; 3440 SSize_t offset = 0; 3441 SSize_t retval; 3442 const char *big_p; 3443 const char *little_p; 3444 bool big_utf8; 3445 bool little_utf8; 3446 const bool is_index = PL_op->op_type == OP_INDEX; 3447 const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0)); 3448 3449 if (threeargs) 3450 offset = POPi; 3451 little = POPs; 3452 big = POPs; 3453 big_p = SvPV_const(big, biglen); 3454 little_p = SvPV_const(little, llen); 3455 3456 big_utf8 = DO_UTF8(big); 3457 little_utf8 = DO_UTF8(little); 3458 if (big_utf8 ^ little_utf8) { 3459 /* One needs to be upgraded. */ 3460 if (little_utf8) { 3461 /* Well, maybe instead we might be able to downgrade the small 3462 string? */ 3463 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen, 3464 &little_utf8); 3465 if (little_utf8) { 3466 /* If the large string is ISO-8859-1, and it's not possible to 3467 convert the small string to ISO-8859-1, then there is no 3468 way that it could be found anywhere by index. */ 3469 retval = -1; 3470 goto push_result; 3471 } 3472 3473 /* At this point, pv is a malloc()ed string. So donate it to temp 3474 to ensure it will get free()d */ 3475 little = temp = newSV(0); 3476 sv_usepvn(temp, pv, llen); 3477 little_p = SvPVX(little); 3478 } else { 3479 temp = newSVpvn(little_p, llen); 3480 3481 sv_utf8_upgrade(temp); 3482 little = temp; 3483 little_p = SvPV_const(little, llen); 3484 } 3485 } 3486 if (SvGAMAGIC(big)) { 3487 /* Life just becomes a lot easier if I use a temporary here. 3488 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously) 3489 will trigger magic and overloading again, as will fbm_instr() 3490 */ 3491 big = newSVpvn_flags(big_p, biglen, 3492 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0)); 3493 big_p = SvPVX(big); 3494 } 3495 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) { 3496 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will 3497 warn on undef, and we've already triggered a warning with the 3498 SvPV_const some lines above. We can't remove that, as we need to 3499 call some SvPV to trigger overloading early and find out if the 3500 string is UTF-8. 3501 This is all getting too messy. The API isn't quite clean enough, 3502 because data access has side effects. 3503 */ 3504 little = newSVpvn_flags(little_p, llen, 3505 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0)); 3506 little_p = SvPVX(little); 3507 } 3508 3509 if (!threeargs) 3510 offset = is_index ? 0 : biglen; 3511 else { 3512 if (big_utf8 && offset > 0) 3513 offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN); 3514 if (!is_index) 3515 offset += llen; 3516 } 3517 if (offset < 0) 3518 offset = 0; 3519 else if (offset > (SSize_t)biglen) 3520 offset = biglen; 3521 if (!(little_p = is_index 3522 ? fbm_instr((unsigned char*)big_p + offset, 3523 (unsigned char*)big_p + biglen, little, 0) 3524 : rninstr(big_p, big_p + offset, 3525 little_p, little_p + llen))) 3526 retval = -1; 3527 else { 3528 retval = little_p - big_p; 3529 if (retval > 1 && big_utf8) 3530 retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN); 3531 } 3532 SvREFCNT_dec(temp); 3533 3534 push_result: 3535 /* OPpTRUEBOOL indicates an '== -1' has been optimised away */ 3536 if (PL_op->op_private & OPpTRUEBOOL) { 3537 PUSHs( ((retval != -1) ^ cBOOL(PL_op->op_private & OPpINDEX_BOOLNEG)) 3538 ? &PL_sv_yes : &PL_sv_no); 3539 if (PL_op->op_private & OPpTARGET_MY) 3540 /* $lex = (index() == -1) */ 3541 sv_setsv(TARG, TOPs); 3542 } 3543 else 3544 PUSHi(retval); 3545 RETURN; 3546 } 3547 3548 PP(pp_sprintf) 3549 { 3550 dSP; dMARK; dORIGMARK; dTARGET; 3551 SvTAINTED_off(TARG); 3552 do_sprintf(TARG, SP-MARK, MARK+1); 3553 TAINT_IF(SvTAINTED(TARG)); 3554 SP = ORIGMARK; 3555 PUSHTARG; 3556 RETURN; 3557 } 3558 3559 PP(pp_ord) 3560 { 3561 dSP; dTARGET; 3562 3563 SV *argsv = TOPs; 3564 STRLEN len; 3565 const U8 *s = (U8*)SvPV_const(argsv, len); 3566 3567 SETu(DO_UTF8(argsv) 3568 ? (len ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV) : 0) 3569 : (UV)(*s)); 3570 3571 return NORMAL; 3572 } 3573 3574 PP(pp_chr) 3575 { 3576 dSP; dTARGET; 3577 char *tmps; 3578 UV value; 3579 SV *top = TOPs; 3580 3581 SvGETMAGIC(top); 3582 if (UNLIKELY(SvAMAGIC(top))) 3583 top = sv_2num(top); 3584 if (UNLIKELY(isinfnansv(top))) 3585 Perl_croak(aTHX_ "Cannot chr %" NVgf, SvNV(top)); 3586 else { 3587 if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */ 3588 && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0) 3589 || 3590 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top))) 3591 && SvNV_nomg(top) < 0.0))) 3592 { 3593 if (ckWARN(WARN_UTF8)) { 3594 if (SvGMAGICAL(top)) { 3595 SV *top2 = sv_newmortal(); 3596 sv_setsv_nomg(top2, top); 3597 top = top2; 3598 } 3599 Perl_warner(aTHX_ packWARN(WARN_UTF8), 3600 "Invalid negative number (%" SVf ") in chr", SVfARG(top)); 3601 } 3602 value = UNICODE_REPLACEMENT; 3603 } else { 3604 value = SvUV_nomg(top); 3605 } 3606 } 3607 3608 SvUPGRADE(TARG,SVt_PV); 3609 3610 if (value > 255 && !IN_BYTES) { 3611 SvGROW(TARG, (STRLEN)UVCHR_SKIP(value)+1); 3612 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0); 3613 SvCUR_set(TARG, tmps - SvPVX_const(TARG)); 3614 *tmps = '\0'; 3615 (void)SvPOK_only(TARG); 3616 SvUTF8_on(TARG); 3617 SETTARG; 3618 return NORMAL; 3619 } 3620 3621 SvGROW(TARG,2); 3622 SvCUR_set(TARG, 1); 3623 tmps = SvPVX(TARG); 3624 *tmps++ = (char)value; 3625 *tmps = '\0'; 3626 (void)SvPOK_only(TARG); 3627 3628 SETTARG; 3629 return NORMAL; 3630 } 3631 3632 PP(pp_crypt) 3633 { 3634 #ifdef HAS_CRYPT 3635 dSP; dTARGET; 3636 dPOPTOPssrl; 3637 STRLEN len; 3638 const char *tmps = SvPV_const(left, len); 3639 3640 if (DO_UTF8(left)) { 3641 /* If Unicode, try to downgrade. 3642 * If not possible, croak. 3643 * Yes, we made this up. */ 3644 SV* const tsv = newSVpvn_flags(tmps, len, SVf_UTF8|SVs_TEMP); 3645 3646 sv_utf8_downgrade(tsv, FALSE); 3647 tmps = SvPV_const(tsv, len); 3648 } 3649 # ifdef USE_ITHREADS 3650 # ifdef HAS_CRYPT_R 3651 if (!PL_reentrant_buffer->_crypt_struct_buffer) { 3652 /* This should be threadsafe because in ithreads there is only 3653 * one thread per interpreter. If this would not be true, 3654 * we would need a mutex to protect this malloc. */ 3655 PL_reentrant_buffer->_crypt_struct_buffer = 3656 (struct crypt_data *)safemalloc(sizeof(struct crypt_data)); 3657 #if defined(__GLIBC__) || defined(__EMX__) 3658 if (PL_reentrant_buffer->_crypt_struct_buffer) { 3659 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0; 3660 #if (defined(__GLIBC__) && __GLIBC__ == 2) && \ 3661 (defined(__GLIBC_MINOR__) && __GLIBC_MINOR__ >= 2 && __GLIBC_MINOR__ < 4) 3662 /* work around glibc-2.2.5 bug, has been fixed at some 3663 * time in glibc-2.3.X */ 3664 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0; 3665 #endif 3666 } 3667 #endif 3668 } 3669 # endif /* HAS_CRYPT_R */ 3670 # endif /* USE_ITHREADS */ 3671 # ifdef FCRYPT 3672 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right))); 3673 # else 3674 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right))); 3675 # endif 3676 SvUTF8_off(TARG); 3677 SETTARG; 3678 RETURN; 3679 #else 3680 DIE(aTHX_ 3681 "The crypt() function is unimplemented due to excessive paranoia."); 3682 #endif 3683 } 3684 3685 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So 3686 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */ 3687 3688 3689 /* also used for: pp_lcfirst() */ 3690 3691 PP(pp_ucfirst) 3692 { 3693 /* Actually is both lcfirst() and ucfirst(). Only the first character 3694 * changes. This means that possibly we can change in-place, ie., just 3695 * take the source and change that one character and store it back, but not 3696 * if read-only etc, or if the length changes */ 3697 3698 dSP; 3699 SV *source = TOPs; 3700 STRLEN slen; /* slen is the byte length of the whole SV. */ 3701 STRLEN need; 3702 SV *dest; 3703 bool inplace; /* ? Convert first char only, in-place */ 3704 bool doing_utf8 = FALSE; /* ? using utf8 */ 3705 bool convert_source_to_utf8 = FALSE; /* ? need to convert */ 3706 const int op_type = PL_op->op_type; 3707 const U8 *s; 3708 U8 *d; 3709 U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; 3710 STRLEN ulen; /* ulen is the byte length of the original Unicode character 3711 * stored as UTF-8 at s. */ 3712 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or 3713 * lowercased) character stored in tmpbuf. May be either 3714 * UTF-8 or not, but in either case is the number of bytes */ 3715 bool remove_dot_above = FALSE; 3716 3717 s = (const U8*)SvPV_const(source, slen); 3718 3719 /* We may be able to get away with changing only the first character, in 3720 * place, but not if read-only, etc. Later we may discover more reasons to 3721 * not convert in-place. */ 3722 inplace = !SvREADONLY(source) && SvPADTMP(source); 3723 3724 #ifdef USE_LOCALE_CTYPE 3725 3726 if (IN_LC_RUNTIME(LC_CTYPE)) { 3727 _CHECK_AND_WARN_PROBLEMATIC_LOCALE; 3728 } 3729 3730 #endif 3731 3732 /* First calculate what the changed first character should be. This affects 3733 * whether we can just swap it out, leaving the rest of the string unchanged, 3734 * or even if have to convert the dest to UTF-8 when the source isn't */ 3735 3736 if (! slen) { /* If empty */ 3737 need = 1; /* still need a trailing NUL */ 3738 ulen = 0; 3739 *tmpbuf = '\0'; 3740 } 3741 else if (DO_UTF8(source)) { /* Is the source utf8? */ 3742 doing_utf8 = TRUE; 3743 ulen = UTF8SKIP(s); 3744 if (op_type == OP_UCFIRST) { 3745 #ifdef USE_LOCALE_CTYPE 3746 _toTITLE_utf8_flags(s, s +slen, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE)); 3747 #else 3748 _toTITLE_utf8_flags(s, s +slen, tmpbuf, &tculen, 0); 3749 #endif 3750 } 3751 else { 3752 3753 #ifdef USE_LOCALE_CTYPE 3754 3755 _toLOWER_utf8_flags(s, s + slen, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE)); 3756 3757 /* In turkic locales, lower casing an 'I' normally yields U+0131, 3758 * LATIN SMALL LETTER DOTLESS I, but not if the grapheme also 3759 * contains a COMBINING DOT ABOVE. Instead it is treated like 3760 * LATIN CAPITAL LETTER I WITH DOT ABOVE lowercased to 'i'. The 3761 * call to lowercase above has handled this. But SpecialCasing.txt 3762 * says we are supposed to remove the COMBINING DOT ABOVE. We can 3763 * tell if we have this situation if I ==> i in a turkic locale. */ 3764 if ( UNLIKELY(PL_in_utf8_turkic_locale) 3765 && IN_LC_RUNTIME(LC_CTYPE) 3766 && (UNLIKELY(*s == 'I' && tmpbuf[0] == 'i'))) 3767 { 3768 /* Here, we know there was a COMBINING DOT ABOVE. We won't be 3769 * able to handle this in-place. */ 3770 inplace = FALSE; 3771 3772 /* It seems likely that the DOT will immediately follow the 3773 * 'I'. If so, we can remove it simply by indicating to the 3774 * code below to start copying the source just beyond the DOT. 3775 * We know its length is 2 */ 3776 if (LIKELY(memBEGINs(s + 1, s + slen, COMBINING_DOT_ABOVE_UTF8))) { 3777 ulen += 2; 3778 } 3779 else { /* But if it doesn't follow immediately, set a flag for 3780 the code below */ 3781 remove_dot_above = TRUE; 3782 } 3783 } 3784 #else 3785 PERL_UNUSED_VAR(remove_dot_above); 3786 3787 _toLOWER_utf8_flags(s, s + slen, tmpbuf, &tculen, 0); 3788 #endif 3789 3790 } 3791 3792 /* we can't do in-place if the length changes. */ 3793 if (ulen != tculen) inplace = FALSE; 3794 need = slen + 1 - ulen + tculen; 3795 } 3796 else { /* Non-zero length, non-UTF-8, Need to consider locale and if 3797 * latin1 is treated as caseless. Note that a locale takes 3798 * precedence */ 3799 ulen = 1; /* Original character is 1 byte */ 3800 tculen = 1; /* Most characters will require one byte, but this will 3801 * need to be overridden for the tricky ones */ 3802 need = slen + 1; 3803 3804 3805 #ifdef USE_LOCALE_CTYPE 3806 3807 if (IN_LC_RUNTIME(LC_CTYPE)) { 3808 if ( UNLIKELY(PL_in_utf8_turkic_locale) 3809 && ( (op_type == OP_LCFIRST && UNLIKELY(*s == 'I')) 3810 || (op_type == OP_UCFIRST && UNLIKELY(*s == 'i')))) 3811 { 3812 if (*s == 'I') { /* lcfirst('I') */ 3813 tmpbuf[0] = UTF8_TWO_BYTE_HI(LATIN_SMALL_LETTER_DOTLESS_I); 3814 tmpbuf[1] = UTF8_TWO_BYTE_LO(LATIN_SMALL_LETTER_DOTLESS_I); 3815 } 3816 else { /* ucfirst('i') */ 3817 tmpbuf[0] = UTF8_TWO_BYTE_HI(LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE); 3818 tmpbuf[1] = UTF8_TWO_BYTE_LO(LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE); 3819 } 3820 tculen = 2; 3821 inplace = FALSE; 3822 doing_utf8 = TRUE; 3823 convert_source_to_utf8 = TRUE; 3824 need += variant_under_utf8_count(s, s + slen); 3825 } 3826 else if (op_type == OP_LCFIRST) { 3827 3828 /* For lc, there are no gotchas for UTF-8 locales (other than 3829 * the turkish ones already handled above) */ 3830 *tmpbuf = toLOWER_LC(*s); 3831 } 3832 else { /* ucfirst */ 3833 3834 /* But for uc, some characters require special handling */ 3835 if (IN_UTF8_CTYPE_LOCALE) { 3836 goto do_uni_rules; 3837 } 3838 3839 /* This would be a bug if any locales have upper and title case 3840 * different */ 3841 *tmpbuf = (U8) toUPPER_LC(*s); 3842 } 3843 } 3844 else 3845 #endif 3846 /* Here, not in locale. If not using Unicode rules, is a simple 3847 * lower/upper, depending */ 3848 if (! IN_UNI_8_BIT) { 3849 *tmpbuf = (op_type == OP_LCFIRST) 3850 ? toLOWER(*s) 3851 : toUPPER(*s); 3852 } 3853 else if (op_type == OP_LCFIRST) { 3854 /* lower case the first letter: no trickiness for any character */ 3855 *tmpbuf = toLOWER_LATIN1(*s); 3856 } 3857 else { 3858 /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is 3859 * non-turkic UTF-8, which we treat as not in locale), and cased 3860 * latin1 */ 3861 UV title_ord; 3862 #ifdef USE_LOCALE_CTYPE 3863 do_uni_rules: 3864 #endif 3865 3866 title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's'); 3867 if (tculen > 1) { 3868 assert(tculen == 2); 3869 3870 /* If the result is an upper Latin1-range character, it can 3871 * still be represented in one byte, which is its ordinal */ 3872 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) { 3873 *tmpbuf = (U8) title_ord; 3874 tculen = 1; 3875 } 3876 else { 3877 /* Otherwise it became more than one ASCII character (in 3878 * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to 3879 * beyond Latin1, so the number of bytes changed, so can't 3880 * replace just the first character in place. */ 3881 inplace = FALSE; 3882 3883 /* If the result won't fit in a byte, the entire result 3884 * will have to be in UTF-8. Allocate enough space for the 3885 * expanded first byte, and if UTF-8, the rest of the input 3886 * string, some or all of which may also expand to two 3887 * bytes, plus the terminating NUL. */ 3888 if (title_ord > 255) { 3889 doing_utf8 = TRUE; 3890 convert_source_to_utf8 = TRUE; 3891 need = slen 3892 + variant_under_utf8_count(s, s + slen) 3893 + 1; 3894 3895 /* The (converted) UTF-8 and UTF-EBCDIC lengths of all 3896 * characters whose title case is above 255 is 3897 * 2. */ 3898 ulen = 2; 3899 } 3900 else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */ 3901 need = slen + 1 + 1; 3902 } 3903 } 3904 } 3905 } /* End of use Unicode (Latin1) semantics */ 3906 } /* End of changing the case of the first character */ 3907 3908 /* Here, have the first character's changed case stored in tmpbuf. Ready to 3909 * generate the result */ 3910 if (inplace) { 3911 3912 /* We can convert in place. This means we change just the first 3913 * character without disturbing the rest; no need to grow */ 3914 dest = source; 3915 s = d = (U8*)SvPV_force_nomg(source, slen); 3916 } else { 3917 dTARGET; 3918 3919 dest = TARG; 3920 3921 /* Here, we can't convert in place; we earlier calculated how much 3922 * space we will need, so grow to accommodate that */ 3923 SvUPGRADE(dest, SVt_PV); 3924 d = (U8*)SvGROW(dest, need); 3925 (void)SvPOK_only(dest); 3926 3927 SETs(dest); 3928 } 3929 3930 if (doing_utf8) { 3931 if (! inplace) { 3932 if (! convert_source_to_utf8) { 3933 3934 /* Here both source and dest are in UTF-8, but have to create 3935 * the entire output. We initialize the result to be the 3936 * title/lower cased first character, and then append the rest 3937 * of the string. */ 3938 sv_setpvn(dest, (char*)tmpbuf, tculen); 3939 if (slen > ulen) { 3940 3941 /* But this boolean being set means we are in a turkic 3942 * locale, and there is a DOT character that needs to be 3943 * removed, and it isn't immediately after the current 3944 * character. Keep concatenating characters to the output 3945 * one at a time, until we find the DOT, which we simply 3946 * skip */ 3947 if (UNLIKELY(remove_dot_above)) { 3948 do { 3949 Size_t this_len = UTF8SKIP(s + ulen); 3950 3951 sv_catpvn(dest, (char*)(s + ulen), this_len); 3952 3953 ulen += this_len; 3954 if (memBEGINs(s + ulen, s + slen, COMBINING_DOT_ABOVE_UTF8)) { 3955 ulen += 2; 3956 break; 3957 } 3958 } while (s + ulen < s + slen); 3959 } 3960 3961 /* The rest of the string can be concatenated unchanged, 3962 * all at once */ 3963 sv_catpvn(dest, (char*)(s + ulen), slen - ulen); 3964 } 3965 } 3966 else { 3967 const U8 *const send = s + slen; 3968 3969 /* Here the dest needs to be in UTF-8, but the source isn't, 3970 * except we earlier UTF-8'd the first character of the source 3971 * into tmpbuf. First put that into dest, and then append the 3972 * rest of the source, converting it to UTF-8 as we go. */ 3973 3974 /* Assert tculen is 2 here because the only characters that 3975 * get to this part of the code have 2-byte UTF-8 equivalents */ 3976 assert(tculen == 2); 3977 *d++ = *tmpbuf; 3978 *d++ = *(tmpbuf + 1); 3979 s++; /* We have just processed the 1st char */ 3980 3981 while (s < send) { 3982 append_utf8_from_native_byte(*s, &d); 3983 s++; 3984 } 3985 3986 *d = '\0'; 3987 SvCUR_set(dest, d - (U8*)SvPVX_const(dest)); 3988 } 3989 SvUTF8_on(dest); 3990 } 3991 else { /* in-place UTF-8. Just overwrite the first character */ 3992 Copy(tmpbuf, d, tculen, U8); 3993 SvCUR_set(dest, need - 1); 3994 } 3995 3996 } 3997 else { /* Neither source nor dest are, nor need to be UTF-8 */ 3998 if (slen) { 3999 if (inplace) { /* in-place, only need to change the 1st char */ 4000 *d = *tmpbuf; 4001 } 4002 else { /* Not in-place */ 4003 4004 /* Copy the case-changed character(s) from tmpbuf */ 4005 Copy(tmpbuf, d, tculen, U8); 4006 d += tculen - 1; /* Code below expects d to point to final 4007 * character stored */ 4008 } 4009 } 4010 else { /* empty source */ 4011 /* See bug #39028: Don't taint if empty */ 4012 *d = *s; 4013 } 4014 4015 /* In a "use bytes" we don't treat the source as UTF-8, but, still want 4016 * the destination to retain that flag */ 4017 if (DO_UTF8(source)) 4018 SvUTF8_on(dest); 4019 4020 if (!inplace) { /* Finish the rest of the string, unchanged */ 4021 /* This will copy the trailing NUL */ 4022 Copy(s + 1, d + 1, slen, U8); 4023 SvCUR_set(dest, need - 1); 4024 } 4025 } 4026 #ifdef USE_LOCALE_CTYPE 4027 if (IN_LC_RUNTIME(LC_CTYPE)) { 4028 TAINT; 4029 SvTAINTED_on(dest); 4030 } 4031 #endif 4032 if (dest != source && SvTAINTED(source)) 4033 SvTAINT(dest); 4034 SvSETMAGIC(dest); 4035 return NORMAL; 4036 } 4037 4038 PP(pp_uc) 4039 { 4040 dVAR; 4041 dSP; 4042 SV *source = TOPs; 4043 STRLEN len; 4044 STRLEN min; 4045 SV *dest; 4046 const U8 *s; 4047 U8 *d; 4048 4049 SvGETMAGIC(source); 4050 4051 if ( SvPADTMP(source) 4052 && !SvREADONLY(source) && SvPOK(source) 4053 && !DO_UTF8(source) 4054 && ( 4055 #ifdef USE_LOCALE_CTYPE 4056 (IN_LC_RUNTIME(LC_CTYPE)) 4057 ? ! IN_UTF8_CTYPE_LOCALE 4058 : 4059 #endif 4060 ! IN_UNI_8_BIT)) 4061 { 4062 4063 /* We can convert in place. The reason we can't if in UNI_8_BIT is to 4064 * make the loop tight, so we overwrite the source with the dest before 4065 * looking at it, and we need to look at the original source 4066 * afterwards. There would also need to be code added to handle 4067 * switching to not in-place in midstream if we run into characters 4068 * that change the length. Since being in locale overrides UNI_8_BIT, 4069 * that latter becomes irrelevant in the above test; instead for 4070 * locale, the size can't normally change, except if the locale is a 4071 * UTF-8 one */ 4072 dest = source; 4073 s = d = (U8*)SvPV_force_nomg(source, len); 4074 min = len + 1; 4075 } else { 4076 dTARGET; 4077 4078 dest = TARG; 4079 4080 s = (const U8*)SvPV_nomg_const(source, len); 4081 min = len + 1; 4082 4083 SvUPGRADE(dest, SVt_PV); 4084 d = (U8*)SvGROW(dest, min); 4085 (void)SvPOK_only(dest); 4086 4087 SETs(dest); 4088 } 4089 4090 #ifdef USE_LOCALE_CTYPE 4091 4092 if (IN_LC_RUNTIME(LC_CTYPE)) { 4093 _CHECK_AND_WARN_PROBLEMATIC_LOCALE; 4094 } 4095 4096 #endif 4097 4098 /* Overloaded values may have toggled the UTF-8 flag on source, so we need 4099 to check DO_UTF8 again here. */ 4100 4101 if (DO_UTF8(source)) { 4102 const U8 *const send = s + len; 4103 U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; 4104 4105 #define GREEK_CAPITAL_LETTER_IOTA 0x0399 4106 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345 4107 /* All occurrences of these are to be moved to follow any other marks. 4108 * This is context-dependent. We may not be passed enough context to 4109 * move the iota subscript beyond all of them, but we do the best we can 4110 * with what we're given. The result is always better than if we 4111 * hadn't done this. And, the problem would only arise if we are 4112 * passed a character without all its combining marks, which would be 4113 * the caller's mistake. The information this is based on comes from a 4114 * comment in Unicode SpecialCasing.txt, (and the Standard's text 4115 * itself) and so can't be checked properly to see if it ever gets 4116 * revised. But the likelihood of it changing is remote */ 4117 bool in_iota_subscript = FALSE; 4118 4119 while (s < send) { 4120 STRLEN u; 4121 STRLEN ulen; 4122 UV uv; 4123 if (UNLIKELY(in_iota_subscript)) { 4124 UV cp = utf8_to_uvchr_buf(s, send, NULL); 4125 4126 if (! _invlist_contains_cp(PL_utf8_mark, cp)) { 4127 4128 /* A non-mark. Time to output the iota subscript */ 4129 *d++ = UTF8_TWO_BYTE_HI(GREEK_CAPITAL_LETTER_IOTA); 4130 *d++ = UTF8_TWO_BYTE_LO(GREEK_CAPITAL_LETTER_IOTA); 4131 in_iota_subscript = FALSE; 4132 } 4133 } 4134 4135 /* Then handle the current character. Get the changed case value 4136 * and copy it to the output buffer */ 4137 4138 u = UTF8SKIP(s); 4139 #ifdef USE_LOCALE_CTYPE 4140 uv = _toUPPER_utf8_flags(s, send, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE)); 4141 #else 4142 uv = _toUPPER_utf8_flags(s, send, tmpbuf, &ulen, 0); 4143 #endif 4144 if (uv == GREEK_CAPITAL_LETTER_IOTA 4145 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI) 4146 { 4147 in_iota_subscript = TRUE; 4148 } 4149 else { 4150 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) { 4151 /* If the eventually required minimum size outgrows the 4152 * available space, we need to grow. */ 4153 const UV o = d - (U8*)SvPVX_const(dest); 4154 4155 /* If someone uppercases one million U+03B0s we SvGROW() 4156 * one million times. Or we could try guessing how much to 4157 * allocate without allocating too much. But we can't 4158 * really guess without examining the rest of the string. 4159 * Such is life. See corresponding comment in lc code for 4160 * another option */ 4161 d = o + (U8*) SvGROW(dest, min); 4162 } 4163 Copy(tmpbuf, d, ulen, U8); 4164 d += ulen; 4165 } 4166 s += u; 4167 } 4168 if (in_iota_subscript) { 4169 *d++ = UTF8_TWO_BYTE_HI(GREEK_CAPITAL_LETTER_IOTA); 4170 *d++ = UTF8_TWO_BYTE_LO(GREEK_CAPITAL_LETTER_IOTA); 4171 } 4172 SvUTF8_on(dest); 4173 *d = '\0'; 4174 4175 SvCUR_set(dest, d - (U8*)SvPVX_const(dest)); 4176 } 4177 else { /* Not UTF-8 */ 4178 if (len) { 4179 const U8 *const send = s + len; 4180 4181 /* Use locale casing if in locale; regular style if not treating 4182 * latin1 as having case; otherwise the latin1 casing. Do the 4183 * whole thing in a tight loop, for speed, */ 4184 #ifdef USE_LOCALE_CTYPE 4185 if (IN_LC_RUNTIME(LC_CTYPE)) { 4186 if (IN_UTF8_CTYPE_LOCALE) { 4187 goto do_uni_rules; 4188 } 4189 for (; s < send; d++, s++) 4190 *d = (U8) toUPPER_LC(*s); 4191 } 4192 else 4193 #endif 4194 if (! IN_UNI_8_BIT) { 4195 for (; s < send; d++, s++) { 4196 *d = toUPPER(*s); 4197 } 4198 } 4199 else { 4200 #ifdef USE_LOCALE_CTYPE 4201 do_uni_rules: 4202 #endif 4203 for (; s < send; d++, s++) { 4204 Size_t extra; 4205 4206 *d = toUPPER_LATIN1_MOD(*s); 4207 if ( LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) 4208 4209 #ifdef USE_LOCALE_CTYPE 4210 4211 && (LIKELY( ! PL_in_utf8_turkic_locale 4212 || ! IN_LC_RUNTIME(LC_CTYPE)) 4213 || *s != 'i') 4214 #endif 4215 4216 ) { 4217 continue; 4218 } 4219 4220 /* The mainstream case is the tight loop above. To avoid 4221 * extra tests in that, all three characters that always 4222 * require special handling are mapped by the MOD to the 4223 * one tested just above. Use the source to distinguish 4224 * between those cases */ 4225 4226 #if UNICODE_MAJOR_VERSION > 2 \ 4227 || (UNICODE_MAJOR_VERSION == 2 && UNICODE_DOT_VERSION >= 1 \ 4228 && UNICODE_DOT_DOT_VERSION >= 8) 4229 if (*s == LATIN_SMALL_LETTER_SHARP_S) { 4230 4231 /* uc() of this requires 2 characters, but they are 4232 * ASCII. If not enough room, grow the string */ 4233 if (SvLEN(dest) < ++min) { 4234 const UV o = d - (U8*)SvPVX_const(dest); 4235 d = o + (U8*) SvGROW(dest, min); 4236 } 4237 *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */ 4238 continue; /* Back to the tight loop; still in ASCII */ 4239 } 4240 #endif 4241 4242 /* The other special handling characters have their 4243 * upper cases outside the latin1 range, hence need to be 4244 * in UTF-8, so the whole result needs to be in UTF-8. 4245 * 4246 * So, here we are somewhere in the middle of processing a 4247 * non-UTF-8 string, and realize that we will have to 4248 * convert the whole thing to UTF-8. What to do? There 4249 * are several possibilities. The simplest to code is to 4250 * convert what we have so far, set a flag, and continue on 4251 * in the loop. The flag would be tested each time through 4252 * the loop, and if set, the next character would be 4253 * converted to UTF-8 and stored. But, I (khw) didn't want 4254 * to slow down the mainstream case at all for this fairly 4255 * rare case, so I didn't want to add a test that didn't 4256 * absolutely have to be there in the loop, besides the 4257 * possibility that it would get too complicated for 4258 * optimizers to deal with. Another possibility is to just 4259 * give up, convert the source to UTF-8, and restart the 4260 * function that way. Another possibility is to convert 4261 * both what has already been processed and what is yet to 4262 * come separately to UTF-8, then jump into the loop that 4263 * handles UTF-8. But the most efficient time-wise of the 4264 * ones I could think of is what follows, and turned out to 4265 * not require much extra code. 4266 * 4267 * First, calculate the extra space needed for the 4268 * remainder of the source needing to be in UTF-8. Except 4269 * for the 'i' in Turkic locales, in UTF-8 strings, the 4270 * uppercase of a character below 256 occupies the same 4271 * number of bytes as the original. Therefore, the space 4272 * needed is the that number plus the number of characters 4273 * that become two bytes when converted to UTF-8, plus, in 4274 * turkish locales, the number of 'i's. */ 4275 4276 extra = send - s + variant_under_utf8_count(s, send); 4277 4278 #ifdef USE_LOCALE_CTYPE 4279 4280 if (UNLIKELY(*s == 'i')) { /* We wouldn't get an 'i' here 4281 unless are in a Turkic 4282 locale */ 4283 const U8 * s_peek = s; 4284 4285 do { 4286 extra++; 4287 4288 s_peek = (U8 *) memchr(s_peek + 1, 'i', 4289 send - (s_peek + 1)); 4290 } while (s_peek != NULL); 4291 } 4292 #endif 4293 4294 /* Convert what we have so far into UTF-8, telling the 4295 * function that we know it should be converted, and to 4296 * allow extra space for what we haven't processed yet. 4297 * 4298 * This may cause the string pointer to move, so need to 4299 * save and re-find it. */ 4300 4301 len = d - (U8*)SvPVX_const(dest); 4302 SvCUR_set(dest, len); 4303 len = sv_utf8_upgrade_flags_grow(dest, 4304 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE, 4305 extra 4306 + 1 /* trailing NUL */ ); 4307 d = (U8*)SvPVX(dest) + len; 4308 4309 /* Now process the remainder of the source, simultaneously 4310 * converting to upper and UTF-8. 4311 * 4312 * To avoid extra tests in the loop body, and since the 4313 * loop is so simple, split out the rare Turkic case into 4314 * its own loop */ 4315 4316 #ifdef USE_LOCALE_CTYPE 4317 if ( UNLIKELY(PL_in_utf8_turkic_locale) 4318 && UNLIKELY(IN_LC_RUNTIME(LC_CTYPE))) 4319 { 4320 for (; s < send; s++) { 4321 if (*s == 'i') { 4322 *d++ = UTF8_TWO_BYTE_HI(LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE); 4323 *d++ = UTF8_TWO_BYTE_LO(LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE); 4324 } 4325 else { 4326 (void) _to_upper_title_latin1(*s, d, &len, 'S'); 4327 d += len; 4328 } 4329 } 4330 } 4331 else 4332 #endif 4333 for (; s < send; s++) { 4334 (void) _to_upper_title_latin1(*s, d, &len, 'S'); 4335 d += len; 4336 } 4337 4338 /* Here have processed the whole source; no need to 4339 * continue with the outer loop. Each character has been 4340 * converted to upper case and converted to UTF-8. */ 4341 break; 4342 } /* End of processing all latin1-style chars */ 4343 } /* End of processing all chars */ 4344 } /* End of source is not empty */ 4345 4346 if (source != dest) { 4347 *d = '\0'; /* Here d points to 1 after last char, add NUL */ 4348 SvCUR_set(dest, d - (U8*)SvPVX_const(dest)); 4349 } 4350 } /* End of isn't utf8 */ 4351 #ifdef USE_LOCALE_CTYPE 4352 if (IN_LC_RUNTIME(LC_CTYPE)) { 4353 TAINT; 4354 SvTAINTED_on(dest); 4355 } 4356 #endif 4357 if (dest != source && SvTAINTED(source)) 4358 SvTAINT(dest); 4359 SvSETMAGIC(dest); 4360 return NORMAL; 4361 } 4362 4363 PP(pp_lc) 4364 { 4365 dSP; 4366 SV *source = TOPs; 4367 STRLEN len; 4368 STRLEN min; 4369 SV *dest; 4370 const U8 *s; 4371 U8 *d; 4372 bool has_turkic_I = FALSE; 4373 4374 SvGETMAGIC(source); 4375 4376 if ( SvPADTMP(source) 4377 && !SvREADONLY(source) && SvPOK(source) 4378 && !DO_UTF8(source) 4379 4380 #ifdef USE_LOCALE_CTYPE 4381 4382 && ( LIKELY(! IN_LC_RUNTIME(LC_CTYPE)) 4383 || LIKELY(! PL_in_utf8_turkic_locale)) 4384 4385 #endif 4386 4387 ) { 4388 4389 /* We can convert in place, as, outside of Turkic UTF-8 locales, 4390 * lowercasing anything in the latin1 range (or else DO_UTF8 would have 4391 * been on) doesn't lengthen it. */ 4392 dest = source; 4393 s = d = (U8*)SvPV_force_nomg(source, len); 4394 min = len + 1; 4395 } else { 4396 dTARGET; 4397 4398 dest = TARG; 4399 4400 s = (const U8*)SvPV_nomg_const(source, len); 4401 min = len + 1; 4402 4403 SvUPGRADE(dest, SVt_PV); 4404 d = (U8*)SvGROW(dest, min); 4405 (void)SvPOK_only(dest); 4406 4407 SETs(dest); 4408 } 4409 4410 #ifdef USE_LOCALE_CTYPE 4411 4412 if (IN_LC_RUNTIME(LC_CTYPE)) { 4413 const U8 * next_I; 4414 4415 _CHECK_AND_WARN_PROBLEMATIC_LOCALE; 4416 4417 /* Lowercasing in a Turkic locale can cause non-UTF-8 to need to become 4418 * UTF-8 for the single case of the character 'I' */ 4419 if ( UNLIKELY(PL_in_utf8_turkic_locale) 4420 && ! DO_UTF8(source) 4421 && (next_I = (U8 *) memchr(s, 'I', len))) 4422 { 4423 Size_t I_count = 0; 4424 const U8 *const send = s + len; 4425 4426 do { 4427 I_count++; 4428 4429 next_I = (U8 *) memchr(next_I + 1, 'I', 4430 send - (next_I + 1)); 4431 } while (next_I != NULL); 4432 4433 /* Except for the 'I', in UTF-8 strings, the lower case of a 4434 * character below 256 occupies the same number of bytes as the 4435 * original. Therefore, the space needed is the original length 4436 * plus I_count plus the number of characters that become two bytes 4437 * when converted to UTF-8 */ 4438 sv_utf8_upgrade_flags_grow(dest, 0, len 4439 + I_count 4440 + variant_under_utf8_count(s, send) 4441 + 1 /* Trailing NUL */ ); 4442 d = (U8*)SvPVX(dest); 4443 has_turkic_I = TRUE; 4444 } 4445 } 4446 4447 #endif 4448 4449 /* Overloaded values may have toggled the UTF-8 flag on source, so we need 4450 to check DO_UTF8 again here. */ 4451 4452 if (DO_UTF8(source)) { 4453 const U8 *const send = s + len; 4454 U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; 4455 bool remove_dot_above = FALSE; 4456 4457 while (s < send) { 4458 const STRLEN u = UTF8SKIP(s); 4459 STRLEN ulen; 4460 4461 #ifdef USE_LOCALE_CTYPE 4462 4463 _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE)); 4464 4465 /* If we are in a Turkic locale, we have to do more work. As noted 4466 * in the comments for lcfirst, there is a special case if a 'I' 4467 * is in a grapheme with COMBINING DOT ABOVE UTF8. It turns into a 4468 * 'i', and the DOT must be removed. We check for that situation, 4469 * and set a flag if the DOT is there. Then each time through the 4470 * loop, we have to see if we need to remove the next DOT above, 4471 * and if so, do it. We know that there is a DOT because 4472 * _toLOWER_utf8_flags() wouldn't have returned 'i' unless there 4473 * was one in a proper position. */ 4474 if ( UNLIKELY(PL_in_utf8_turkic_locale) 4475 && IN_LC_RUNTIME(LC_CTYPE)) 4476 { 4477 if ( UNLIKELY(remove_dot_above) 4478 && memBEGINs(tmpbuf, sizeof(tmpbuf), COMBINING_DOT_ABOVE_UTF8)) 4479 { 4480 s += u; 4481 remove_dot_above = FALSE; 4482 continue; 4483 } 4484 else if (UNLIKELY(*s == 'I' && tmpbuf[0] == 'i')) { 4485 remove_dot_above = TRUE; 4486 } 4487 } 4488 #else 4489 PERL_UNUSED_VAR(remove_dot_above); 4490 4491 _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, 0); 4492 #endif 4493 4494 /* Here is where we would do context-sensitive actions for the 4495 * Greek final sigma. See the commit message for 86510fb15 for why 4496 * there isn't any */ 4497 4498 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) { 4499 4500 /* If the eventually required minimum size outgrows the 4501 * available space, we need to grow. */ 4502 const UV o = d - (U8*)SvPVX_const(dest); 4503 4504 /* If someone lowercases one million U+0130s we SvGROW() one 4505 * million times. Or we could try guessing how much to 4506 * allocate without allocating too much. Such is life. 4507 * Another option would be to grow an extra byte or two more 4508 * each time we need to grow, which would cut down the million 4509 * to 500K, with little waste */ 4510 d = o + (U8*) SvGROW(dest, min); 4511 } 4512 4513 /* Copy the newly lowercased letter to the output buffer we're 4514 * building */ 4515 Copy(tmpbuf, d, ulen, U8); 4516 d += ulen; 4517 s += u; 4518 } /* End of looping through the source string */ 4519 SvUTF8_on(dest); 4520 *d = '\0'; 4521 SvCUR_set(dest, d - (U8*)SvPVX_const(dest)); 4522 } else { /* 'source' not utf8 */ 4523 if (len) { 4524 const U8 *const send = s + len; 4525 4526 /* Use locale casing if in locale; regular style if not treating 4527 * latin1 as having case; otherwise the latin1 casing. Do the 4528 * whole thing in a tight loop, for speed, */ 4529 #ifdef USE_LOCALE_CTYPE 4530 if (IN_LC_RUNTIME(LC_CTYPE)) { 4531 if (LIKELY( ! has_turkic_I)) { 4532 for (; s < send; d++, s++) 4533 *d = toLOWER_LC(*s); 4534 } 4535 else { /* This is the only case where lc() converts 'dest' 4536 into UTF-8 from a non-UTF-8 'source' */ 4537 for (; s < send; s++) { 4538 if (*s == 'I') { 4539 *d++ = UTF8_TWO_BYTE_HI(LATIN_SMALL_LETTER_DOTLESS_I); 4540 *d++ = UTF8_TWO_BYTE_LO(LATIN_SMALL_LETTER_DOTLESS_I); 4541 } 4542 else { 4543 append_utf8_from_native_byte(toLOWER_LATIN1(*s), &d); 4544 } 4545 } 4546 } 4547 } 4548 else 4549 #endif 4550 if (! IN_UNI_8_BIT) { 4551 for (; s < send; d++, s++) { 4552 *d = toLOWER(*s); 4553 } 4554 } 4555 else { 4556 for (; s < send; d++, s++) { 4557 *d = toLOWER_LATIN1(*s); 4558 } 4559 } 4560 } 4561 if (source != dest) { 4562 *d = '\0'; 4563 SvCUR_set(dest, d - (U8*)SvPVX_const(dest)); 4564 } 4565 } 4566 #ifdef USE_LOCALE_CTYPE 4567 if (IN_LC_RUNTIME(LC_CTYPE)) { 4568 TAINT; 4569 SvTAINTED_on(dest); 4570 } 4571 #endif 4572 if (dest != source && SvTAINTED(source)) 4573 SvTAINT(dest); 4574 SvSETMAGIC(dest); 4575 return NORMAL; 4576 } 4577 4578 PP(pp_quotemeta) 4579 { 4580 dSP; dTARGET; 4581 SV * const sv = TOPs; 4582 STRLEN len; 4583 const char *s = SvPV_const(sv,len); 4584 4585 SvUTF8_off(TARG); /* decontaminate */ 4586 if (len) { 4587 char *d; 4588 SvUPGRADE(TARG, SVt_PV); 4589 SvGROW(TARG, (len * 2) + 1); 4590 d = SvPVX(TARG); 4591 if (DO_UTF8(sv)) { 4592 while (len) { 4593 STRLEN ulen = UTF8SKIP(s); 4594 bool to_quote = FALSE; 4595 4596 if (UTF8_IS_INVARIANT(*s)) { 4597 if (_isQUOTEMETA(*s)) { 4598 to_quote = TRUE; 4599 } 4600 } 4601 else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(s, s + len)) { 4602 if ( 4603 #ifdef USE_LOCALE_CTYPE 4604 /* In locale, we quote all non-ASCII Latin1 chars. 4605 * Otherwise use the quoting rules */ 4606 4607 IN_LC_RUNTIME(LC_CTYPE) 4608 || 4609 #endif 4610 _isQUOTEMETA(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s + 1)))) 4611 { 4612 to_quote = TRUE; 4613 } 4614 } 4615 else if (is_QUOTEMETA_high(s)) { 4616 to_quote = TRUE; 4617 } 4618 4619 if (to_quote) { 4620 *d++ = '\\'; 4621 } 4622 if (ulen > len) 4623 ulen = len; 4624 len -= ulen; 4625 while (ulen--) 4626 *d++ = *s++; 4627 } 4628 SvUTF8_on(TARG); 4629 } 4630 else if (IN_UNI_8_BIT) { 4631 while (len--) { 4632 if (_isQUOTEMETA(*s)) 4633 *d++ = '\\'; 4634 *d++ = *s++; 4635 } 4636 } 4637 else { 4638 /* For non UNI_8_BIT (and hence in locale) just quote all \W 4639 * including everything above ASCII */ 4640 while (len--) { 4641 if (!isWORDCHAR_A(*s)) 4642 *d++ = '\\'; 4643 *d++ = *s++; 4644 } 4645 } 4646 *d = '\0'; 4647 SvCUR_set(TARG, d - SvPVX_const(TARG)); 4648 (void)SvPOK_only_UTF8(TARG); 4649 } 4650 else 4651 sv_setpvn(TARG, s, len); 4652 SETTARG; 4653 return NORMAL; 4654 } 4655 4656 PP(pp_fc) 4657 { 4658 dTARGET; 4659 dSP; 4660 SV *source = TOPs; 4661 STRLEN len; 4662 STRLEN min; 4663 SV *dest; 4664 const U8 *s; 4665 const U8 *send; 4666 U8 *d; 4667 U8 tmpbuf[UTF8_MAXBYTES_CASE + 1]; 4668 #if UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */ \ 4669 || (UNICODE_MAJOR_VERSION == 3 && ( UNICODE_DOT_VERSION > 0) \ 4670 || UNICODE_DOT_DOT_VERSION > 0) 4671 const bool full_folding = TRUE; /* This variable is here so we can easily 4672 move to more generality later */ 4673 #else 4674 const bool full_folding = FALSE; 4675 #endif 4676 const U8 flags = ( full_folding ? FOLD_FLAGS_FULL : 0 ) 4677 #ifdef USE_LOCALE_CTYPE 4678 | ( IN_LC_RUNTIME(LC_CTYPE) ? FOLD_FLAGS_LOCALE : 0 ) 4679 #endif 4680 ; 4681 4682 /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me. 4683 * You are welcome(?) -Hugmeir 4684 */ 4685 4686 SvGETMAGIC(source); 4687 4688 dest = TARG; 4689 4690 if (SvOK(source)) { 4691 s = (const U8*)SvPV_nomg_const(source, len); 4692 } else { 4693 if (ckWARN(WARN_UNINITIALIZED)) 4694 report_uninit(source); 4695 s = (const U8*)""; 4696 len = 0; 4697 } 4698 4699 min = len + 1; 4700 4701 SvUPGRADE(dest, SVt_PV); 4702 d = (U8*)SvGROW(dest, min); 4703 (void)SvPOK_only(dest); 4704 4705 SETs(dest); 4706 4707 send = s + len; 4708 4709 #ifdef USE_LOCALE_CTYPE 4710 4711 if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */ 4712 _CHECK_AND_WARN_PROBLEMATIC_LOCALE; 4713 } 4714 4715 #endif 4716 4717 if (DO_UTF8(source)) { /* UTF-8 flagged string. */ 4718 while (s < send) { 4719 const STRLEN u = UTF8SKIP(s); 4720 STRLEN ulen; 4721 4722 _toFOLD_utf8_flags(s, send, tmpbuf, &ulen, flags); 4723 4724 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) { 4725 const UV o = d - (U8*)SvPVX_const(dest); 4726 d = o + (U8*) SvGROW(dest, min); 4727 } 4728 4729 Copy(tmpbuf, d, ulen, U8); 4730 d += ulen; 4731 s += u; 4732 } 4733 SvUTF8_on(dest); 4734 } /* Unflagged string */ 4735 else if (len) { 4736 #ifdef USE_LOCALE_CTYPE 4737 if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */ 4738 if (IN_UTF8_CTYPE_LOCALE) { 4739 goto do_uni_folding; 4740 } 4741 for (; s < send; d++, s++) 4742 *d = (U8) toFOLD_LC(*s); 4743 } 4744 else 4745 #endif 4746 if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */ 4747 for (; s < send; d++, s++) 4748 *d = toFOLD(*s); 4749 } 4750 else { 4751 #ifdef USE_LOCALE_CTYPE 4752 do_uni_folding: 4753 #endif 4754 /* For ASCII and the Latin-1 range, there's potentially three 4755 * troublesome folds: 4756 * \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full 4757 * casefolding becomes 'ss'; 4758 * \x{B5} (\N{MICRO SIGN}), which under any fold becomes 4759 * \x{3BC} (\N{GREEK SMALL LETTER MU}) 4760 * I only in Turkic locales, this folds to \x{131} 4761 * \N{LATIN SMALL LETTER DOTLESS I} 4762 * For the rest, the casefold is their lowercase. */ 4763 for (; s < send; d++, s++) { 4764 if ( UNLIKELY(*s == MICRO_SIGN) 4765 #ifdef USE_LOCALE_CTYPE 4766 || ( UNLIKELY(PL_in_utf8_turkic_locale) 4767 && UNLIKELY(IN_LC_RUNTIME(LC_CTYPE)) 4768 && UNLIKELY(*s == 'I')) 4769 #endif 4770 ) { 4771 Size_t extra = send - s 4772 + variant_under_utf8_count(s, send); 4773 4774 /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU}, 4775 * and 'I' in Turkic locales is \N{LATIN SMALL LETTER 4776 * DOTLESS I} both of which are outside of the latin-1 4777 * range. There's a couple of ways to deal with this -- khw 4778 * discusses them in pp_lc/uc, so go there :) What we do 4779 * here is upgrade what we had already casefolded, then 4780 * enter an inner loop that appends the rest of the 4781 * characters as UTF-8. 4782 * 4783 * First we calculate the needed size of the upgraded dest 4784 * beyond what's been processed already (the upgrade 4785 * function figures that out). Except for the 'I' in 4786 * Turkic locales, in UTF-8 strings, the fold case of a 4787 * character below 256 occupies the same number of bytes as 4788 * the original (even the Sharp S). Therefore, the space 4789 * needed is the number of bytes remaining plus the number 4790 * of characters that become two bytes when converted to 4791 * UTF-8 plus, in turkish locales, the number of 'I's */ 4792 4793 if (UNLIKELY(*s == 'I')) { 4794 const U8 * s_peek = s; 4795 4796 do { 4797 extra++; 4798 4799 s_peek = (U8 *) memchr(s_peek + 1, 'i', 4800 send - (s_peek + 1)); 4801 } while (s_peek != NULL); 4802 } 4803 4804 /* Growing may move things, so have to save and recalculate 4805 * 'd' */ 4806 len = d - (U8*)SvPVX_const(dest); 4807 SvCUR_set(dest, len); 4808 len = sv_utf8_upgrade_flags_grow(dest, 4809 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE, 4810 extra 4811 + 1 /* Trailing NUL */ ); 4812 d = (U8*)SvPVX(dest) + len; 4813 4814 *d++ = UTF8_TWO_BYTE_HI(GREEK_SMALL_LETTER_MU); 4815 *d++ = UTF8_TWO_BYTE_LO(GREEK_SMALL_LETTER_MU); 4816 s++; 4817 4818 for (; s < send; s++) { 4819 STRLEN ulen; 4820 _to_uni_fold_flags(*s, d, &ulen, flags); 4821 d += ulen; 4822 } 4823 break; 4824 } 4825 else if ( UNLIKELY(*s == LATIN_SMALL_LETTER_SHARP_S) 4826 && full_folding) 4827 { 4828 /* Under full casefolding, LATIN SMALL LETTER SHARP S 4829 * becomes "ss", which may require growing the SV. */ 4830 if (SvLEN(dest) < ++min) { 4831 const UV o = d - (U8*)SvPVX_const(dest); 4832 d = o + (U8*) SvGROW(dest, min); 4833 } 4834 *(d)++ = 's'; 4835 *d = 's'; 4836 } 4837 else { /* Else, the fold is the lower case */ 4838 *d = toLOWER_LATIN1(*s); 4839 } 4840 } 4841 } 4842 } 4843 *d = '\0'; 4844 SvCUR_set(dest, d - (U8*)SvPVX_const(dest)); 4845 4846 #ifdef USE_LOCALE_CTYPE 4847 if (IN_LC_RUNTIME(LC_CTYPE)) { 4848 TAINT; 4849 SvTAINTED_on(dest); 4850 } 4851 #endif 4852 if (SvTAINTED(source)) 4853 SvTAINT(dest); 4854 SvSETMAGIC(dest); 4855 RETURN; 4856 } 4857 4858 /* Arrays. */ 4859 4860 PP(pp_aslice) 4861 { 4862 dSP; dMARK; dORIGMARK; 4863 AV *const av = MUTABLE_AV(POPs); 4864 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET); 4865 4866 if (SvTYPE(av) == SVt_PVAV) { 4867 const bool localizing = PL_op->op_private & OPpLVAL_INTRO; 4868 bool can_preserve = FALSE; 4869 4870 if (localizing) { 4871 MAGIC *mg; 4872 HV *stash; 4873 4874 can_preserve = SvCANEXISTDELETE(av); 4875 } 4876 4877 if (lval && localizing) { 4878 SV **svp; 4879 SSize_t max = -1; 4880 for (svp = MARK + 1; svp <= SP; svp++) { 4881 const SSize_t elem = SvIV(*svp); 4882 if (elem > max) 4883 max = elem; 4884 } 4885 if (max > AvMAX(av)) 4886 av_extend(av, max); 4887 } 4888 4889 while (++MARK <= SP) { 4890 SV **svp; 4891 SSize_t elem = SvIV(*MARK); 4892 bool preeminent = TRUE; 4893 4894 if (localizing && can_preserve) { 4895 /* If we can determine whether the element exist, 4896 * Try to preserve the existenceness of a tied array 4897 * element by using EXISTS and DELETE if possible. 4898 * Fallback to FETCH and STORE otherwise. */ 4899 preeminent = av_exists(av, elem); 4900 } 4901 4902 svp = av_fetch(av, elem, lval); 4903 if (lval) { 4904 if (!svp || !*svp) 4905 DIE(aTHX_ PL_no_aelem, elem); 4906 if (localizing) { 4907 if (preeminent) 4908 save_aelem(av, elem, svp); 4909 else 4910 SAVEADELETE(av, elem); 4911 } 4912 } 4913 *MARK = svp ? *svp : &PL_sv_undef; 4914 } 4915 } 4916 if (GIMME_V != G_ARRAY) { 4917 MARK = ORIGMARK; 4918 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef; 4919 SP = MARK; 4920 } 4921 RETURN; 4922 } 4923 4924 PP(pp_kvaslice) 4925 { 4926 dSP; dMARK; 4927 AV *const av = MUTABLE_AV(POPs); 4928 I32 lval = (PL_op->op_flags & OPf_MOD); 4929 SSize_t items = SP - MARK; 4930 4931 if (PL_op->op_private & OPpMAYBE_LVSUB) { 4932 const I32 flags = is_lvalue_sub(); 4933 if (flags) { 4934 if (!(flags & OPpENTERSUB_INARGS)) 4935 /* diag_listed_as: Can't modify %s in %s */ 4936 Perl_croak(aTHX_ "Can't modify index/value array slice in list assignment"); 4937 lval = flags; 4938 } 4939 } 4940 4941 MEXTEND(SP,items); 4942 while (items > 1) { 4943 *(MARK+items*2-1) = *(MARK+items); 4944 items--; 4945 } 4946 items = SP-MARK; 4947 SP += items; 4948 4949 while (++MARK <= SP) { 4950 SV **svp; 4951 4952 svp = av_fetch(av, SvIV(*MARK), lval); 4953 if (lval) { 4954 if (!svp || !*svp || *svp == &PL_sv_undef) { 4955 DIE(aTHX_ PL_no_aelem, SvIV(*MARK)); 4956 } 4957 *MARK = sv_mortalcopy(*MARK); 4958 } 4959 *++MARK = svp ? *svp : &PL_sv_undef; 4960 } 4961 if (GIMME_V != G_ARRAY) { 4962 MARK = SP - items*2; 4963 *++MARK = items > 0 ? *SP : &PL_sv_undef; 4964 SP = MARK; 4965 } 4966 RETURN; 4967 } 4968 4969 4970 PP(pp_aeach) 4971 { 4972 dSP; 4973 AV *array = MUTABLE_AV(POPs); 4974 const U8 gimme = GIMME_V; 4975 IV *iterp = Perl_av_iter_p(aTHX_ array); 4976 const IV current = (*iterp)++; 4977 4978 if (current > av_tindex(array)) { 4979 *iterp = 0; 4980 if (gimme == G_SCALAR) 4981 RETPUSHUNDEF; 4982 else 4983 RETURN; 4984 } 4985 4986 EXTEND(SP, 2); 4987 mPUSHi(current); 4988 if (gimme == G_ARRAY) { 4989 SV **const element = av_fetch(array, current, 0); 4990 PUSHs(element ? *element : &PL_sv_undef); 4991 } 4992 RETURN; 4993 } 4994 4995 /* also used for: pp_avalues()*/ 4996 PP(pp_akeys) 4997 { 4998 dSP; 4999 AV *array = MUTABLE_AV(POPs); 5000 const U8 gimme = GIMME_V; 5001 5002 *Perl_av_iter_p(aTHX_ array) = 0; 5003 5004 if (gimme == G_SCALAR) { 5005 dTARGET; 5006 PUSHi(av_tindex(array) + 1); 5007 } 5008 else if (gimme == G_ARRAY) { 5009 if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) { 5010 const I32 flags = is_lvalue_sub(); 5011 if (flags && !(flags & OPpENTERSUB_INARGS)) 5012 /* diag_listed_as: Can't modify %s in %s */ 5013 Perl_croak(aTHX_ 5014 "Can't modify keys on array in list assignment"); 5015 } 5016 { 5017 IV n = Perl_av_len(aTHX_ array); 5018 IV i; 5019 5020 EXTEND(SP, n + 1); 5021 5022 if ( PL_op->op_type == OP_AKEYS 5023 || ( PL_op->op_type == OP_AVHVSWITCH 5024 && (PL_op->op_private & 3) + OP_AEACH == OP_AKEYS )) 5025 { 5026 for (i = 0; i <= n; i++) { 5027 mPUSHi(i); 5028 } 5029 } 5030 else { 5031 for (i = 0; i <= n; i++) { 5032 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0); 5033 PUSHs(elem ? *elem : &PL_sv_undef); 5034 } 5035 } 5036 } 5037 } 5038 RETURN; 5039 } 5040 5041 /* Associative arrays. */ 5042 5043 PP(pp_each) 5044 { 5045 dSP; 5046 HV * hash = MUTABLE_HV(POPs); 5047 HE *entry; 5048 const U8 gimme = GIMME_V; 5049 5050 entry = hv_iternext(hash); 5051 5052 EXTEND(SP, 2); 5053 if (entry) { 5054 SV* const sv = hv_iterkeysv(entry); 5055 PUSHs(sv); 5056 if (gimme == G_ARRAY) { 5057 SV *val; 5058 val = hv_iterval(hash, entry); 5059 PUSHs(val); 5060 } 5061 } 5062 else if (gimme == G_SCALAR) 5063 RETPUSHUNDEF; 5064 5065 RETURN; 5066 } 5067 5068 STATIC OP * 5069 S_do_delete_local(pTHX) 5070 { 5071 dSP; 5072 const U8 gimme = GIMME_V; 5073 const MAGIC *mg; 5074 HV *stash; 5075 const bool sliced = !!(PL_op->op_private & OPpSLICE); 5076 SV **unsliced_keysv = sliced ? NULL : sp--; 5077 SV * const osv = POPs; 5078 SV **mark = sliced ? PL_stack_base + POPMARK : unsliced_keysv-1; 5079 dORIGMARK; 5080 const bool tied = SvRMAGICAL(osv) 5081 && mg_find((const SV *)osv, PERL_MAGIC_tied); 5082 const bool can_preserve = SvCANEXISTDELETE(osv); 5083 const U32 type = SvTYPE(osv); 5084 SV ** const end = sliced ? SP : unsliced_keysv; 5085 5086 if (type == SVt_PVHV) { /* hash element */ 5087 HV * const hv = MUTABLE_HV(osv); 5088 while (++MARK <= end) { 5089 SV * const keysv = *MARK; 5090 SV *sv = NULL; 5091 bool preeminent = TRUE; 5092 if (can_preserve) 5093 preeminent = hv_exists_ent(hv, keysv, 0); 5094 if (tied) { 5095 HE *he = hv_fetch_ent(hv, keysv, 1, 0); 5096 if (he) 5097 sv = HeVAL(he); 5098 else 5099 preeminent = FALSE; 5100 } 5101 else { 5102 sv = hv_delete_ent(hv, keysv, 0, 0); 5103 if (preeminent) 5104 SvREFCNT_inc_simple_void(sv); /* De-mortalize */ 5105 } 5106 if (preeminent) { 5107 if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv)); 5108 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM); 5109 if (tied) { 5110 *MARK = sv_mortalcopy(sv); 5111 mg_clear(sv); 5112 } else 5113 *MARK = sv; 5114 } 5115 else { 5116 SAVEHDELETE(hv, keysv); 5117 *MARK = &PL_sv_undef; 5118 } 5119 } 5120 } 5121 else if (type == SVt_PVAV) { /* array element */ 5122 if (PL_op->op_flags & OPf_SPECIAL) { 5123 AV * const av = MUTABLE_AV(osv); 5124 while (++MARK <= end) { 5125 SSize_t idx = SvIV(*MARK); 5126 SV *sv = NULL; 5127 bool preeminent = TRUE; 5128 if (can_preserve) 5129 preeminent = av_exists(av, idx); 5130 if (tied) { 5131 SV **svp = av_fetch(av, idx, 1); 5132 if (svp) 5133 sv = *svp; 5134 else 5135 preeminent = FALSE; 5136 } 5137 else { 5138 sv = av_delete(av, idx, 0); 5139 if (preeminent) 5140 SvREFCNT_inc_simple_void(sv); /* De-mortalize */ 5141 } 5142 if (preeminent) { 5143 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM); 5144 if (tied) { 5145 *MARK = sv_mortalcopy(sv); 5146 mg_clear(sv); 5147 } else 5148 *MARK = sv; 5149 } 5150 else { 5151 SAVEADELETE(av, idx); 5152 *MARK = &PL_sv_undef; 5153 } 5154 } 5155 } 5156 else 5157 DIE(aTHX_ "panic: avhv_delete no longer supported"); 5158 } 5159 else 5160 DIE(aTHX_ "Not a HASH reference"); 5161 if (sliced) { 5162 if (gimme == G_VOID) 5163 SP = ORIGMARK; 5164 else if (gimme == G_SCALAR) { 5165 MARK = ORIGMARK; 5166 if (SP > MARK) 5167 *++MARK = *SP; 5168 else 5169 *++MARK = &PL_sv_undef; 5170 SP = MARK; 5171 } 5172 } 5173 else if (gimme != G_VOID) 5174 PUSHs(*unsliced_keysv); 5175 5176 RETURN; 5177 } 5178 5179 PP(pp_delete) 5180 { 5181 dSP; 5182 U8 gimme; 5183 I32 discard; 5184 5185 if (PL_op->op_private & OPpLVAL_INTRO) 5186 return do_delete_local(); 5187 5188 gimme = GIMME_V; 5189 discard = (gimme == G_VOID) ? G_DISCARD : 0; 5190 5191 if (PL_op->op_private & (OPpSLICE|OPpKVSLICE)) { 5192 dMARK; dORIGMARK; 5193 HV * const hv = MUTABLE_HV(POPs); 5194 const U32 hvtype = SvTYPE(hv); 5195 int skip = 0; 5196 if (PL_op->op_private & OPpKVSLICE) { 5197 SSize_t items = SP - MARK; 5198 5199 MEXTEND(SP,items); 5200 while (items > 1) { 5201 *(MARK+items*2-1) = *(MARK+items); 5202 items--; 5203 } 5204 items = SP - MARK; 5205 SP += items; 5206 skip = 1; 5207 } 5208 if (hvtype == SVt_PVHV) { /* hash element */ 5209 while ((MARK += (1+skip)) <= SP) { 5210 SV * const sv = hv_delete_ent(hv, *(MARK-skip), discard, 0); 5211 *MARK = sv ? sv : &PL_sv_undef; 5212 } 5213 } 5214 else if (hvtype == SVt_PVAV) { /* array element */ 5215 if (PL_op->op_flags & OPf_SPECIAL) { 5216 while ((MARK += (1+skip)) <= SP) { 5217 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*(MARK-skip)), discard); 5218 *MARK = sv ? sv : &PL_sv_undef; 5219 } 5220 } 5221 } 5222 else 5223 DIE(aTHX_ "Not a HASH reference"); 5224 if (discard) 5225 SP = ORIGMARK; 5226 else if (gimme == G_SCALAR) { 5227 MARK = ORIGMARK; 5228 if (SP > MARK) 5229 *++MARK = *SP; 5230 else 5231 *++MARK = &PL_sv_undef; 5232 SP = MARK; 5233 } 5234 } 5235 else { 5236 SV *keysv = POPs; 5237 HV * const hv = MUTABLE_HV(POPs); 5238 SV *sv = NULL; 5239 if (SvTYPE(hv) == SVt_PVHV) 5240 sv = hv_delete_ent(hv, keysv, discard, 0); 5241 else if (SvTYPE(hv) == SVt_PVAV) { 5242 if (PL_op->op_flags & OPf_SPECIAL) 5243 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard); 5244 else 5245 DIE(aTHX_ "panic: avhv_delete no longer supported"); 5246 } 5247 else 5248 DIE(aTHX_ "Not a HASH reference"); 5249 if (!sv) 5250 sv = &PL_sv_undef; 5251 if (!discard) 5252 PUSHs(sv); 5253 } 5254 RETURN; 5255 } 5256 5257 PP(pp_exists) 5258 { 5259 dSP; 5260 SV *tmpsv; 5261 HV *hv; 5262 5263 if (UNLIKELY( PL_op->op_private & OPpEXISTS_SUB )) { 5264 GV *gv; 5265 SV * const sv = POPs; 5266 CV * const cv = sv_2cv(sv, &hv, &gv, 0); 5267 if (cv) 5268 RETPUSHYES; 5269 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv)) 5270 RETPUSHYES; 5271 RETPUSHNO; 5272 } 5273 tmpsv = POPs; 5274 hv = MUTABLE_HV(POPs); 5275 if (LIKELY( SvTYPE(hv) == SVt_PVHV )) { 5276 if (hv_exists_ent(hv, tmpsv, 0)) 5277 RETPUSHYES; 5278 } 5279 else if (SvTYPE(hv) == SVt_PVAV) { 5280 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */ 5281 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv))) 5282 RETPUSHYES; 5283 } 5284 } 5285 else { 5286 DIE(aTHX_ "Not a HASH reference"); 5287 } 5288 RETPUSHNO; 5289 } 5290 5291 PP(pp_hslice) 5292 { 5293 dSP; dMARK; dORIGMARK; 5294 HV * const hv = MUTABLE_HV(POPs); 5295 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET); 5296 const bool localizing = PL_op->op_private & OPpLVAL_INTRO; 5297 bool can_preserve = FALSE; 5298 5299 if (localizing) { 5300 MAGIC *mg; 5301 HV *stash; 5302 5303 if (SvCANEXISTDELETE(hv)) 5304 can_preserve = TRUE; 5305 } 5306 5307 while (++MARK <= SP) { 5308 SV * const keysv = *MARK; 5309 SV **svp; 5310 HE *he; 5311 bool preeminent = TRUE; 5312 5313 if (localizing && can_preserve) { 5314 /* If we can determine whether the element exist, 5315 * try to preserve the existenceness of a tied hash 5316 * element by using EXISTS and DELETE if possible. 5317 * Fallback to FETCH and STORE otherwise. */ 5318 preeminent = hv_exists_ent(hv, keysv, 0); 5319 } 5320 5321 he = hv_fetch_ent(hv, keysv, lval, 0); 5322 svp = he ? &HeVAL(he) : NULL; 5323 5324 if (lval) { 5325 if (!svp || !*svp || *svp == &PL_sv_undef) { 5326 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv)); 5327 } 5328 if (localizing) { 5329 if (HvNAME_get(hv) && isGV_or_RVCV(*svp)) 5330 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL)); 5331 else if (preeminent) 5332 save_helem_flags(hv, keysv, svp, 5333 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC); 5334 else 5335 SAVEHDELETE(hv, keysv); 5336 } 5337 } 5338 *MARK = svp && *svp ? *svp : &PL_sv_undef; 5339 } 5340 if (GIMME_V != G_ARRAY) { 5341 MARK = ORIGMARK; 5342 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef; 5343 SP = MARK; 5344 } 5345 RETURN; 5346 } 5347 5348 PP(pp_kvhslice) 5349 { 5350 dSP; dMARK; 5351 HV * const hv = MUTABLE_HV(POPs); 5352 I32 lval = (PL_op->op_flags & OPf_MOD); 5353 SSize_t items = SP - MARK; 5354 5355 if (PL_op->op_private & OPpMAYBE_LVSUB) { 5356 const I32 flags = is_lvalue_sub(); 5357 if (flags) { 5358 if (!(flags & OPpENTERSUB_INARGS)) 5359 /* diag_listed_as: Can't modify %s in %s */ 5360 Perl_croak(aTHX_ "Can't modify key/value hash slice in %s assignment", 5361 GIMME_V == G_ARRAY ? "list" : "scalar"); 5362 lval = flags; 5363 } 5364 } 5365 5366 MEXTEND(SP,items); 5367 while (items > 1) { 5368 *(MARK+items*2-1) = *(MARK+items); 5369 items--; 5370 } 5371 items = SP-MARK; 5372 SP += items; 5373 5374 while (++MARK <= SP) { 5375 SV * const keysv = *MARK; 5376 SV **svp; 5377 HE *he; 5378 5379 he = hv_fetch_ent(hv, keysv, lval, 0); 5380 svp = he ? &HeVAL(he) : NULL; 5381 5382 if (lval) { 5383 if (!svp || !*svp || *svp == &PL_sv_undef) { 5384 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv)); 5385 } 5386 *MARK = sv_mortalcopy(*MARK); 5387 } 5388 *++MARK = svp && *svp ? *svp : &PL_sv_undef; 5389 } 5390 if (GIMME_V != G_ARRAY) { 5391 MARK = SP - items*2; 5392 *++MARK = items > 0 ? *SP : &PL_sv_undef; 5393 SP = MARK; 5394 } 5395 RETURN; 5396 } 5397 5398 /* List operators. */ 5399 5400 PP(pp_list) 5401 { 5402 I32 markidx = POPMARK; 5403 if (GIMME_V != G_ARRAY) { 5404 /* don't initialize mark here, EXTEND() may move the stack */ 5405 SV **mark; 5406 dSP; 5407 EXTEND(SP, 1); /* in case no arguments, as in @empty */ 5408 mark = PL_stack_base + markidx; 5409 if (++MARK <= SP) 5410 *MARK = *SP; /* unwanted list, return last item */ 5411 else 5412 *MARK = &PL_sv_undef; 5413 SP = MARK; 5414 PUTBACK; 5415 } 5416 return NORMAL; 5417 } 5418 5419 PP(pp_lslice) 5420 { 5421 dSP; 5422 SV ** const lastrelem = PL_stack_sp; 5423 SV ** const lastlelem = PL_stack_base + POPMARK; 5424 SV ** const firstlelem = PL_stack_base + POPMARK + 1; 5425 SV ** const firstrelem = lastlelem + 1; 5426 const U8 mod = PL_op->op_flags & OPf_MOD; 5427 5428 const I32 max = lastrelem - lastlelem; 5429 SV **lelem; 5430 5431 if (GIMME_V != G_ARRAY) { 5432 if (lastlelem < firstlelem) { 5433 EXTEND(SP, 1); 5434 *firstlelem = &PL_sv_undef; 5435 } 5436 else { 5437 I32 ix = SvIV(*lastlelem); 5438 if (ix < 0) 5439 ix += max; 5440 if (ix < 0 || ix >= max) 5441 *firstlelem = &PL_sv_undef; 5442 else 5443 *firstlelem = firstrelem[ix]; 5444 } 5445 SP = firstlelem; 5446 RETURN; 5447 } 5448 5449 if (max == 0) { 5450 SP = firstlelem - 1; 5451 RETURN; 5452 } 5453 5454 for (lelem = firstlelem; lelem <= lastlelem; lelem++) { 5455 I32 ix = SvIV(*lelem); 5456 if (ix < 0) 5457 ix += max; 5458 if (ix < 0 || ix >= max) 5459 *lelem = &PL_sv_undef; 5460 else { 5461 if (!(*lelem = firstrelem[ix])) 5462 *lelem = &PL_sv_undef; 5463 else if (mod && SvPADTMP(*lelem)) { 5464 *lelem = firstrelem[ix] = sv_mortalcopy(*lelem); 5465 } 5466 } 5467 } 5468 SP = lastlelem; 5469 RETURN; 5470 } 5471 5472 PP(pp_anonlist) 5473 { 5474 dSP; dMARK; 5475 const I32 items = SP - MARK; 5476 SV * const av = MUTABLE_SV(av_make(items, MARK+1)); 5477 SP = MARK; 5478 mXPUSHs((PL_op->op_flags & OPf_SPECIAL) 5479 ? newRV_noinc(av) : av); 5480 RETURN; 5481 } 5482 5483 PP(pp_anonhash) 5484 { 5485 dSP; dMARK; dORIGMARK; 5486 HV* const hv = newHV(); 5487 SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL 5488 ? newRV_noinc(MUTABLE_SV(hv)) 5489 : MUTABLE_SV(hv) ); 5490 5491 while (MARK < SP) { 5492 SV * const key = 5493 (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK); 5494 SV *val; 5495 if (MARK < SP) 5496 { 5497 MARK++; 5498 SvGETMAGIC(*MARK); 5499 val = newSV(0); 5500 sv_setsv_nomg(val, *MARK); 5501 } 5502 else 5503 { 5504 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash"); 5505 val = newSV(0); 5506 } 5507 (void)hv_store_ent(hv,key,val,0); 5508 } 5509 SP = ORIGMARK; 5510 XPUSHs(retval); 5511 RETURN; 5512 } 5513 5514 PP(pp_splice) 5515 { 5516 dSP; dMARK; dORIGMARK; 5517 int num_args = (SP - MARK); 5518 AV *ary = MUTABLE_AV(*++MARK); 5519 SV **src; 5520 SV **dst; 5521 SSize_t i; 5522 SSize_t offset; 5523 SSize_t length; 5524 SSize_t newlen; 5525 SSize_t after; 5526 SSize_t diff; 5527 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied); 5528 5529 if (mg) { 5530 return Perl_tied_method(aTHX_ SV_CONST(SPLICE), mark - 1, MUTABLE_SV(ary), mg, 5531 GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK, 5532 sp - mark); 5533 } 5534 5535 if (SvREADONLY(ary)) 5536 Perl_croak_no_modify(); 5537 5538 SP++; 5539 5540 if (++MARK < SP) { 5541 offset = i = SvIV(*MARK); 5542 if (offset < 0) 5543 offset += AvFILLp(ary) + 1; 5544 if (offset < 0) 5545 DIE(aTHX_ PL_no_aelem, i); 5546 if (++MARK < SP) { 5547 length = SvIVx(*MARK++); 5548 if (length < 0) { 5549 length += AvFILLp(ary) - offset + 1; 5550 if (length < 0) 5551 length = 0; 5552 } 5553 } 5554 else 5555 length = AvMAX(ary) + 1; /* close enough to infinity */ 5556 } 5557 else { 5558 offset = 0; 5559 length = AvMAX(ary) + 1; 5560 } 5561 if (offset > AvFILLp(ary) + 1) { 5562 if (num_args > 2) 5563 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" ); 5564 offset = AvFILLp(ary) + 1; 5565 } 5566 after = AvFILLp(ary) + 1 - (offset + length); 5567 if (after < 0) { /* not that much array */ 5568 length += after; /* offset+length now in array */ 5569 after = 0; 5570 if (!AvALLOC(ary)) 5571 av_extend(ary, 0); 5572 } 5573 5574 /* At this point, MARK .. SP-1 is our new LIST */ 5575 5576 newlen = SP - MARK; 5577 diff = newlen - length; 5578 if (newlen && !AvREAL(ary) && AvREIFY(ary)) 5579 av_reify(ary); 5580 5581 /* make new elements SVs now: avoid problems if they're from the array */ 5582 for (dst = MARK, i = newlen; i; i--) { 5583 SV * const h = *dst; 5584 *dst++ = newSVsv(h); 5585 } 5586 5587 if (diff < 0) { /* shrinking the area */ 5588 SV **tmparyval = NULL; 5589 if (newlen) { 5590 Newx(tmparyval, newlen, SV*); /* so remember insertion */ 5591 Copy(MARK, tmparyval, newlen, SV*); 5592 } 5593 5594 MARK = ORIGMARK + 1; 5595 if (GIMME_V == G_ARRAY) { /* copy return vals to stack */ 5596 const bool real = cBOOL(AvREAL(ary)); 5597 MEXTEND(MARK, length); 5598 if (real) 5599 EXTEND_MORTAL(length); 5600 for (i = 0, dst = MARK; i < length; i++) { 5601 if ((*dst = AvARRAY(ary)[i+offset])) { 5602 if (real) 5603 sv_2mortal(*dst); /* free them eventually */ 5604 } 5605 else 5606 *dst = &PL_sv_undef; 5607 dst++; 5608 } 5609 MARK += length - 1; 5610 } 5611 else { 5612 *MARK = AvARRAY(ary)[offset+length-1]; 5613 if (AvREAL(ary)) { 5614 sv_2mortal(*MARK); 5615 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--) 5616 SvREFCNT_dec(*dst++); /* free them now */ 5617 } 5618 if (!*MARK) 5619 *MARK = &PL_sv_undef; 5620 } 5621 AvFILLp(ary) += diff; 5622 5623 /* pull up or down? */ 5624 5625 if (offset < after) { /* easier to pull up */ 5626 if (offset) { /* esp. if nothing to pull */ 5627 src = &AvARRAY(ary)[offset-1]; 5628 dst = src - diff; /* diff is negative */ 5629 for (i = offset; i > 0; i--) /* can't trust Copy */ 5630 *dst-- = *src--; 5631 } 5632 dst = AvARRAY(ary); 5633 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */ 5634 AvMAX(ary) += diff; 5635 } 5636 else { 5637 if (after) { /* anything to pull down? */ 5638 src = AvARRAY(ary) + offset + length; 5639 dst = src + diff; /* diff is negative */ 5640 Move(src, dst, after, SV*); 5641 } 5642 dst = &AvARRAY(ary)[AvFILLp(ary)+1]; 5643 /* avoid later double free */ 5644 } 5645 i = -diff; 5646 while (i) 5647 dst[--i] = NULL; 5648 5649 if (newlen) { 5650 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* ); 5651 Safefree(tmparyval); 5652 } 5653 } 5654 else { /* no, expanding (or same) */ 5655 SV** tmparyval = NULL; 5656 if (length) { 5657 Newx(tmparyval, length, SV*); /* so remember deletion */ 5658 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*); 5659 } 5660 5661 if (diff > 0) { /* expanding */ 5662 /* push up or down? */ 5663 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) { 5664 if (offset) { 5665 src = AvARRAY(ary); 5666 dst = src - diff; 5667 Move(src, dst, offset, SV*); 5668 } 5669 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */ 5670 AvMAX(ary) += diff; 5671 AvFILLp(ary) += diff; 5672 } 5673 else { 5674 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */ 5675 av_extend(ary, AvFILLp(ary) + diff); 5676 AvFILLp(ary) += diff; 5677 5678 if (after) { 5679 dst = AvARRAY(ary) + AvFILLp(ary); 5680 src = dst - diff; 5681 for (i = after; i; i--) { 5682 *dst-- = *src--; 5683 } 5684 } 5685 } 5686 } 5687 5688 if (newlen) { 5689 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* ); 5690 } 5691 5692 MARK = ORIGMARK + 1; 5693 if (GIMME_V == G_ARRAY) { /* copy return vals to stack */ 5694 if (length) { 5695 const bool real = cBOOL(AvREAL(ary)); 5696 if (real) 5697 EXTEND_MORTAL(length); 5698 for (i = 0, dst = MARK; i < length; i++) { 5699 if ((*dst = tmparyval[i])) { 5700 if (real) 5701 sv_2mortal(*dst); /* free them eventually */ 5702 } 5703 else *dst = &PL_sv_undef; 5704 dst++; 5705 } 5706 } 5707 MARK += length - 1; 5708 } 5709 else if (length--) { 5710 *MARK = tmparyval[length]; 5711 if (AvREAL(ary)) { 5712 sv_2mortal(*MARK); 5713 while (length-- > 0) 5714 SvREFCNT_dec(tmparyval[length]); 5715 } 5716 if (!*MARK) 5717 *MARK = &PL_sv_undef; 5718 } 5719 else 5720 *MARK = &PL_sv_undef; 5721 Safefree(tmparyval); 5722 } 5723 5724 if (SvMAGICAL(ary)) 5725 mg_set(MUTABLE_SV(ary)); 5726 5727 SP = MARK; 5728 RETURN; 5729 } 5730 5731 PP(pp_push) 5732 { 5733 dSP; dMARK; dORIGMARK; dTARGET; 5734 AV * const ary = MUTABLE_AV(*++MARK); 5735 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied); 5736 5737 if (mg) { 5738 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg); 5739 PUSHMARK(MARK); 5740 PUTBACK; 5741 ENTER_with_name("call_PUSH"); 5742 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED); 5743 LEAVE_with_name("call_PUSH"); 5744 /* SPAGAIN; not needed: SP is assigned to immediately below */ 5745 } 5746 else { 5747 /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we 5748 * only need to save locally, not on the save stack */ 5749 U16 old_delaymagic = PL_delaymagic; 5750 5751 if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify(); 5752 PL_delaymagic = DM_DELAY; 5753 for (++MARK; MARK <= SP; MARK++) { 5754 SV *sv; 5755 if (*MARK) SvGETMAGIC(*MARK); 5756 sv = newSV(0); 5757 if (*MARK) 5758 sv_setsv_nomg(sv, *MARK); 5759 av_store(ary, AvFILLp(ary)+1, sv); 5760 } 5761 if (PL_delaymagic & DM_ARRAY_ISA) 5762 mg_set(MUTABLE_SV(ary)); 5763 PL_delaymagic = old_delaymagic; 5764 } 5765 SP = ORIGMARK; 5766 if (OP_GIMME(PL_op, 0) != G_VOID) { 5767 PUSHi( AvFILL(ary) + 1 ); 5768 } 5769 RETURN; 5770 } 5771 5772 /* also used for: pp_pop()*/ 5773 PP(pp_shift) 5774 { 5775 dSP; 5776 AV * const av = PL_op->op_flags & OPf_SPECIAL 5777 ? MUTABLE_AV(GvAVn(PL_defgv)) : MUTABLE_AV(POPs); 5778 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av); 5779 EXTEND(SP, 1); 5780 assert (sv); 5781 if (AvREAL(av)) 5782 (void)sv_2mortal(sv); 5783 PUSHs(sv); 5784 RETURN; 5785 } 5786 5787 PP(pp_unshift) 5788 { 5789 dSP; dMARK; dORIGMARK; dTARGET; 5790 AV *ary = MUTABLE_AV(*++MARK); 5791 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied); 5792 5793 if (mg) { 5794 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg); 5795 PUSHMARK(MARK); 5796 PUTBACK; 5797 ENTER_with_name("call_UNSHIFT"); 5798 call_sv(SV_CONST(UNSHIFT),G_SCALAR|G_DISCARD|G_METHOD_NAMED); 5799 LEAVE_with_name("call_UNSHIFT"); 5800 /* SPAGAIN; not needed: SP is assigned to immediately below */ 5801 } 5802 else { 5803 /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we 5804 * only need to save locally, not on the save stack */ 5805 U16 old_delaymagic = PL_delaymagic; 5806 SSize_t i = 0; 5807 5808 av_unshift(ary, SP - MARK); 5809 PL_delaymagic = DM_DELAY; 5810 while (MARK < SP) { 5811 SV * const sv = newSVsv(*++MARK); 5812 (void)av_store(ary, i++, sv); 5813 } 5814 if (PL_delaymagic & DM_ARRAY_ISA) 5815 mg_set(MUTABLE_SV(ary)); 5816 PL_delaymagic = old_delaymagic; 5817 } 5818 SP = ORIGMARK; 5819 if (OP_GIMME(PL_op, 0) != G_VOID) { 5820 PUSHi( AvFILL(ary) + 1 ); 5821 } 5822 RETURN; 5823 } 5824 5825 PP(pp_reverse) 5826 { 5827 dSP; dMARK; 5828 5829 if (GIMME_V == G_ARRAY) { 5830 if (PL_op->op_private & OPpREVERSE_INPLACE) { 5831 AV *av; 5832 5833 /* See pp_sort() */ 5834 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV); 5835 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */ 5836 av = MUTABLE_AV((*SP)); 5837 /* In-place reversing only happens in void context for the array 5838 * assignment. We don't need to push anything on the stack. */ 5839 SP = MARK; 5840 5841 if (SvMAGICAL(av)) { 5842 SSize_t i, j; 5843 SV *tmp = sv_newmortal(); 5844 /* For SvCANEXISTDELETE */ 5845 HV *stash; 5846 const MAGIC *mg; 5847 bool can_preserve = SvCANEXISTDELETE(av); 5848 5849 for (i = 0, j = av_tindex(av); i < j; ++i, --j) { 5850 SV *begin, *end; 5851 5852 if (can_preserve) { 5853 if (!av_exists(av, i)) { 5854 if (av_exists(av, j)) { 5855 SV *sv = av_delete(av, j, 0); 5856 begin = *av_fetch(av, i, TRUE); 5857 sv_setsv_mg(begin, sv); 5858 } 5859 continue; 5860 } 5861 else if (!av_exists(av, j)) { 5862 SV *sv = av_delete(av, i, 0); 5863 end = *av_fetch(av, j, TRUE); 5864 sv_setsv_mg(end, sv); 5865 continue; 5866 } 5867 } 5868 5869 begin = *av_fetch(av, i, TRUE); 5870 end = *av_fetch(av, j, TRUE); 5871 sv_setsv(tmp, begin); 5872 sv_setsv_mg(begin, end); 5873 sv_setsv_mg(end, tmp); 5874 } 5875 } 5876 else { 5877 SV **begin = AvARRAY(av); 5878 5879 if (begin) { 5880 SV **end = begin + AvFILLp(av); 5881 5882 while (begin < end) { 5883 SV * const tmp = *begin; 5884 *begin++ = *end; 5885 *end-- = tmp; 5886 } 5887 } 5888 } 5889 } 5890 else { 5891 SV **oldsp = SP; 5892 MARK++; 5893 while (MARK < SP) { 5894 SV * const tmp = *MARK; 5895 *MARK++ = *SP; 5896 *SP-- = tmp; 5897 } 5898 /* safe as long as stack cannot get extended in the above */ 5899 SP = oldsp; 5900 } 5901 } 5902 else { 5903 char *up; 5904 dTARGET; 5905 STRLEN len; 5906 5907 SvUTF8_off(TARG); /* decontaminate */ 5908 if (SP - MARK > 1) { 5909 do_join(TARG, &PL_sv_no, MARK, SP); 5910 SP = MARK + 1; 5911 SETs(TARG); 5912 } else if (SP > MARK) { 5913 sv_setsv(TARG, *SP); 5914 SETs(TARG); 5915 } else { 5916 sv_setsv(TARG, DEFSV); 5917 XPUSHs(TARG); 5918 } 5919 5920 up = SvPV_force(TARG, len); 5921 if (len > 1) { 5922 char *down; 5923 if (DO_UTF8(TARG)) { /* first reverse each character */ 5924 U8* s = (U8*)SvPVX(TARG); 5925 const U8* send = (U8*)(s + len); 5926 while (s < send) { 5927 if (UTF8_IS_INVARIANT(*s)) { 5928 s++; 5929 continue; 5930 } 5931 else { 5932 if (!utf8_to_uvchr_buf(s, send, 0)) 5933 break; 5934 up = (char*)s; 5935 s += UTF8SKIP(s); 5936 down = (char*)(s - 1); 5937 /* reverse this character */ 5938 while (down > up) { 5939 const char tmp = *up; 5940 *up++ = *down; 5941 *down-- = tmp; 5942 } 5943 } 5944 } 5945 up = SvPVX(TARG); 5946 } 5947 down = SvPVX(TARG) + len - 1; 5948 while (down > up) { 5949 const char tmp = *up; 5950 *up++ = *down; 5951 *down-- = tmp; 5952 } 5953 (void)SvPOK_only_UTF8(TARG); 5954 } 5955 } 5956 RETURN; 5957 } 5958 5959 PP(pp_split) 5960 { 5961 dSP; dTARG; 5962 AV *ary = ( (PL_op->op_private & OPpSPLIT_ASSIGN) /* @a = split */ 5963 && (PL_op->op_flags & OPf_STACKED)) /* @{expr} = split */ 5964 ? (AV *)POPs : NULL; 5965 IV limit = POPi; /* note, negative is forever */ 5966 SV * const sv = POPs; 5967 STRLEN len; 5968 const char *s = SvPV_const(sv, len); 5969 const bool do_utf8 = DO_UTF8(sv); 5970 const bool in_uni_8_bit = IN_UNI_8_BIT; 5971 const char *strend = s + len; 5972 PMOP *pm = cPMOPx(PL_op); 5973 REGEXP *rx; 5974 SV *dstr; 5975 const char *m; 5976 SSize_t iters = 0; 5977 const STRLEN slen = do_utf8 5978 ? utf8_length((U8*)s, (U8*)strend) 5979 : (STRLEN)(strend - s); 5980 SSize_t maxiters = slen + 10; 5981 I32 trailing_empty = 0; 5982 const char *orig; 5983 const IV origlimit = limit; 5984 I32 realarray = 0; 5985 I32 base; 5986 const U8 gimme = GIMME_V; 5987 bool gimme_scalar; 5988 I32 oldsave = PL_savestack_ix; 5989 U32 make_mortal = SVs_TEMP; 5990 bool multiline = 0; 5991 MAGIC *mg = NULL; 5992 5993 rx = PM_GETRE(pm); 5994 5995 TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET && 5996 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE))); 5997 5998 /* handle @ary = split(...) optimisation */ 5999 if (PL_op->op_private & OPpSPLIT_ASSIGN) { 6000 if (!(PL_op->op_flags & OPf_STACKED)) { 6001 if (PL_op->op_private & OPpSPLIT_LEX) { 6002 if (PL_op->op_private & OPpLVAL_INTRO) 6003 SAVECLEARSV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)); 6004 ary = (AV *)PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff); 6005 } 6006 else { 6007 GV *gv = 6008 #ifdef USE_ITHREADS 6009 MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)); 6010 #else 6011 pm->op_pmreplrootu.op_pmtargetgv; 6012 #endif 6013 if (PL_op->op_private & OPpLVAL_INTRO) 6014 ary = save_ary(gv); 6015 else 6016 ary = GvAVn(gv); 6017 } 6018 /* skip anything pushed by OPpLVAL_INTRO above */ 6019 oldsave = PL_savestack_ix; 6020 } 6021 6022 realarray = 1; 6023 PUTBACK; 6024 av_extend(ary,0); 6025 (void)sv_2mortal(SvREFCNT_inc_simple_NN(sv)); 6026 av_clear(ary); 6027 SPAGAIN; 6028 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) { 6029 PUSHMARK(SP); 6030 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg)); 6031 } 6032 else { 6033 if (!AvREAL(ary)) { 6034 I32 i; 6035 AvREAL_on(ary); 6036 AvREIFY_off(ary); 6037 for (i = AvFILLp(ary); i >= 0; i--) 6038 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */ 6039 } 6040 /* temporarily switch stacks */ 6041 SAVESWITCHSTACK(PL_curstack, ary); 6042 make_mortal = 0; 6043 } 6044 } 6045 6046 base = SP - PL_stack_base; 6047 orig = s; 6048 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) { 6049 if (do_utf8) { 6050 while (s < strend && isSPACE_utf8_safe(s, strend)) 6051 s += UTF8SKIP(s); 6052 } 6053 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) { 6054 while (s < strend && isSPACE_LC(*s)) 6055 s++; 6056 } 6057 else if (in_uni_8_bit) { 6058 while (s < strend && isSPACE_L1(*s)) 6059 s++; 6060 } 6061 else { 6062 while (s < strend && isSPACE(*s)) 6063 s++; 6064 } 6065 } 6066 if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) { 6067 multiline = 1; 6068 } 6069 6070 gimme_scalar = gimme == G_SCALAR && !ary; 6071 6072 if (!limit) 6073 limit = maxiters + 2; 6074 if (RX_EXTFLAGS(rx) & RXf_WHITE) { 6075 while (--limit) { 6076 m = s; 6077 /* this one uses 'm' and is a negative test */ 6078 if (do_utf8) { 6079 while (m < strend && ! isSPACE_utf8_safe(m, strend) ) { 6080 const int t = UTF8SKIP(m); 6081 /* isSPACE_utf8_safe returns FALSE for malform utf8 */ 6082 if (strend - m < t) 6083 m = strend; 6084 else 6085 m += t; 6086 } 6087 } 6088 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) 6089 { 6090 while (m < strend && !isSPACE_LC(*m)) 6091 ++m; 6092 } 6093 else if (in_uni_8_bit) { 6094 while (m < strend && !isSPACE_L1(*m)) 6095 ++m; 6096 } else { 6097 while (m < strend && !isSPACE(*m)) 6098 ++m; 6099 } 6100 if (m >= strend) 6101 break; 6102 6103 if (gimme_scalar) { 6104 iters++; 6105 if (m-s == 0) 6106 trailing_empty++; 6107 else 6108 trailing_empty = 0; 6109 } else { 6110 dstr = newSVpvn_flags(s, m-s, 6111 (do_utf8 ? SVf_UTF8 : 0) | make_mortal); 6112 XPUSHs(dstr); 6113 } 6114 6115 /* skip the whitespace found last */ 6116 if (do_utf8) 6117 s = m + UTF8SKIP(m); 6118 else 6119 s = m + 1; 6120 6121 /* this one uses 's' and is a positive test */ 6122 if (do_utf8) { 6123 while (s < strend && isSPACE_utf8_safe(s, strend) ) 6124 s += UTF8SKIP(s); 6125 } 6126 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) 6127 { 6128 while (s < strend && isSPACE_LC(*s)) 6129 ++s; 6130 } 6131 else if (in_uni_8_bit) { 6132 while (s < strend && isSPACE_L1(*s)) 6133 ++s; 6134 } else { 6135 while (s < strend && isSPACE(*s)) 6136 ++s; 6137 } 6138 } 6139 } 6140 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) { 6141 while (--limit) { 6142 for (m = s; m < strend && *m != '\n'; m++) 6143 ; 6144 m++; 6145 if (m >= strend) 6146 break; 6147 6148 if (gimme_scalar) { 6149 iters++; 6150 if (m-s == 0) 6151 trailing_empty++; 6152 else 6153 trailing_empty = 0; 6154 } else { 6155 dstr = newSVpvn_flags(s, m-s, 6156 (do_utf8 ? SVf_UTF8 : 0) | make_mortal); 6157 XPUSHs(dstr); 6158 } 6159 s = m; 6160 } 6161 } 6162 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) { 6163 /* 6164 Pre-extend the stack, either the number of bytes or 6165 characters in the string or a limited amount, triggered by: 6166 6167 my ($x, $y) = split //, $str; 6168 or 6169 split //, $str, $i; 6170 */ 6171 if (!gimme_scalar) { 6172 const IV items = limit - 1; 6173 /* setting it to -1 will trigger a panic in EXTEND() */ 6174 const SSize_t sslen = slen > SSize_t_MAX ? -1 : (SSize_t)slen; 6175 if (items >=0 && items < sslen) 6176 EXTEND(SP, items); 6177 else 6178 EXTEND(SP, sslen); 6179 } 6180 6181 if (do_utf8) { 6182 while (--limit) { 6183 /* keep track of how many bytes we skip over */ 6184 m = s; 6185 s += UTF8SKIP(s); 6186 if (gimme_scalar) { 6187 iters++; 6188 if (s-m == 0) 6189 trailing_empty++; 6190 else 6191 trailing_empty = 0; 6192 } else { 6193 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal); 6194 6195 PUSHs(dstr); 6196 } 6197 6198 if (s >= strend) 6199 break; 6200 } 6201 } else { 6202 while (--limit) { 6203 if (gimme_scalar) { 6204 iters++; 6205 } else { 6206 dstr = newSVpvn(s, 1); 6207 6208 6209 if (make_mortal) 6210 sv_2mortal(dstr); 6211 6212 PUSHs(dstr); 6213 } 6214 6215 s++; 6216 6217 if (s >= strend) 6218 break; 6219 } 6220 } 6221 } 6222 else if (do_utf8 == (RX_UTF8(rx) != 0) && 6223 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx) 6224 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL) 6225 && !(RX_EXTFLAGS(rx) & RXf_IS_ANCHORED)) { 6226 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL); 6227 SV * const csv = CALLREG_INTUIT_STRING(rx); 6228 6229 len = RX_MINLENRET(rx); 6230 if (len == 1 && !RX_UTF8(rx) && !tail) { 6231 const char c = *SvPV_nolen_const(csv); 6232 while (--limit) { 6233 for (m = s; m < strend && *m != c; m++) 6234 ; 6235 if (m >= strend) 6236 break; 6237 if (gimme_scalar) { 6238 iters++; 6239 if (m-s == 0) 6240 trailing_empty++; 6241 else 6242 trailing_empty = 0; 6243 } else { 6244 dstr = newSVpvn_flags(s, m-s, 6245 (do_utf8 ? SVf_UTF8 : 0) | make_mortal); 6246 XPUSHs(dstr); 6247 } 6248 /* The rx->minlen is in characters but we want to step 6249 * s ahead by bytes. */ 6250 if (do_utf8) 6251 s = (char*)utf8_hop_forward((U8*) m, len, (U8*) strend); 6252 else 6253 s = m + len; /* Fake \n at the end */ 6254 } 6255 } 6256 else { 6257 while (s < strend && --limit && 6258 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend, 6259 csv, multiline ? FBMrf_MULTILINE : 0)) ) 6260 { 6261 if (gimme_scalar) { 6262 iters++; 6263 if (m-s == 0) 6264 trailing_empty++; 6265 else 6266 trailing_empty = 0; 6267 } else { 6268 dstr = newSVpvn_flags(s, m-s, 6269 (do_utf8 ? SVf_UTF8 : 0) | make_mortal); 6270 XPUSHs(dstr); 6271 } 6272 /* The rx->minlen is in characters but we want to step 6273 * s ahead by bytes. */ 6274 if (do_utf8) 6275 s = (char*)utf8_hop_forward((U8*)m, len, (U8 *) strend); 6276 else 6277 s = m + len; /* Fake \n at the end */ 6278 } 6279 } 6280 } 6281 else { 6282 maxiters += slen * RX_NPARENS(rx); 6283 while (s < strend && --limit) 6284 { 6285 I32 rex_return; 6286 PUTBACK; 6287 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1, 6288 sv, NULL, 0); 6289 SPAGAIN; 6290 if (rex_return == 0) 6291 break; 6292 TAINT_IF(RX_MATCH_TAINTED(rx)); 6293 /* we never pass the REXEC_COPY_STR flag, so it should 6294 * never get copied */ 6295 assert(!RX_MATCH_COPIED(rx)); 6296 m = RX_OFFS(rx)[0].start + orig; 6297 6298 if (gimme_scalar) { 6299 iters++; 6300 if (m-s == 0) 6301 trailing_empty++; 6302 else 6303 trailing_empty = 0; 6304 } else { 6305 dstr = newSVpvn_flags(s, m-s, 6306 (do_utf8 ? SVf_UTF8 : 0) | make_mortal); 6307 XPUSHs(dstr); 6308 } 6309 if (RX_NPARENS(rx)) { 6310 I32 i; 6311 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) { 6312 s = RX_OFFS(rx)[i].start + orig; 6313 m = RX_OFFS(rx)[i].end + orig; 6314 6315 /* japhy (07/27/01) -- the (m && s) test doesn't catch 6316 parens that didn't match -- they should be set to 6317 undef, not the empty string */ 6318 if (gimme_scalar) { 6319 iters++; 6320 if (m-s == 0) 6321 trailing_empty++; 6322 else 6323 trailing_empty = 0; 6324 } else { 6325 if (m >= orig && s >= orig) { 6326 dstr = newSVpvn_flags(s, m-s, 6327 (do_utf8 ? SVf_UTF8 : 0) 6328 | make_mortal); 6329 } 6330 else 6331 dstr = &PL_sv_undef; /* undef, not "" */ 6332 XPUSHs(dstr); 6333 } 6334 6335 } 6336 } 6337 s = RX_OFFS(rx)[0].end + orig; 6338 } 6339 } 6340 6341 if (!gimme_scalar) { 6342 iters = (SP - PL_stack_base) - base; 6343 } 6344 if (iters > maxiters) 6345 DIE(aTHX_ "Split loop"); 6346 6347 /* keep field after final delim? */ 6348 if (s < strend || (iters && origlimit)) { 6349 if (!gimme_scalar) { 6350 const STRLEN l = strend - s; 6351 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal); 6352 XPUSHs(dstr); 6353 } 6354 iters++; 6355 } 6356 else if (!origlimit) { 6357 if (gimme_scalar) { 6358 iters -= trailing_empty; 6359 } else { 6360 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) { 6361 if (TOPs && !make_mortal) 6362 sv_2mortal(TOPs); 6363 *SP-- = NULL; 6364 iters--; 6365 } 6366 } 6367 } 6368 6369 PUTBACK; 6370 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */ 6371 SPAGAIN; 6372 if (realarray) { 6373 if (!mg) { 6374 if (SvSMAGICAL(ary)) { 6375 PUTBACK; 6376 mg_set(MUTABLE_SV(ary)); 6377 SPAGAIN; 6378 } 6379 if (gimme == G_ARRAY) { 6380 EXTEND(SP, iters); 6381 Copy(AvARRAY(ary), SP + 1, iters, SV*); 6382 SP += iters; 6383 RETURN; 6384 } 6385 } 6386 else { 6387 PUTBACK; 6388 ENTER_with_name("call_PUSH"); 6389 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED); 6390 LEAVE_with_name("call_PUSH"); 6391 SPAGAIN; 6392 if (gimme == G_ARRAY) { 6393 SSize_t i; 6394 /* EXTEND should not be needed - we just popped them */ 6395 EXTEND(SP, iters); 6396 for (i=0; i < iters; i++) { 6397 SV **svp = av_fetch(ary, i, FALSE); 6398 PUSHs((svp) ? *svp : &PL_sv_undef); 6399 } 6400 RETURN; 6401 } 6402 } 6403 } 6404 else { 6405 if (gimme == G_ARRAY) 6406 RETURN; 6407 } 6408 6409 GETTARGET; 6410 XPUSHi(iters); 6411 RETURN; 6412 } 6413 6414 PP(pp_once) 6415 { 6416 dSP; 6417 SV *const sv = PAD_SVl(PL_op->op_targ); 6418 6419 if (SvPADSTALE(sv)) { 6420 /* First time. */ 6421 SvPADSTALE_off(sv); 6422 RETURNOP(cLOGOP->op_other); 6423 } 6424 RETURNOP(cLOGOP->op_next); 6425 } 6426 6427 PP(pp_lock) 6428 { 6429 dSP; 6430 dTOPss; 6431 SV *retsv = sv; 6432 SvLOCK(sv); 6433 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV 6434 || SvTYPE(retsv) == SVt_PVCV) { 6435 retsv = refto(retsv); 6436 } 6437 SETs(retsv); 6438 RETURN; 6439 } 6440 6441 6442 /* used for: pp_padany(), pp_custom(); plus any system ops 6443 * that aren't implemented on a particular platform */ 6444 6445 PP(unimplemented_op) 6446 { 6447 const Optype op_type = PL_op->op_type; 6448 /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope 6449 with out of range op numbers - it only "special" cases op_custom. 6450 Secondly, as the three ops we "panic" on are padmy, mapstart and custom, 6451 if we get here for a custom op then that means that the custom op didn't 6452 have an implementation. Given that OP_NAME() looks up the custom op 6453 by its pp_addr, likely it will return NULL, unless someone (unhelpfully) 6454 registers &PL_unimplemented_op as the address of their custom op. 6455 NULL doesn't generate a useful error message. "custom" does. */ 6456 const char *const name = op_type >= OP_max 6457 ? "[out of range]" : PL_op_name[PL_op->op_type]; 6458 if(OP_IS_SOCKET(op_type)) 6459 DIE(aTHX_ PL_no_sock_func, name); 6460 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name, op_type); 6461 } 6462 6463 static void 6464 S_maybe_unwind_defav(pTHX) 6465 { 6466 if (CX_CUR()->cx_type & CXp_HASARGS) { 6467 PERL_CONTEXT *cx = CX_CUR(); 6468 6469 assert(CxHASARGS(cx)); 6470 cx_popsub_args(cx); 6471 cx->cx_type &= ~CXp_HASARGS; 6472 } 6473 } 6474 6475 /* For sorting out arguments passed to a &CORE:: subroutine */ 6476 PP(pp_coreargs) 6477 { 6478 dSP; 6479 int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0; 6480 int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0; 6481 AV * const at_ = GvAV(PL_defgv); 6482 SV **svp = at_ ? AvARRAY(at_) : NULL; 6483 I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0; 6484 I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0; 6485 bool seen_question = 0; 6486 const char *err = NULL; 6487 const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK; 6488 6489 /* Count how many args there are first, to get some idea how far to 6490 extend the stack. */ 6491 while (oa) { 6492 if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; } 6493 maxargs++; 6494 if (oa & OA_OPTIONAL) seen_question = 1; 6495 if (!seen_question) minargs++; 6496 oa >>= 4; 6497 } 6498 6499 if(numargs < minargs) err = "Not enough"; 6500 else if(numargs > maxargs) err = "Too many"; 6501 if (err) 6502 /* diag_listed_as: Too many arguments for %s */ 6503 Perl_croak(aTHX_ 6504 "%s arguments for %s", err, 6505 opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv) 6506 ); 6507 6508 /* Reset the stack pointer. Without this, we end up returning our own 6509 arguments in list context, in addition to the values we are supposed 6510 to return. nextstate usually does this on sub entry, but we need 6511 to run the next op with the caller's hints, so we cannot have a 6512 nextstate. */ 6513 SP = PL_stack_base + CX_CUR()->blk_oldsp; 6514 6515 if(!maxargs) RETURN; 6516 6517 /* We do this here, rather than with a separate pushmark op, as it has 6518 to come in between two things this function does (stack reset and 6519 arg pushing). This seems the easiest way to do it. */ 6520 if (pushmark) { 6521 PUTBACK; 6522 (void)Perl_pp_pushmark(aTHX); 6523 } 6524 6525 EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs); 6526 PUTBACK; /* The code below can die in various places. */ 6527 6528 oa = PL_opargs[opnum] >> OASHIFT; 6529 for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) { 6530 whicharg++; 6531 switch (oa & 7) { 6532 case OA_SCALAR: 6533 try_defsv: 6534 if (!numargs && defgv && whicharg == minargs + 1) { 6535 PUSHs(DEFSV); 6536 } 6537 else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL); 6538 break; 6539 case OA_LIST: 6540 while (numargs--) { 6541 PUSHs(svp && *svp ? *svp : &PL_sv_undef); 6542 svp++; 6543 } 6544 RETURN; 6545 case OA_AVREF: 6546 if (!numargs) { 6547 GV *gv; 6548 if (CvUNIQUE(find_runcv_where(FIND_RUNCV_level_eq,1,NULL))) 6549 gv = PL_argvgv; 6550 else { 6551 S_maybe_unwind_defav(aTHX); 6552 gv = PL_defgv; 6553 } 6554 PUSHs((SV *)GvAVn(gv)); 6555 break; 6556 } 6557 if (!svp || !*svp || !SvROK(*svp) 6558 || SvTYPE(SvRV(*svp)) != SVt_PVAV) 6559 DIE(aTHX_ 6560 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/ 6561 "Type of arg %d to &CORE::%s must be array reference", 6562 whicharg, PL_op_desc[opnum] 6563 ); 6564 PUSHs(SvRV(*svp)); 6565 break; 6566 case OA_HVREF: 6567 if (!svp || !*svp || !SvROK(*svp) 6568 || ( SvTYPE(SvRV(*svp)) != SVt_PVHV 6569 && ( opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN 6570 || SvTYPE(SvRV(*svp)) != SVt_PVAV ))) 6571 DIE(aTHX_ 6572 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/ 6573 "Type of arg %d to &CORE::%s must be hash%s reference", 6574 whicharg, PL_op_desc[opnum], 6575 opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN 6576 ? "" 6577 : " or array" 6578 ); 6579 PUSHs(SvRV(*svp)); 6580 break; 6581 case OA_FILEREF: 6582 if (!numargs) PUSHs(NULL); 6583 else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp))) 6584 /* no magic here, as the prototype will have added an extra 6585 refgen and we just want what was there before that */ 6586 PUSHs(SvRV(*svp)); 6587 else { 6588 const bool constr = PL_op->op_private & whicharg; 6589 PUSHs(S_rv2gv(aTHX_ 6590 svp && *svp ? *svp : &PL_sv_undef, 6591 constr, cBOOL(CopHINTS_get(PL_curcop) & HINT_STRICT_REFS), 6592 !constr 6593 )); 6594 } 6595 break; 6596 case OA_SCALARREF: 6597 if (!numargs) goto try_defsv; 6598 else { 6599 const bool wantscalar = 6600 PL_op->op_private & OPpCOREARGS_SCALARMOD; 6601 if (!svp || !*svp || !SvROK(*svp) 6602 /* We have to permit globrefs even for the \$ proto, as 6603 *foo is indistinguishable from ${\*foo}, and the proto- 6604 type permits the latter. */ 6605 || SvTYPE(SvRV(*svp)) > ( 6606 wantscalar ? SVt_PVLV 6607 : opnum == OP_LOCK || opnum == OP_UNDEF 6608 ? SVt_PVCV 6609 : SVt_PVHV 6610 ) 6611 ) 6612 DIE(aTHX_ 6613 "Type of arg %d to &CORE::%s must be %s", 6614 whicharg, PL_op_name[opnum], 6615 wantscalar 6616 ? "scalar reference" 6617 : opnum == OP_LOCK || opnum == OP_UNDEF 6618 ? "reference to one of [$@%&*]" 6619 : "reference to one of [$@%*]" 6620 ); 6621 PUSHs(SvRV(*svp)); 6622 if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv) { 6623 /* Undo @_ localisation, so that sub exit does not undo 6624 part of our undeffing. */ 6625 S_maybe_unwind_defav(aTHX); 6626 } 6627 } 6628 break; 6629 default: 6630 DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7)); 6631 } 6632 oa = oa >> 4; 6633 } 6634 6635 RETURN; 6636 } 6637 6638 /* Implement CORE::keys(),values(),each(). 6639 * 6640 * We won't know until run-time whether the arg is an array or hash, 6641 * so this op calls 6642 * 6643 * pp_keys/pp_values/pp_each 6644 * or 6645 * pp_akeys/pp_avalues/pp_aeach 6646 * 6647 * as appropriate (or whatever pp function actually implements the OP_FOO 6648 * functionality for each FOO). 6649 */ 6650 6651 PP(pp_avhvswitch) 6652 { 6653 dVAR; dSP; 6654 return PL_ppaddr[ 6655 (SvTYPE(TOPs) == SVt_PVAV ? OP_AEACH : OP_EACH) 6656 + (PL_op->op_private & OPpAVHVSWITCH_MASK) 6657 ](aTHX); 6658 } 6659 6660 PP(pp_runcv) 6661 { 6662 dSP; 6663 CV *cv; 6664 if (PL_op->op_private & OPpOFFBYONE) { 6665 cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL); 6666 } 6667 else cv = find_runcv(NULL); 6668 XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv))); 6669 RETURN; 6670 } 6671 6672 static void 6673 S_localise_aelem_lval(pTHX_ AV * const av, SV * const keysv, 6674 const bool can_preserve) 6675 { 6676 const SSize_t ix = SvIV(keysv); 6677 if (can_preserve ? av_exists(av, ix) : TRUE) { 6678 SV ** const svp = av_fetch(av, ix, 1); 6679 if (!svp || !*svp) 6680 Perl_croak(aTHX_ PL_no_aelem, ix); 6681 save_aelem(av, ix, svp); 6682 } 6683 else 6684 SAVEADELETE(av, ix); 6685 } 6686 6687 static void 6688 S_localise_helem_lval(pTHX_ HV * const hv, SV * const keysv, 6689 const bool can_preserve) 6690 { 6691 if (can_preserve ? hv_exists_ent(hv, keysv, 0) : TRUE) { 6692 HE * const he = hv_fetch_ent(hv, keysv, 1, 0); 6693 SV ** const svp = he ? &HeVAL(he) : NULL; 6694 if (!svp || !*svp) 6695 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(keysv)); 6696 save_helem_flags(hv, keysv, svp, 0); 6697 } 6698 else 6699 SAVEHDELETE(hv, keysv); 6700 } 6701 6702 static void 6703 S_localise_gv_slot(pTHX_ GV *gv, U8 type) 6704 { 6705 if (type == OPpLVREF_SV) { 6706 save_pushptrptr(gv, SvREFCNT_inc_simple(GvSV(gv)), SAVEt_GVSV); 6707 GvSV(gv) = 0; 6708 } 6709 else if (type == OPpLVREF_AV) 6710 /* XXX Inefficient, as it creates a new AV, which we are 6711 about to clobber. */ 6712 save_ary(gv); 6713 else { 6714 assert(type == OPpLVREF_HV); 6715 /* XXX Likewise inefficient. */ 6716 save_hash(gv); 6717 } 6718 } 6719 6720 6721 PP(pp_refassign) 6722 { 6723 dSP; 6724 SV * const key = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL; 6725 SV * const left = PL_op->op_flags & OPf_STACKED ? POPs : NULL; 6726 dTOPss; 6727 const char *bad = NULL; 6728 const U8 type = PL_op->op_private & OPpLVREF_TYPE; 6729 if (!SvROK(sv)) DIE(aTHX_ "Assigned value is not a reference"); 6730 switch (type) { 6731 case OPpLVREF_SV: 6732 if (SvTYPE(SvRV(sv)) > SVt_PVLV) 6733 bad = " SCALAR"; 6734 break; 6735 case OPpLVREF_AV: 6736 if (SvTYPE(SvRV(sv)) != SVt_PVAV) 6737 bad = "n ARRAY"; 6738 break; 6739 case OPpLVREF_HV: 6740 if (SvTYPE(SvRV(sv)) != SVt_PVHV) 6741 bad = " HASH"; 6742 break; 6743 case OPpLVREF_CV: 6744 if (SvTYPE(SvRV(sv)) != SVt_PVCV) 6745 bad = " CODE"; 6746 } 6747 if (bad) 6748 /* diag_listed_as: Assigned value is not %s reference */ 6749 DIE(aTHX_ "Assigned value is not a%s reference", bad); 6750 { 6751 MAGIC *mg; 6752 HV *stash; 6753 switch (left ? SvTYPE(left) : 0) { 6754 case 0: 6755 { 6756 SV * const old = PAD_SV(ARGTARG); 6757 PAD_SETSV(ARGTARG, SvREFCNT_inc_NN(SvRV(sv))); 6758 SvREFCNT_dec(old); 6759 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) 6760 == OPpLVAL_INTRO) 6761 SAVECLEARSV(PAD_SVl(ARGTARG)); 6762 break; 6763 } 6764 case SVt_PVGV: 6765 if (PL_op->op_private & OPpLVAL_INTRO) { 6766 S_localise_gv_slot(aTHX_ (GV *)left, type); 6767 } 6768 gv_setref(left, sv); 6769 SvSETMAGIC(left); 6770 break; 6771 case SVt_PVAV: 6772 assert(key); 6773 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) { 6774 S_localise_aelem_lval(aTHX_ (AV *)left, key, 6775 SvCANEXISTDELETE(left)); 6776 } 6777 av_store((AV *)left, SvIV(key), SvREFCNT_inc_simple_NN(SvRV(sv))); 6778 break; 6779 case SVt_PVHV: 6780 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) { 6781 assert(key); 6782 S_localise_helem_lval(aTHX_ (HV *)left, key, 6783 SvCANEXISTDELETE(left)); 6784 } 6785 (void)hv_store_ent((HV *)left, key, SvREFCNT_inc_simple_NN(SvRV(sv)), 0); 6786 } 6787 if (PL_op->op_flags & OPf_MOD) 6788 SETs(sv_2mortal(newSVsv(sv))); 6789 /* XXX else can weak references go stale before they are read, e.g., 6790 in leavesub? */ 6791 RETURN; 6792 } 6793 } 6794 6795 PP(pp_lvref) 6796 { 6797 dSP; 6798 SV * const ret = sv_2mortal(newSV_type(SVt_PVMG)); 6799 SV * const elem = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL; 6800 SV * const arg = PL_op->op_flags & OPf_STACKED ? POPs : NULL; 6801 MAGIC * const mg = sv_magicext(ret, arg, PERL_MAGIC_lvref, 6802 &PL_vtbl_lvref, (char *)elem, 6803 elem ? HEf_SVKEY : (I32)ARGTARG); 6804 mg->mg_private = PL_op->op_private; 6805 if (PL_op->op_private & OPpLVREF_ITER) 6806 mg->mg_flags |= MGf_PERSIST; 6807 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) { 6808 if (elem) { 6809 MAGIC *mg; 6810 HV *stash; 6811 assert(arg); 6812 { 6813 const bool can_preserve = SvCANEXISTDELETE(arg); 6814 if (SvTYPE(arg) == SVt_PVAV) 6815 S_localise_aelem_lval(aTHX_ (AV *)arg, elem, can_preserve); 6816 else 6817 S_localise_helem_lval(aTHX_ (HV *)arg, elem, can_preserve); 6818 } 6819 } 6820 else if (arg) { 6821 S_localise_gv_slot(aTHX_ (GV *)arg, 6822 PL_op->op_private & OPpLVREF_TYPE); 6823 } 6824 else if (!(PL_op->op_private & OPpPAD_STATE)) 6825 SAVECLEARSV(PAD_SVl(ARGTARG)); 6826 } 6827 XPUSHs(ret); 6828 RETURN; 6829 } 6830 6831 PP(pp_lvrefslice) 6832 { 6833 dSP; dMARK; 6834 AV * const av = (AV *)POPs; 6835 const bool localizing = PL_op->op_private & OPpLVAL_INTRO; 6836 bool can_preserve = FALSE; 6837 6838 if (UNLIKELY(localizing)) { 6839 MAGIC *mg; 6840 HV *stash; 6841 SV **svp; 6842 6843 can_preserve = SvCANEXISTDELETE(av); 6844 6845 if (SvTYPE(av) == SVt_PVAV) { 6846 SSize_t max = -1; 6847 6848 for (svp = MARK + 1; svp <= SP; svp++) { 6849 const SSize_t elem = SvIV(*svp); 6850 if (elem > max) 6851 max = elem; 6852 } 6853 if (max > AvMAX(av)) 6854 av_extend(av, max); 6855 } 6856 } 6857 6858 while (++MARK <= SP) { 6859 SV * const elemsv = *MARK; 6860 if (UNLIKELY(localizing)) { 6861 if (SvTYPE(av) == SVt_PVAV) 6862 S_localise_aelem_lval(aTHX_ av, elemsv, can_preserve); 6863 else 6864 S_localise_helem_lval(aTHX_ (HV *)av, elemsv, can_preserve); 6865 } 6866 *MARK = sv_2mortal(newSV_type(SVt_PVMG)); 6867 sv_magic(*MARK,(SV *)av,PERL_MAGIC_lvref,(char *)elemsv,HEf_SVKEY); 6868 } 6869 RETURN; 6870 } 6871 6872 PP(pp_lvavref) 6873 { 6874 if (PL_op->op_flags & OPf_STACKED) 6875 Perl_pp_rv2av(aTHX); 6876 else 6877 Perl_pp_padav(aTHX); 6878 { 6879 dSP; 6880 dTOPss; 6881 SETs(0); /* special alias marker that aassign recognises */ 6882 XPUSHs(sv); 6883 RETURN; 6884 } 6885 } 6886 6887 PP(pp_anonconst) 6888 { 6889 dSP; 6890 dTOPss; 6891 SETs(sv_2mortal((SV *)newCONSTSUB(SvTYPE(CopSTASH(PL_curcop))==SVt_PVHV 6892 ? CopSTASH(PL_curcop) 6893 : NULL, 6894 NULL, SvREFCNT_inc_simple_NN(sv)))); 6895 RETURN; 6896 } 6897 6898 6899 /* process one subroutine argument - typically when the sub has a signature: 6900 * introduce PL_curpad[op_targ] and assign to it the value 6901 * for $: (OPf_STACKED ? *sp : $_[N]) 6902 * for @/%: @_[N..$#_] 6903 * 6904 * It's equivalent to 6905 * my $foo = $_[N]; 6906 * or 6907 * my $foo = (value-on-stack) 6908 * or 6909 * my @foo = @_[N..$#_] 6910 * etc 6911 */ 6912 6913 PP(pp_argelem) 6914 { 6915 dTARG; 6916 SV *val; 6917 SV ** padentry; 6918 OP *o = PL_op; 6919 AV *defav = GvAV(PL_defgv); /* @_ */ 6920 IV ix = PTR2IV(cUNOP_AUXo->op_aux); 6921 IV argc; 6922 6923 /* do 'my $var, @var or %var' action */ 6924 padentry = &(PAD_SVl(o->op_targ)); 6925 save_clearsv(padentry); 6926 targ = *padentry; 6927 6928 if ((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_SV) { 6929 if (o->op_flags & OPf_STACKED) { 6930 dSP; 6931 val = POPs; 6932 PUTBACK; 6933 } 6934 else { 6935 SV **svp; 6936 /* should already have been checked */ 6937 assert(ix >= 0); 6938 #if IVSIZE > PTRSIZE 6939 assert(ix <= SSize_t_MAX); 6940 #endif 6941 6942 svp = av_fetch(defav, ix, FALSE); 6943 val = svp ? *svp : &PL_sv_undef; 6944 } 6945 6946 /* $var = $val */ 6947 6948 /* cargo-culted from pp_sassign */ 6949 assert(TAINTING_get || !TAINT_get); 6950 if (UNLIKELY(TAINT_get) && !SvTAINTED(val)) 6951 TAINT_NOT; 6952 6953 SvSetMagicSV(targ, val); 6954 return o->op_next; 6955 } 6956 6957 /* must be AV or HV */ 6958 6959 assert(!(o->op_flags & OPf_STACKED)); 6960 argc = ((IV)AvFILL(defav) + 1) - ix; 6961 6962 /* This is a copy of the relevant parts of pp_aassign(). 6963 */ 6964 if ((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_AV) { 6965 IV i; 6966 6967 if (AvFILL((AV*)targ) > -1) { 6968 /* target should usually be empty. If we get get 6969 * here, someone's been doing some weird closure tricks. 6970 * Make a copy of all args before clearing the array, 6971 * to avoid the equivalent of @a = ($a[0]) prematurely freeing 6972 * elements. See similar code in pp_aassign. 6973 */ 6974 for (i = 0; i < argc; i++) { 6975 SV **svp = av_fetch(defav, ix + i, FALSE); 6976 SV *newsv = newSV(0); 6977 sv_setsv_flags(newsv, 6978 svp ? *svp : &PL_sv_undef, 6979 (SV_DO_COW_SVSETSV|SV_NOSTEAL)); 6980 if (!av_store(defav, ix + i, newsv)) 6981 SvREFCNT_dec_NN(newsv); 6982 } 6983 av_clear((AV*)targ); 6984 } 6985 6986 if (argc <= 0) 6987 return o->op_next; 6988 6989 av_extend((AV*)targ, argc); 6990 6991 i = 0; 6992 while (argc--) { 6993 SV *tmpsv; 6994 SV **svp = av_fetch(defav, ix + i, FALSE); 6995 SV *val = svp ? *svp : &PL_sv_undef; 6996 tmpsv = newSV(0); 6997 sv_setsv(tmpsv, val); 6998 av_store((AV*)targ, i++, tmpsv); 6999 TAINT_NOT; 7000 } 7001 7002 } 7003 else { 7004 IV i; 7005 7006 assert((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_HV); 7007 7008 if (SvRMAGICAL(targ) || HvUSEDKEYS((HV*)targ)) { 7009 /* see "target should usually be empty" comment above */ 7010 for (i = 0; i < argc; i++) { 7011 SV **svp = av_fetch(defav, ix + i, FALSE); 7012 SV *newsv = newSV(0); 7013 sv_setsv_flags(newsv, 7014 svp ? *svp : &PL_sv_undef, 7015 (SV_DO_COW_SVSETSV|SV_NOSTEAL)); 7016 if (!av_store(defav, ix + i, newsv)) 7017 SvREFCNT_dec_NN(newsv); 7018 } 7019 hv_clear((HV*)targ); 7020 } 7021 7022 if (argc <= 0) 7023 return o->op_next; 7024 assert(argc % 2 == 0); 7025 7026 i = 0; 7027 while (argc) { 7028 SV *tmpsv; 7029 SV **svp; 7030 SV *key; 7031 SV *val; 7032 7033 svp = av_fetch(defav, ix + i++, FALSE); 7034 key = svp ? *svp : &PL_sv_undef; 7035 svp = av_fetch(defav, ix + i++, FALSE); 7036 val = svp ? *svp : &PL_sv_undef; 7037 7038 argc -= 2; 7039 if (UNLIKELY(SvGMAGICAL(key))) 7040 key = sv_mortalcopy(key); 7041 tmpsv = newSV(0); 7042 sv_setsv(tmpsv, val); 7043 hv_store_ent((HV*)targ, key, tmpsv, 0); 7044 TAINT_NOT; 7045 } 7046 } 7047 7048 return o->op_next; 7049 } 7050 7051 /* Handle a default value for one subroutine argument (typically as part 7052 * of a subroutine signature). 7053 * It's equivalent to 7054 * @_ > op_targ ? $_[op_targ] : result_of(op_other) 7055 * 7056 * Intended to be used where op_next is an OP_ARGELEM 7057 * 7058 * We abuse the op_targ field slightly: it's an index into @_ rather than 7059 * into PL_curpad. 7060 */ 7061 7062 PP(pp_argdefelem) 7063 { 7064 OP * const o = PL_op; 7065 AV *defav = GvAV(PL_defgv); /* @_ */ 7066 IV ix = (IV)o->op_targ; 7067 7068 assert(ix >= 0); 7069 #if IVSIZE > PTRSIZE 7070 assert(ix <= SSize_t_MAX); 7071 #endif 7072 7073 if (AvFILL(defav) >= ix) { 7074 dSP; 7075 SV **svp = av_fetch(defav, ix, FALSE); 7076 SV *val = svp ? *svp : &PL_sv_undef; 7077 XPUSHs(val); 7078 RETURN; 7079 } 7080 return cLOGOPo->op_other; 7081 } 7082 7083 7084 static SV * 7085 S_find_runcv_name(void) 7086 { 7087 dTHX; 7088 CV *cv; 7089 GV *gv; 7090 SV *sv; 7091 7092 cv = find_runcv(0); 7093 if (!cv) 7094 return &PL_sv_no; 7095 7096 gv = CvGV(cv); 7097 if (!gv) 7098 return &PL_sv_no; 7099 7100 sv = sv_2mortal(newSV(0)); 7101 gv_fullname4(sv, gv, NULL, TRUE); 7102 return sv; 7103 } 7104 7105 /* Check a a subs arguments - i.e. that it has the correct number of args 7106 * (and anything else we might think of in future). Typically used with 7107 * signatured subs. 7108 */ 7109 7110 PP(pp_argcheck) 7111 { 7112 OP * const o = PL_op; 7113 UNOP_AUX_item *aux = cUNOP_AUXo->op_aux; 7114 IV params = aux[0].iv; 7115 IV opt_params = aux[1].iv; 7116 char slurpy = (char)(aux[2].iv); 7117 AV *defav = GvAV(PL_defgv); /* @_ */ 7118 IV argc; 7119 bool too_few; 7120 7121 assert(!SvMAGICAL(defav)); 7122 argc = (AvFILLp(defav) + 1); 7123 too_few = (argc < (params - opt_params)); 7124 7125 if (UNLIKELY(too_few || (!slurpy && argc > params))) 7126 /* diag_listed_as: Too few arguments for subroutine '%s' */ 7127 /* diag_listed_as: Too many arguments for subroutine '%s' */ 7128 Perl_croak_caller("Too %s arguments for subroutine '%" SVf "'", 7129 too_few ? "few" : "many", S_find_runcv_name()); 7130 7131 if (UNLIKELY(slurpy == '%' && argc > params && (argc - params) % 2)) 7132 /* diag_listed_as: Odd name/value argument for subroutine '%s' */ 7133 Perl_croak_caller("Odd name/value argument for subroutine '%" SVf "'", 7134 S_find_runcv_name()); 7135 7136 return NORMAL; 7137 } 7138 7139 /* 7140 * ex: set ts=8 sts=4 sw=4 et: 7141 */ 7142