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