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