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 (void)srand48_deterministic((Rand_seed_t)anum); 2945 } 2946 else { 2947 anum = seed(); 2948 (void)seedDrand01((Rand_seed_t)anum); 2949 } 2950 2951 PL_srand_called = TRUE; 2952 if (anum) 2953 XPUSHu(anum); 2954 else { 2955 /* Historically srand always returned true. We can avoid breaking 2956 that like this: */ 2957 sv_setpvs(TARG, "0 but true"); 2958 XPUSHTARG; 2959 } 2960 RETURN; 2961 } 2962 2963 PP(pp_int) 2964 { 2965 dSP; dTARGET; 2966 tryAMAGICun_MG(int_amg, AMGf_numeric); 2967 { 2968 SV * const sv = TOPs; 2969 const IV iv = SvIV_nomg(sv); 2970 /* XXX it's arguable that compiler casting to IV might be subtly 2971 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which 2972 else preferring IV has introduced a subtle behaviour change bug. OTOH 2973 relying on floating point to be accurate is a bug. */ 2974 2975 if (!SvOK(sv)) { 2976 SETu(0); 2977 } 2978 else if (SvIOK(sv)) { 2979 if (SvIsUV(sv)) 2980 SETu(SvUV_nomg(sv)); 2981 else 2982 SETi(iv); 2983 } 2984 else { 2985 const NV value = SvNV_nomg(sv); 2986 if (UNLIKELY(Perl_isinfnan(value))) 2987 SETn(value); 2988 else if (value >= 0.0) { 2989 if (value < (NV)UV_MAX + 0.5) { 2990 SETu(U_V(value)); 2991 } else { 2992 SETn(Perl_floor(value)); 2993 } 2994 } 2995 else { 2996 if (value > (NV)IV_MIN - 0.5) { 2997 SETi(I_V(value)); 2998 } else { 2999 SETn(Perl_ceil(value)); 3000 } 3001 } 3002 } 3003 } 3004 return NORMAL; 3005 } 3006 3007 PP(pp_abs) 3008 { 3009 dSP; dTARGET; 3010 tryAMAGICun_MG(abs_amg, AMGf_numeric); 3011 { 3012 SV * const sv = TOPs; 3013 /* This will cache the NV value if string isn't actually integer */ 3014 const IV iv = SvIV_nomg(sv); 3015 3016 if (!SvOK(sv)) { 3017 SETu(0); 3018 } 3019 else if (SvIOK(sv)) { 3020 /* IVX is precise */ 3021 if (SvIsUV(sv)) { 3022 SETu(SvUV_nomg(sv)); /* force it to be numeric only */ 3023 } else { 3024 if (iv >= 0) { 3025 SETi(iv); 3026 } else { 3027 if (iv != IV_MIN) { 3028 SETi(-iv); 3029 } else { 3030 /* 2s complement assumption. Also, not really needed as 3031 IV_MIN and -IV_MIN should both be %100...00 and NV-able */ 3032 SETu((UV)IV_MIN); 3033 } 3034 } 3035 } 3036 } else{ 3037 const NV value = SvNV_nomg(sv); 3038 if (value < 0.0) 3039 SETn(-value); 3040 else 3041 SETn(value); 3042 } 3043 } 3044 return NORMAL; 3045 } 3046 3047 3048 /* also used for: pp_hex() */ 3049 3050 PP(pp_oct) 3051 { 3052 dSP; dTARGET; 3053 const char *tmps; 3054 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES; 3055 STRLEN len; 3056 NV result_nv; 3057 UV result_uv; 3058 SV* const sv = TOPs; 3059 3060 tmps = (SvPV_const(sv, len)); 3061 if (DO_UTF8(sv)) { 3062 /* If Unicode, try to downgrade 3063 * If not possible, croak. */ 3064 SV* const tsv = sv_2mortal(newSVsv(sv)); 3065 3066 SvUTF8_on(tsv); 3067 sv_utf8_downgrade(tsv, FALSE); 3068 tmps = SvPV_const(tsv, len); 3069 } 3070 if (PL_op->op_type == OP_HEX) 3071 goto hex; 3072 3073 while (*tmps && len && isSPACE(*tmps)) 3074 tmps++, len--; 3075 if (*tmps == '0') 3076 tmps++, len--; 3077 if (isALPHA_FOLD_EQ(*tmps, 'x')) { 3078 hex: 3079 result_uv = grok_hex (tmps, &len, &flags, &result_nv); 3080 } 3081 else if (isALPHA_FOLD_EQ(*tmps, 'b')) 3082 result_uv = grok_bin (tmps, &len, &flags, &result_nv); 3083 else 3084 result_uv = grok_oct (tmps, &len, &flags, &result_nv); 3085 3086 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) { 3087 SETn(result_nv); 3088 } 3089 else { 3090 SETu(result_uv); 3091 } 3092 return NORMAL; 3093 } 3094 3095 /* String stuff. */ 3096 3097 3098 PP(pp_length) 3099 { 3100 dSP; dTARGET; 3101 SV * const sv = TOPs; 3102 3103 U32 in_bytes = IN_BYTES; 3104 /* Simplest case shortcut: 3105 * set svflags to just the SVf_POK|SVs_GMG|SVf_UTF8 from the SV, 3106 * with the SVf_UTF8 flag inverted if under 'use bytes' (HINT_BYTES 3107 * set) 3108 */ 3109 U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8); 3110 3111 STATIC_ASSERT_STMT(SVf_UTF8 == (HINT_BYTES << 26)); 3112 SETs(TARG); 3113 3114 if (LIKELY(svflags == SVf_POK)) 3115 goto simple_pv; 3116 3117 if (svflags & SVs_GMG) 3118 mg_get(sv); 3119 3120 if (SvOK(sv)) { 3121 STRLEN len; 3122 if (!IN_BYTES) { /* reread to avoid using an C auto/register */ 3123 if ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == SVf_POK) 3124 goto simple_pv; 3125 if ( SvPOK(sv) && (PL_op->op_private & OPpTRUEBOOL)) { 3126 /* no need to convert from bytes to chars */ 3127 len = SvCUR(sv); 3128 goto return_bool; 3129 } 3130 len = sv_len_utf8_nomg(sv); 3131 } 3132 else { 3133 /* unrolled SvPV_nomg_const(sv,len) */ 3134 if (SvPOK_nog(sv)) { 3135 simple_pv: 3136 len = SvCUR(sv); 3137 if (PL_op->op_private & OPpTRUEBOOL) { 3138 return_bool: 3139 SETs(len ? &PL_sv_yes : &PL_sv_zero); 3140 return NORMAL; 3141 } 3142 } 3143 else { 3144 (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN); 3145 } 3146 } 3147 TARGi((IV)(len), 1); 3148 } 3149 else { 3150 if (!SvPADTMP(TARG)) { 3151 /* OPpTARGET_MY: targ is var in '$lex = length()' */ 3152 sv_set_undef(TARG); 3153 SvSETMAGIC(TARG); 3154 } 3155 else 3156 /* TARG is on stack at this point and is overwriten by SETs. 3157 * This branch is the odd one out, so put TARG by default on 3158 * stack earlier to let local SP go out of liveness sooner */ 3159 SETs(&PL_sv_undef); 3160 } 3161 return NORMAL; /* no putback, SP didn't move in this opcode */ 3162 } 3163 3164 3165 /* Returns false if substring is completely outside original string. 3166 No length is indicated by len_iv = 0 and len_is_uv = 0. len_is_uv must 3167 always be true for an explicit 0. 3168 */ 3169 bool 3170 Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv, 3171 bool pos1_is_uv, IV len_iv, 3172 bool len_is_uv, STRLEN *posp, 3173 STRLEN *lenp) 3174 { 3175 IV pos2_iv; 3176 int pos2_is_uv; 3177 3178 PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS; 3179 3180 if (!pos1_is_uv && pos1_iv < 0 && curlen) { 3181 pos1_is_uv = curlen-1 > ~(UV)pos1_iv; 3182 pos1_iv += curlen; 3183 } 3184 if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen) 3185 return FALSE; 3186 3187 if (len_iv || len_is_uv) { 3188 if (!len_is_uv && len_iv < 0) { 3189 pos2_iv = curlen + len_iv; 3190 if (curlen) 3191 pos2_is_uv = curlen-1 > ~(UV)len_iv; 3192 else 3193 pos2_is_uv = 0; 3194 } else { /* len_iv >= 0 */ 3195 if (!pos1_is_uv && pos1_iv < 0) { 3196 pos2_iv = pos1_iv + len_iv; 3197 pos2_is_uv = (UV)len_iv > (UV)IV_MAX; 3198 } else { 3199 if ((UV)len_iv > curlen-(UV)pos1_iv) 3200 pos2_iv = curlen; 3201 else 3202 pos2_iv = pos1_iv+len_iv; 3203 pos2_is_uv = 1; 3204 } 3205 } 3206 } 3207 else { 3208 pos2_iv = curlen; 3209 pos2_is_uv = 1; 3210 } 3211 3212 if (!pos2_is_uv && pos2_iv < 0) { 3213 if (!pos1_is_uv && pos1_iv < 0) 3214 return FALSE; 3215 pos2_iv = 0; 3216 } 3217 else if (!pos1_is_uv && pos1_iv < 0) 3218 pos1_iv = 0; 3219 3220 if ((UV)pos2_iv < (UV)pos1_iv) 3221 pos2_iv = pos1_iv; 3222 if ((UV)pos2_iv > curlen) 3223 pos2_iv = curlen; 3224 3225 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */ 3226 *posp = (STRLEN)( (UV)pos1_iv ); 3227 *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv ); 3228 3229 return TRUE; 3230 } 3231 3232 PP(pp_substr) 3233 { 3234 dSP; dTARGET; 3235 SV *sv; 3236 STRLEN curlen; 3237 STRLEN utf8_curlen; 3238 SV * pos_sv; 3239 IV pos1_iv; 3240 int pos1_is_uv; 3241 SV * len_sv; 3242 IV len_iv = 0; 3243 int len_is_uv = 0; 3244 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET; 3245 const bool rvalue = (GIMME_V != G_VOID); 3246 const char *tmps; 3247 SV *repl_sv = NULL; 3248 const char *repl = NULL; 3249 STRLEN repl_len; 3250 int num_args = PL_op->op_private & 7; 3251 bool repl_need_utf8_upgrade = FALSE; 3252 3253 if (num_args > 2) { 3254 if (num_args > 3) { 3255 if(!(repl_sv = POPs)) num_args--; 3256 } 3257 if ((len_sv = POPs)) { 3258 len_iv = SvIV(len_sv); 3259 len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1; 3260 } 3261 else num_args--; 3262 } 3263 pos_sv = POPs; 3264 pos1_iv = SvIV(pos_sv); 3265 pos1_is_uv = SvIOK_UV(pos_sv); 3266 sv = POPs; 3267 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) { 3268 assert(!repl_sv); 3269 repl_sv = POPs; 3270 } 3271 if (lvalue && !repl_sv) { 3272 SV * ret; 3273 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */ 3274 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0); 3275 LvTYPE(ret) = 'x'; 3276 LvTARG(ret) = SvREFCNT_inc_simple(sv); 3277 LvTARGOFF(ret) = 3278 pos1_is_uv || pos1_iv >= 0 3279 ? (STRLEN)(UV)pos1_iv 3280 : (LvFLAGS(ret) |= LVf_NEG_OFF, (STRLEN)(UV)-pos1_iv); 3281 LvTARGLEN(ret) = 3282 len_is_uv || len_iv > 0 3283 ? (STRLEN)(UV)len_iv 3284 : (LvFLAGS(ret) |= LVf_NEG_LEN, (STRLEN)(UV)-len_iv); 3285 3286 PUSHs(ret); /* avoid SvSETMAGIC here */ 3287 RETURN; 3288 } 3289 if (repl_sv) { 3290 repl = SvPV_const(repl_sv, repl_len); 3291 SvGETMAGIC(sv); 3292 if (SvROK(sv)) 3293 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), 3294 "Attempt to use reference as lvalue in substr" 3295 ); 3296 tmps = SvPV_force_nomg(sv, curlen); 3297 if (DO_UTF8(repl_sv) && repl_len) { 3298 if (!DO_UTF8(sv)) { 3299 /* Upgrade the dest, and recalculate tmps in case the buffer 3300 * got reallocated; curlen may also have been changed */ 3301 sv_utf8_upgrade_nomg(sv); 3302 tmps = SvPV_nomg(sv, curlen); 3303 } 3304 } 3305 else if (DO_UTF8(sv)) 3306 repl_need_utf8_upgrade = TRUE; 3307 } 3308 else tmps = SvPV_const(sv, curlen); 3309 if (DO_UTF8(sv)) { 3310 utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen); 3311 if (utf8_curlen == curlen) 3312 utf8_curlen = 0; 3313 else 3314 curlen = utf8_curlen; 3315 } 3316 else 3317 utf8_curlen = 0; 3318 3319 { 3320 STRLEN pos, len, byte_len, byte_pos; 3321 3322 if (!translate_substr_offsets( 3323 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len 3324 )) goto bound_fail; 3325 3326 byte_len = len; 3327 byte_pos = utf8_curlen 3328 ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos; 3329 3330 tmps += byte_pos; 3331 3332 if (rvalue) { 3333 SvTAINTED_off(TARG); /* decontaminate */ 3334 SvUTF8_off(TARG); /* decontaminate */ 3335 sv_setpvn(TARG, tmps, byte_len); 3336 #ifdef USE_LOCALE_COLLATE 3337 sv_unmagic(TARG, PERL_MAGIC_collxfrm); 3338 #endif 3339 if (utf8_curlen) 3340 SvUTF8_on(TARG); 3341 } 3342 3343 if (repl) { 3344 SV* repl_sv_copy = NULL; 3345 3346 if (repl_need_utf8_upgrade) { 3347 repl_sv_copy = newSVsv(repl_sv); 3348 sv_utf8_upgrade(repl_sv_copy); 3349 repl = SvPV_const(repl_sv_copy, repl_len); 3350 } 3351 if (!SvOK(sv)) 3352 SvPVCLEAR(sv); 3353 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0); 3354 SvREFCNT_dec(repl_sv_copy); 3355 } 3356 } 3357 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) 3358 SP++; 3359 else if (rvalue) { 3360 SvSETMAGIC(TARG); 3361 PUSHs(TARG); 3362 } 3363 RETURN; 3364 3365 bound_fail: 3366 if (repl) 3367 Perl_croak(aTHX_ "substr outside of string"); 3368 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string"); 3369 RETPUSHUNDEF; 3370 } 3371 3372 PP(pp_vec) 3373 { 3374 dSP; 3375 const IV size = POPi; 3376 SV* offsetsv = POPs; 3377 SV * const src = POPs; 3378 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET; 3379 SV * ret; 3380 UV retuv; 3381 STRLEN offset = 0; 3382 char errflags = 0; 3383 3384 /* extract a STRLEN-ranged integer value from offsetsv into offset, 3385 * or flag that its out of range */ 3386 { 3387 IV iv = SvIV(offsetsv); 3388 3389 /* avoid a large UV being wrapped to a negative value */ 3390 if (SvIOK_UV(offsetsv) && SvUVX(offsetsv) > (UV)IV_MAX) 3391 errflags = LVf_OUT_OF_RANGE; 3392 else if (iv < 0) 3393 errflags = (LVf_NEG_OFF|LVf_OUT_OF_RANGE); 3394 #if PTRSIZE < IVSIZE 3395 else if (iv > Size_t_MAX) 3396 errflags = LVf_OUT_OF_RANGE; 3397 #endif 3398 else 3399 offset = (STRLEN)iv; 3400 } 3401 3402 retuv = errflags ? 0 : do_vecget(src, offset, size); 3403 3404 if (lvalue) { /* it's an lvalue! */ 3405 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */ 3406 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0); 3407 LvTYPE(ret) = 'v'; 3408 LvTARG(ret) = SvREFCNT_inc_simple(src); 3409 LvTARGOFF(ret) = offset; 3410 LvTARGLEN(ret) = size; 3411 LvFLAGS(ret) = errflags; 3412 } 3413 else { 3414 dTARGET; 3415 SvTAINTED_off(TARG); /* decontaminate */ 3416 ret = TARG; 3417 } 3418 3419 sv_setuv(ret, retuv); 3420 if (!lvalue) 3421 SvSETMAGIC(ret); 3422 PUSHs(ret); 3423 RETURN; 3424 } 3425 3426 3427 /* also used for: pp_rindex() */ 3428 3429 PP(pp_index) 3430 { 3431 dSP; dTARGET; 3432 SV *big; 3433 SV *little; 3434 SV *temp = NULL; 3435 STRLEN biglen; 3436 STRLEN llen = 0; 3437 SSize_t offset = 0; 3438 SSize_t retval; 3439 const char *big_p; 3440 const char *little_p; 3441 bool big_utf8; 3442 bool little_utf8; 3443 const bool is_index = PL_op->op_type == OP_INDEX; 3444 const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0)); 3445 3446 if (threeargs) 3447 offset = POPi; 3448 little = POPs; 3449 big = POPs; 3450 big_p = SvPV_const(big, biglen); 3451 little_p = SvPV_const(little, llen); 3452 3453 big_utf8 = DO_UTF8(big); 3454 little_utf8 = DO_UTF8(little); 3455 if (big_utf8 ^ little_utf8) { 3456 /* One needs to be upgraded. */ 3457 if (little_utf8) { 3458 /* Well, maybe instead we might be able to downgrade the small 3459 string? */ 3460 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen, 3461 &little_utf8); 3462 if (little_utf8) { 3463 /* If the large string is ISO-8859-1, and it's not possible to 3464 convert the small string to ISO-8859-1, then there is no 3465 way that it could be found anywhere by index. */ 3466 retval = -1; 3467 goto push_result; 3468 } 3469 3470 /* At this point, pv is a malloc()ed string. So donate it to temp 3471 to ensure it will get free()d */ 3472 little = temp = newSV(0); 3473 sv_usepvn(temp, pv, llen); 3474 little_p = SvPVX(little); 3475 } else { 3476 temp = newSVpvn(little_p, llen); 3477 3478 sv_utf8_upgrade(temp); 3479 little = temp; 3480 little_p = SvPV_const(little, llen); 3481 } 3482 } 3483 if (SvGAMAGIC(big)) { 3484 /* Life just becomes a lot easier if I use a temporary here. 3485 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously) 3486 will trigger magic and overloading again, as will fbm_instr() 3487 */ 3488 big = newSVpvn_flags(big_p, biglen, 3489 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0)); 3490 big_p = SvPVX(big); 3491 } 3492 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) { 3493 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will 3494 warn on undef, and we've already triggered a warning with the 3495 SvPV_const some lines above. We can't remove that, as we need to 3496 call some SvPV to trigger overloading early and find out if the 3497 string is UTF-8. 3498 This is all getting too messy. The API isn't quite clean enough, 3499 because data access has side effects. 3500 */ 3501 little = newSVpvn_flags(little_p, llen, 3502 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0)); 3503 little_p = SvPVX(little); 3504 } 3505 3506 if (!threeargs) 3507 offset = is_index ? 0 : biglen; 3508 else { 3509 if (big_utf8 && offset > 0) 3510 offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN); 3511 if (!is_index) 3512 offset += llen; 3513 } 3514 if (offset < 0) 3515 offset = 0; 3516 else if (offset > (SSize_t)biglen) 3517 offset = biglen; 3518 if (!(little_p = is_index 3519 ? fbm_instr((unsigned char*)big_p + offset, 3520 (unsigned char*)big_p + biglen, little, 0) 3521 : rninstr(big_p, big_p + offset, 3522 little_p, little_p + llen))) 3523 retval = -1; 3524 else { 3525 retval = little_p - big_p; 3526 if (retval > 1 && big_utf8) 3527 retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN); 3528 } 3529 SvREFCNT_dec(temp); 3530 3531 push_result: 3532 /* OPpTRUEBOOL indicates an '== -1' has been optimised away */ 3533 if (PL_op->op_private & OPpTRUEBOOL) { 3534 PUSHs( ((retval != -1) ^ cBOOL(PL_op->op_private & OPpINDEX_BOOLNEG)) 3535 ? &PL_sv_yes : &PL_sv_no); 3536 if (PL_op->op_private & OPpTARGET_MY) 3537 /* $lex = (index() == -1) */ 3538 sv_setsv(TARG, TOPs); 3539 } 3540 else 3541 PUSHi(retval); 3542 RETURN; 3543 } 3544 3545 PP(pp_sprintf) 3546 { 3547 dSP; dMARK; dORIGMARK; dTARGET; 3548 SvTAINTED_off(TARG); 3549 do_sprintf(TARG, SP-MARK, MARK+1); 3550 TAINT_IF(SvTAINTED(TARG)); 3551 SP = ORIGMARK; 3552 PUSHTARG; 3553 RETURN; 3554 } 3555 3556 PP(pp_ord) 3557 { 3558 dSP; dTARGET; 3559 3560 SV *argsv = TOPs; 3561 STRLEN len; 3562 const U8 *s = (U8*)SvPV_const(argsv, len); 3563 3564 SETu(DO_UTF8(argsv) 3565 ? (len ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV) : 0) 3566 : (UV)(*s)); 3567 3568 return NORMAL; 3569 } 3570 3571 PP(pp_chr) 3572 { 3573 dSP; dTARGET; 3574 char *tmps; 3575 UV value; 3576 SV *top = TOPs; 3577 3578 SvGETMAGIC(top); 3579 if (UNLIKELY(SvAMAGIC(top))) 3580 top = sv_2num(top); 3581 if (UNLIKELY(isinfnansv(top))) 3582 Perl_croak(aTHX_ "Cannot chr %" NVgf, SvNV(top)); 3583 else { 3584 if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */ 3585 && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0) 3586 || 3587 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top))) 3588 && SvNV_nomg(top) < 0.0))) 3589 { 3590 if (ckWARN(WARN_UTF8)) { 3591 if (SvGMAGICAL(top)) { 3592 SV *top2 = sv_newmortal(); 3593 sv_setsv_nomg(top2, top); 3594 top = top2; 3595 } 3596 Perl_warner(aTHX_ packWARN(WARN_UTF8), 3597 "Invalid negative number (%" SVf ") in chr", SVfARG(top)); 3598 } 3599 value = UNICODE_REPLACEMENT; 3600 } else { 3601 value = SvUV_nomg(top); 3602 } 3603 } 3604 3605 SvUPGRADE(TARG,SVt_PV); 3606 3607 if (value > 255 && !IN_BYTES) { 3608 SvGROW(TARG, (STRLEN)UVCHR_SKIP(value)+1); 3609 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0); 3610 SvCUR_set(TARG, tmps - SvPVX_const(TARG)); 3611 *tmps = '\0'; 3612 (void)SvPOK_only(TARG); 3613 SvUTF8_on(TARG); 3614 SETTARG; 3615 return NORMAL; 3616 } 3617 3618 SvGROW(TARG,2); 3619 SvCUR_set(TARG, 1); 3620 tmps = SvPVX(TARG); 3621 *tmps++ = (char)value; 3622 *tmps = '\0'; 3623 (void)SvPOK_only(TARG); 3624 3625 SETTARG; 3626 return NORMAL; 3627 } 3628 3629 PP(pp_crypt) 3630 { 3631 #ifdef HAS_CRYPT 3632 dSP; dTARGET; 3633 dPOPTOPssrl; 3634 STRLEN len; 3635 const char *tmps = SvPV_const(left, len); 3636 3637 if (DO_UTF8(left)) { 3638 /* If Unicode, try to downgrade. 3639 * If not possible, croak. 3640 * Yes, we made this up. */ 3641 SV* const tsv = newSVpvn_flags(tmps, len, SVf_UTF8|SVs_TEMP); 3642 3643 sv_utf8_downgrade(tsv, FALSE); 3644 tmps = SvPV_const(tsv, len); 3645 } 3646 # ifdef USE_ITHREADS 3647 # ifdef HAS_CRYPT_R 3648 if (!PL_reentrant_buffer->_crypt_struct_buffer) { 3649 /* This should be threadsafe because in ithreads there is only 3650 * one thread per interpreter. If this would not be true, 3651 * we would need a mutex to protect this malloc. */ 3652 PL_reentrant_buffer->_crypt_struct_buffer = 3653 (struct crypt_data *)safemalloc(sizeof(struct crypt_data)); 3654 #if defined(__GLIBC__) || defined(__EMX__) 3655 if (PL_reentrant_buffer->_crypt_struct_buffer) { 3656 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0; 3657 #if (defined(__GLIBC__) && __GLIBC__ == 2) && \ 3658 (defined(__GLIBC_MINOR__) && __GLIBC_MINOR__ >= 2 && __GLIBC_MINOR__ < 4) 3659 /* work around glibc-2.2.5 bug, has been fixed at some 3660 * time in glibc-2.3.X */ 3661 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0; 3662 #endif 3663 } 3664 #endif 3665 } 3666 # endif /* HAS_CRYPT_R */ 3667 # endif /* USE_ITHREADS */ 3668 # ifdef FCRYPT 3669 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right))); 3670 # else 3671 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right))); 3672 # endif 3673 SvUTF8_off(TARG); 3674 SETTARG; 3675 RETURN; 3676 #else 3677 DIE(aTHX_ 3678 "The crypt() function is unimplemented due to excessive paranoia."); 3679 #endif 3680 } 3681 3682 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So 3683 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */ 3684 3685 3686 /* also used for: pp_lcfirst() */ 3687 3688 PP(pp_ucfirst) 3689 { 3690 /* Actually is both lcfirst() and ucfirst(). Only the first character 3691 * changes. This means that possibly we can change in-place, ie., just 3692 * take the source and change that one character and store it back, but not 3693 * if read-only etc, or if the length changes */ 3694 3695 dSP; 3696 SV *source = TOPs; 3697 STRLEN slen; /* slen is the byte length of the whole SV. */ 3698 STRLEN need; 3699 SV *dest; 3700 bool inplace; /* ? Convert first char only, in-place */ 3701 bool doing_utf8 = FALSE; /* ? using utf8 */ 3702 bool convert_source_to_utf8 = FALSE; /* ? need to convert */ 3703 const int op_type = PL_op->op_type; 3704 const U8 *s; 3705 U8 *d; 3706 U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; 3707 STRLEN ulen; /* ulen is the byte length of the original Unicode character 3708 * stored as UTF-8 at s. */ 3709 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or 3710 * lowercased) character stored in tmpbuf. May be either 3711 * UTF-8 or not, but in either case is the number of bytes */ 3712 3713 s = (const U8*)SvPV_const(source, slen); 3714 3715 /* We may be able to get away with changing only the first character, in 3716 * place, but not if read-only, etc. Later we may discover more reasons to 3717 * not convert in-place. */ 3718 inplace = !SvREADONLY(source) && SvPADTMP(source); 3719 3720 #ifdef USE_LOCALE_CTYPE 3721 3722 if (IN_LC_RUNTIME(LC_CTYPE)) { 3723 _CHECK_AND_WARN_PROBLEMATIC_LOCALE; 3724 } 3725 3726 #endif 3727 3728 /* First calculate what the changed first character should be. This affects 3729 * whether we can just swap it out, leaving the rest of the string unchanged, 3730 * or even if have to convert the dest to UTF-8 when the source isn't */ 3731 3732 if (! slen) { /* If empty */ 3733 need = 1; /* still need a trailing NUL */ 3734 ulen = 0; 3735 *tmpbuf = '\0'; 3736 } 3737 else if (DO_UTF8(source)) { /* Is the source utf8? */ 3738 doing_utf8 = TRUE; 3739 ulen = UTF8SKIP(s); 3740 if (op_type == OP_UCFIRST) { 3741 #ifdef USE_LOCALE_CTYPE 3742 _toTITLE_utf8_flags(s, s +slen, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE)); 3743 #else 3744 _toTITLE_utf8_flags(s, s +slen, tmpbuf, &tculen, 0); 3745 #endif 3746 } 3747 else { 3748 #ifdef USE_LOCALE_CTYPE 3749 _toLOWER_utf8_flags(s, s + slen, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE)); 3750 #else 3751 _toLOWER_utf8_flags(s, s + slen, tmpbuf, &tculen, 0); 3752 #endif 3753 } 3754 3755 /* we can't do in-place if the length changes. */ 3756 if (ulen != tculen) inplace = FALSE; 3757 need = slen + 1 - ulen + tculen; 3758 } 3759 else { /* Non-zero length, non-UTF-8, Need to consider locale and if 3760 * latin1 is treated as caseless. Note that a locale takes 3761 * precedence */ 3762 ulen = 1; /* Original character is 1 byte */ 3763 tculen = 1; /* Most characters will require one byte, but this will 3764 * need to be overridden for the tricky ones */ 3765 need = slen + 1; 3766 3767 if (op_type == OP_LCFIRST) { 3768 3769 /* lower case the first letter: no trickiness for any character */ 3770 #ifdef USE_LOCALE_CTYPE 3771 if (IN_LC_RUNTIME(LC_CTYPE)) { 3772 *tmpbuf = toLOWER_LC(*s); 3773 } 3774 else 3775 #endif 3776 { 3777 *tmpbuf = (IN_UNI_8_BIT) 3778 ? toLOWER_LATIN1(*s) 3779 : toLOWER(*s); 3780 } 3781 } 3782 #ifdef USE_LOCALE_CTYPE 3783 /* is ucfirst() */ 3784 else if (IN_LC_RUNTIME(LC_CTYPE)) { 3785 if (IN_UTF8_CTYPE_LOCALE) { 3786 goto do_uni_rules; 3787 } 3788 3789 *tmpbuf = (U8) toUPPER_LC(*s); /* This would be a bug if any 3790 locales have upper and title case 3791 different */ 3792 } 3793 #endif 3794 else if (! IN_UNI_8_BIT) { 3795 *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or 3796 * on EBCDIC machines whatever the 3797 * native function does */ 3798 } 3799 else { 3800 /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is 3801 * UTF-8, which we treat as not in locale), and cased latin1 */ 3802 UV title_ord; 3803 #ifdef USE_LOCALE_CTYPE 3804 do_uni_rules: 3805 #endif 3806 3807 title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's'); 3808 if (tculen > 1) { 3809 assert(tculen == 2); 3810 3811 /* If the result is an upper Latin1-range character, it can 3812 * still be represented in one byte, which is its ordinal */ 3813 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) { 3814 *tmpbuf = (U8) title_ord; 3815 tculen = 1; 3816 } 3817 else { 3818 /* Otherwise it became more than one ASCII character (in 3819 * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to 3820 * beyond Latin1, so the number of bytes changed, so can't 3821 * replace just the first character in place. */ 3822 inplace = FALSE; 3823 3824 /* If the result won't fit in a byte, the entire result 3825 * will have to be in UTF-8. Assume worst case sizing in 3826 * conversion. (all latin1 characters occupy at most two 3827 * bytes in utf8) */ 3828 if (title_ord > 255) { 3829 doing_utf8 = TRUE; 3830 convert_source_to_utf8 = TRUE; 3831 need = slen * 2 + 1; 3832 3833 /* The (converted) UTF-8 and UTF-EBCDIC lengths of all 3834 * (both) characters whose title case is above 255 is 3835 * 2. */ 3836 ulen = 2; 3837 } 3838 else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */ 3839 need = slen + 1 + 1; 3840 } 3841 } 3842 } 3843 } /* End of use Unicode (Latin1) semantics */ 3844 } /* End of changing the case of the first character */ 3845 3846 /* Here, have the first character's changed case stored in tmpbuf. Ready to 3847 * generate the result */ 3848 if (inplace) { 3849 3850 /* We can convert in place. This means we change just the first 3851 * character without disturbing the rest; no need to grow */ 3852 dest = source; 3853 s = d = (U8*)SvPV_force_nomg(source, slen); 3854 } else { 3855 dTARGET; 3856 3857 dest = TARG; 3858 3859 /* Here, we can't convert in place; we earlier calculated how much 3860 * space we will need, so grow to accommodate that */ 3861 SvUPGRADE(dest, SVt_PV); 3862 d = (U8*)SvGROW(dest, need); 3863 (void)SvPOK_only(dest); 3864 3865 SETs(dest); 3866 } 3867 3868 if (doing_utf8) { 3869 if (! inplace) { 3870 if (! convert_source_to_utf8) { 3871 3872 /* Here both source and dest are in UTF-8, but have to create 3873 * the entire output. We initialize the result to be the 3874 * title/lower cased first character, and then append the rest 3875 * of the string. */ 3876 sv_setpvn(dest, (char*)tmpbuf, tculen); 3877 if (slen > ulen) { 3878 sv_catpvn(dest, (char*)(s + ulen), slen - ulen); 3879 } 3880 } 3881 else { 3882 const U8 *const send = s + slen; 3883 3884 /* Here the dest needs to be in UTF-8, but the source isn't, 3885 * except we earlier UTF-8'd the first character of the source 3886 * into tmpbuf. First put that into dest, and then append the 3887 * rest of the source, converting it to UTF-8 as we go. */ 3888 3889 /* Assert tculen is 2 here because the only two characters that 3890 * get to this part of the code have 2-byte UTF-8 equivalents */ 3891 *d++ = *tmpbuf; 3892 *d++ = *(tmpbuf + 1); 3893 s++; /* We have just processed the 1st char */ 3894 3895 for (; s < send; s++) { 3896 d = uvchr_to_utf8(d, *s); 3897 } 3898 *d = '\0'; 3899 SvCUR_set(dest, d - (U8*)SvPVX_const(dest)); 3900 } 3901 SvUTF8_on(dest); 3902 } 3903 else { /* in-place UTF-8. Just overwrite the first character */ 3904 Copy(tmpbuf, d, tculen, U8); 3905 SvCUR_set(dest, need - 1); 3906 } 3907 3908 } 3909 else { /* Neither source nor dest are in or need to be UTF-8 */ 3910 if (slen) { 3911 if (inplace) { /* in-place, only need to change the 1st char */ 3912 *d = *tmpbuf; 3913 } 3914 else { /* Not in-place */ 3915 3916 /* Copy the case-changed character(s) from tmpbuf */ 3917 Copy(tmpbuf, d, tculen, U8); 3918 d += tculen - 1; /* Code below expects d to point to final 3919 * character stored */ 3920 } 3921 } 3922 else { /* empty source */ 3923 /* See bug #39028: Don't taint if empty */ 3924 *d = *s; 3925 } 3926 3927 /* In a "use bytes" we don't treat the source as UTF-8, but, still want 3928 * the destination to retain that flag */ 3929 if (SvUTF8(source) && ! IN_BYTES) 3930 SvUTF8_on(dest); 3931 3932 if (!inplace) { /* Finish the rest of the string, unchanged */ 3933 /* This will copy the trailing NUL */ 3934 Copy(s + 1, d + 1, slen, U8); 3935 SvCUR_set(dest, need - 1); 3936 } 3937 } 3938 #ifdef USE_LOCALE_CTYPE 3939 if (IN_LC_RUNTIME(LC_CTYPE)) { 3940 TAINT; 3941 SvTAINTED_on(dest); 3942 } 3943 #endif 3944 if (dest != source && SvTAINTED(source)) 3945 SvTAINT(dest); 3946 SvSETMAGIC(dest); 3947 return NORMAL; 3948 } 3949 3950 /* There's so much setup/teardown code common between uc and lc, I wonder if 3951 it would be worth merging the two, and just having a switch outside each 3952 of the three tight loops. There is less and less commonality though */ 3953 PP(pp_uc) 3954 { 3955 dSP; 3956 SV *source = TOPs; 3957 STRLEN len; 3958 STRLEN min; 3959 SV *dest; 3960 const U8 *s; 3961 U8 *d; 3962 3963 SvGETMAGIC(source); 3964 3965 if ( SvPADTMP(source) 3966 && !SvREADONLY(source) && SvPOK(source) 3967 && !DO_UTF8(source) 3968 && ( 3969 #ifdef USE_LOCALE_CTYPE 3970 (IN_LC_RUNTIME(LC_CTYPE)) 3971 ? ! IN_UTF8_CTYPE_LOCALE 3972 : 3973 #endif 3974 ! IN_UNI_8_BIT)) 3975 { 3976 3977 /* We can convert in place. The reason we can't if in UNI_8_BIT is to 3978 * make the loop tight, so we overwrite the source with the dest before 3979 * looking at it, and we need to look at the original source 3980 * afterwards. There would also need to be code added to handle 3981 * switching to not in-place in midstream if we run into characters 3982 * that change the length. Since being in locale overrides UNI_8_BIT, 3983 * that latter becomes irrelevant in the above test; instead for 3984 * locale, the size can't normally change, except if the locale is a 3985 * UTF-8 one */ 3986 dest = source; 3987 s = d = (U8*)SvPV_force_nomg(source, len); 3988 min = len + 1; 3989 } else { 3990 dTARGET; 3991 3992 dest = TARG; 3993 3994 s = (const U8*)SvPV_nomg_const(source, len); 3995 min = len + 1; 3996 3997 SvUPGRADE(dest, SVt_PV); 3998 d = (U8*)SvGROW(dest, min); 3999 (void)SvPOK_only(dest); 4000 4001 SETs(dest); 4002 } 4003 4004 #ifdef USE_LOCALE_CTYPE 4005 4006 if (IN_LC_RUNTIME(LC_CTYPE)) { 4007 _CHECK_AND_WARN_PROBLEMATIC_LOCALE; 4008 } 4009 4010 #endif 4011 4012 /* Overloaded values may have toggled the UTF-8 flag on source, so we need 4013 to check DO_UTF8 again here. */ 4014 4015 if (DO_UTF8(source)) { 4016 const U8 *const send = s + len; 4017 U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; 4018 4019 /* All occurrences of these are to be moved to follow any other marks. 4020 * This is context-dependent. We may not be passed enough context to 4021 * move the iota subscript beyond all of them, but we do the best we can 4022 * with what we're given. The result is always better than if we 4023 * hadn't done this. And, the problem would only arise if we are 4024 * passed a character without all its combining marks, which would be 4025 * the caller's mistake. The information this is based on comes from a 4026 * comment in Unicode SpecialCasing.txt, (and the Standard's text 4027 * itself) and so can't be checked properly to see if it ever gets 4028 * revised. But the likelihood of it changing is remote */ 4029 bool in_iota_subscript = FALSE; 4030 4031 while (s < send) { 4032 STRLEN u; 4033 STRLEN ulen; 4034 UV uv; 4035 if (in_iota_subscript && ! _is_utf8_mark(s)) { 4036 4037 /* A non-mark. Time to output the iota subscript */ 4038 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8); 4039 d += capital_iota_len; 4040 in_iota_subscript = FALSE; 4041 } 4042 4043 /* Then handle the current character. Get the changed case value 4044 * and copy it to the output buffer */ 4045 4046 u = UTF8SKIP(s); 4047 #ifdef USE_LOCALE_CTYPE 4048 uv = _toUPPER_utf8_flags(s, send, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE)); 4049 #else 4050 uv = _toUPPER_utf8_flags(s, send, tmpbuf, &ulen, 0); 4051 #endif 4052 #define GREEK_CAPITAL_LETTER_IOTA 0x0399 4053 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345 4054 if (uv == GREEK_CAPITAL_LETTER_IOTA 4055 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI) 4056 { 4057 in_iota_subscript = TRUE; 4058 } 4059 else { 4060 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) { 4061 /* If the eventually required minimum size outgrows the 4062 * available space, we need to grow. */ 4063 const UV o = d - (U8*)SvPVX_const(dest); 4064 4065 /* If someone uppercases one million U+03B0s we SvGROW() 4066 * one million times. Or we could try guessing how much to 4067 * allocate without allocating too much. Such is life. 4068 * See corresponding comment in lc code for another option 4069 * */ 4070 d = o + (U8*) SvGROW(dest, min); 4071 } 4072 Copy(tmpbuf, d, ulen, U8); 4073 d += ulen; 4074 } 4075 s += u; 4076 } 4077 if (in_iota_subscript) { 4078 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8); 4079 d += capital_iota_len; 4080 } 4081 SvUTF8_on(dest); 4082 *d = '\0'; 4083 4084 SvCUR_set(dest, d - (U8*)SvPVX_const(dest)); 4085 } 4086 else { /* Not UTF-8 */ 4087 if (len) { 4088 const U8 *const send = s + len; 4089 4090 /* Use locale casing if in locale; regular style if not treating 4091 * latin1 as having case; otherwise the latin1 casing. Do the 4092 * whole thing in a tight loop, for speed, */ 4093 #ifdef USE_LOCALE_CTYPE 4094 if (IN_LC_RUNTIME(LC_CTYPE)) { 4095 if (IN_UTF8_CTYPE_LOCALE) { 4096 goto do_uni_rules; 4097 } 4098 for (; s < send; d++, s++) 4099 *d = (U8) toUPPER_LC(*s); 4100 } 4101 else 4102 #endif 4103 if (! IN_UNI_8_BIT) { 4104 for (; s < send; d++, s++) { 4105 *d = toUPPER(*s); 4106 } 4107 } 4108 else { 4109 #ifdef USE_LOCALE_CTYPE 4110 do_uni_rules: 4111 #endif 4112 for (; s < send; d++, s++) { 4113 *d = toUPPER_LATIN1_MOD(*s); 4114 if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) { 4115 continue; 4116 } 4117 4118 /* The mainstream case is the tight loop above. To avoid 4119 * extra tests in that, all three characters that require 4120 * special handling are mapped by the MOD to the one tested 4121 * just above. 4122 * Use the source to distinguish between the three cases */ 4123 4124 #if UNICODE_MAJOR_VERSION > 2 \ 4125 || (UNICODE_MAJOR_VERSION == 2 && UNICODE_DOT_VERSION >= 1 \ 4126 && UNICODE_DOT_DOT_VERSION >= 8) 4127 if (*s == LATIN_SMALL_LETTER_SHARP_S) { 4128 4129 /* uc() of this requires 2 characters, but they are 4130 * ASCII. If not enough room, grow the string */ 4131 if (SvLEN(dest) < ++min) { 4132 const UV o = d - (U8*)SvPVX_const(dest); 4133 d = o + (U8*) SvGROW(dest, min); 4134 } 4135 *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */ 4136 continue; /* Back to the tight loop; still in ASCII */ 4137 } 4138 #endif 4139 4140 /* The other two special handling characters have their 4141 * upper cases outside the latin1 range, hence need to be 4142 * in UTF-8, so the whole result needs to be in UTF-8. So, 4143 * here we are somewhere in the middle of processing a 4144 * non-UTF-8 string, and realize that we will have to convert 4145 * the whole thing to UTF-8. What to do? There are 4146 * several possibilities. The simplest to code is to 4147 * convert what we have so far, set a flag, and continue on 4148 * in the loop. The flag would be tested each time through 4149 * the loop, and if set, the next character would be 4150 * converted to UTF-8 and stored. But, I (khw) didn't want 4151 * to slow down the mainstream case at all for this fairly 4152 * rare case, so I didn't want to add a test that didn't 4153 * absolutely have to be there in the loop, besides the 4154 * possibility that it would get too complicated for 4155 * optimizers to deal with. Another possibility is to just 4156 * give up, convert the source to UTF-8, and restart the 4157 * function that way. Another possibility is to convert 4158 * both what has already been processed and what is yet to 4159 * come separately to UTF-8, then jump into the loop that 4160 * handles UTF-8. But the most efficient time-wise of the 4161 * ones I could think of is what follows, and turned out to 4162 * not require much extra code. */ 4163 4164 /* Convert what we have so far into UTF-8, telling the 4165 * function that we know it should be converted, and to 4166 * allow extra space for what we haven't processed yet. 4167 * Assume the worst case space requirements for converting 4168 * what we haven't processed so far: that it will require 4169 * two bytes for each remaining source character, plus the 4170 * NUL at the end. This may cause the string pointer to 4171 * move, so re-find it. */ 4172 4173 len = d - (U8*)SvPVX_const(dest); 4174 SvCUR_set(dest, len); 4175 len = sv_utf8_upgrade_flags_grow(dest, 4176 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE, 4177 (send -s) * 2 + 1); 4178 d = (U8*)SvPVX(dest) + len; 4179 4180 /* Now process the remainder of the source, converting to 4181 * upper and UTF-8. If a resulting byte is invariant in 4182 * UTF-8, output it as-is, otherwise convert to UTF-8 and 4183 * append it to the output. */ 4184 for (; s < send; s++) { 4185 (void) _to_upper_title_latin1(*s, d, &len, 'S'); 4186 d += len; 4187 } 4188 4189 /* Here have processed the whole source; no need to continue 4190 * with the outer loop. Each character has been converted 4191 * to upper case and converted to UTF-8 */ 4192 4193 break; 4194 } /* End of processing all latin1-style chars */ 4195 } /* End of processing all chars */ 4196 } /* End of source is not empty */ 4197 4198 if (source != dest) { 4199 *d = '\0'; /* Here d points to 1 after last char, add NUL */ 4200 SvCUR_set(dest, d - (U8*)SvPVX_const(dest)); 4201 } 4202 } /* End of isn't utf8 */ 4203 #ifdef USE_LOCALE_CTYPE 4204 if (IN_LC_RUNTIME(LC_CTYPE)) { 4205 TAINT; 4206 SvTAINTED_on(dest); 4207 } 4208 #endif 4209 if (dest != source && SvTAINTED(source)) 4210 SvTAINT(dest); 4211 SvSETMAGIC(dest); 4212 return NORMAL; 4213 } 4214 4215 PP(pp_lc) 4216 { 4217 dSP; 4218 SV *source = TOPs; 4219 STRLEN len; 4220 STRLEN min; 4221 SV *dest; 4222 const U8 *s; 4223 U8 *d; 4224 4225 SvGETMAGIC(source); 4226 4227 if ( SvPADTMP(source) 4228 && !SvREADONLY(source) && SvPOK(source) 4229 && !DO_UTF8(source)) { 4230 4231 /* We can convert in place, as lowercasing anything in the latin1 range 4232 * (or else DO_UTF8 would have been on) doesn't lengthen it */ 4233 dest = source; 4234 s = d = (U8*)SvPV_force_nomg(source, len); 4235 min = len + 1; 4236 } else { 4237 dTARGET; 4238 4239 dest = TARG; 4240 4241 s = (const U8*)SvPV_nomg_const(source, len); 4242 min = len + 1; 4243 4244 SvUPGRADE(dest, SVt_PV); 4245 d = (U8*)SvGROW(dest, min); 4246 (void)SvPOK_only(dest); 4247 4248 SETs(dest); 4249 } 4250 4251 #ifdef USE_LOCALE_CTYPE 4252 4253 if (IN_LC_RUNTIME(LC_CTYPE)) { 4254 _CHECK_AND_WARN_PROBLEMATIC_LOCALE; 4255 } 4256 4257 #endif 4258 4259 /* Overloaded values may have toggled the UTF-8 flag on source, so we need 4260 to check DO_UTF8 again here. */ 4261 4262 if (DO_UTF8(source)) { 4263 const U8 *const send = s + len; 4264 U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; 4265 4266 while (s < send) { 4267 const STRLEN u = UTF8SKIP(s); 4268 STRLEN ulen; 4269 4270 #ifdef USE_LOCALE_CTYPE 4271 _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE)); 4272 #else 4273 _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, 0); 4274 #endif 4275 4276 /* Here is where we would do context-sensitive actions. See the 4277 * commit message for 86510fb15 for why there isn't any */ 4278 4279 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) { 4280 4281 /* If the eventually required minimum size outgrows the 4282 * available space, we need to grow. */ 4283 const UV o = d - (U8*)SvPVX_const(dest); 4284 4285 /* If someone lowercases one million U+0130s we SvGROW() one 4286 * million times. Or we could try guessing how much to 4287 * allocate without allocating too much. Such is life. 4288 * Another option would be to grow an extra byte or two more 4289 * each time we need to grow, which would cut down the million 4290 * to 500K, with little waste */ 4291 d = o + (U8*) SvGROW(dest, min); 4292 } 4293 4294 /* Copy the newly lowercased letter to the output buffer we're 4295 * building */ 4296 Copy(tmpbuf, d, ulen, U8); 4297 d += ulen; 4298 s += u; 4299 } /* End of looping through the source string */ 4300 SvUTF8_on(dest); 4301 *d = '\0'; 4302 SvCUR_set(dest, d - (U8*)SvPVX_const(dest)); 4303 } else { /* Not utf8 */ 4304 if (len) { 4305 const U8 *const send = s + len; 4306 4307 /* Use locale casing if in locale; regular style if not treating 4308 * latin1 as having case; otherwise the latin1 casing. Do the 4309 * whole thing in a tight loop, for speed, */ 4310 #ifdef USE_LOCALE_CTYPE 4311 if (IN_LC_RUNTIME(LC_CTYPE)) { 4312 for (; s < send; d++, s++) 4313 *d = toLOWER_LC(*s); 4314 } 4315 else 4316 #endif 4317 if (! IN_UNI_8_BIT) { 4318 for (; s < send; d++, s++) { 4319 *d = toLOWER(*s); 4320 } 4321 } 4322 else { 4323 for (; s < send; d++, s++) { 4324 *d = toLOWER_LATIN1(*s); 4325 } 4326 } 4327 } 4328 if (source != dest) { 4329 *d = '\0'; 4330 SvCUR_set(dest, d - (U8*)SvPVX_const(dest)); 4331 } 4332 } 4333 #ifdef USE_LOCALE_CTYPE 4334 if (IN_LC_RUNTIME(LC_CTYPE)) { 4335 TAINT; 4336 SvTAINTED_on(dest); 4337 } 4338 #endif 4339 if (dest != source && SvTAINTED(source)) 4340 SvTAINT(dest); 4341 SvSETMAGIC(dest); 4342 return NORMAL; 4343 } 4344 4345 PP(pp_quotemeta) 4346 { 4347 dSP; dTARGET; 4348 SV * const sv = TOPs; 4349 STRLEN len; 4350 const char *s = SvPV_const(sv,len); 4351 4352 SvUTF8_off(TARG); /* decontaminate */ 4353 if (len) { 4354 char *d; 4355 SvUPGRADE(TARG, SVt_PV); 4356 SvGROW(TARG, (len * 2) + 1); 4357 d = SvPVX(TARG); 4358 if (DO_UTF8(sv)) { 4359 while (len) { 4360 STRLEN ulen = UTF8SKIP(s); 4361 bool to_quote = FALSE; 4362 4363 if (UTF8_IS_INVARIANT(*s)) { 4364 if (_isQUOTEMETA(*s)) { 4365 to_quote = TRUE; 4366 } 4367 } 4368 else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(s, s + len)) { 4369 if ( 4370 #ifdef USE_LOCALE_CTYPE 4371 /* In locale, we quote all non-ASCII Latin1 chars. 4372 * Otherwise use the quoting rules */ 4373 4374 IN_LC_RUNTIME(LC_CTYPE) 4375 || 4376 #endif 4377 _isQUOTEMETA(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s + 1)))) 4378 { 4379 to_quote = TRUE; 4380 } 4381 } 4382 else if (is_QUOTEMETA_high(s)) { 4383 to_quote = TRUE; 4384 } 4385 4386 if (to_quote) { 4387 *d++ = '\\'; 4388 } 4389 if (ulen > len) 4390 ulen = len; 4391 len -= ulen; 4392 while (ulen--) 4393 *d++ = *s++; 4394 } 4395 SvUTF8_on(TARG); 4396 } 4397 else if (IN_UNI_8_BIT) { 4398 while (len--) { 4399 if (_isQUOTEMETA(*s)) 4400 *d++ = '\\'; 4401 *d++ = *s++; 4402 } 4403 } 4404 else { 4405 /* For non UNI_8_BIT (and hence in locale) just quote all \W 4406 * including everything above ASCII */ 4407 while (len--) { 4408 if (!isWORDCHAR_A(*s)) 4409 *d++ = '\\'; 4410 *d++ = *s++; 4411 } 4412 } 4413 *d = '\0'; 4414 SvCUR_set(TARG, d - SvPVX_const(TARG)); 4415 (void)SvPOK_only_UTF8(TARG); 4416 } 4417 else 4418 sv_setpvn(TARG, s, len); 4419 SETTARG; 4420 return NORMAL; 4421 } 4422 4423 PP(pp_fc) 4424 { 4425 dTARGET; 4426 dSP; 4427 SV *source = TOPs; 4428 STRLEN len; 4429 STRLEN min; 4430 SV *dest; 4431 const U8 *s; 4432 const U8 *send; 4433 U8 *d; 4434 U8 tmpbuf[UTF8_MAXBYTES_CASE + 1]; 4435 #if UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */ \ 4436 || (UNICODE_MAJOR_VERSION == 3 && ( UNICODE_DOT_VERSION > 0) \ 4437 || UNICODE_DOT_DOT_VERSION > 0) 4438 const bool full_folding = TRUE; /* This variable is here so we can easily 4439 move to more generality later */ 4440 #else 4441 const bool full_folding = FALSE; 4442 #endif 4443 const U8 flags = ( full_folding ? FOLD_FLAGS_FULL : 0 ) 4444 #ifdef USE_LOCALE_CTYPE 4445 | ( IN_LC_RUNTIME(LC_CTYPE) ? FOLD_FLAGS_LOCALE : 0 ) 4446 #endif 4447 ; 4448 4449 /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me. 4450 * You are welcome(?) -Hugmeir 4451 */ 4452 4453 SvGETMAGIC(source); 4454 4455 dest = TARG; 4456 4457 if (SvOK(source)) { 4458 s = (const U8*)SvPV_nomg_const(source, len); 4459 } else { 4460 if (ckWARN(WARN_UNINITIALIZED)) 4461 report_uninit(source); 4462 s = (const U8*)""; 4463 len = 0; 4464 } 4465 4466 min = len + 1; 4467 4468 SvUPGRADE(dest, SVt_PV); 4469 d = (U8*)SvGROW(dest, min); 4470 (void)SvPOK_only(dest); 4471 4472 SETs(dest); 4473 4474 send = s + len; 4475 4476 #ifdef USE_LOCALE_CTYPE 4477 4478 if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */ 4479 _CHECK_AND_WARN_PROBLEMATIC_LOCALE; 4480 } 4481 4482 #endif 4483 4484 if (DO_UTF8(source)) { /* UTF-8 flagged string. */ 4485 while (s < send) { 4486 const STRLEN u = UTF8SKIP(s); 4487 STRLEN ulen; 4488 4489 _toFOLD_utf8_flags(s, send, tmpbuf, &ulen, flags); 4490 4491 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) { 4492 const UV o = d - (U8*)SvPVX_const(dest); 4493 d = o + (U8*) SvGROW(dest, min); 4494 } 4495 4496 Copy(tmpbuf, d, ulen, U8); 4497 d += ulen; 4498 s += u; 4499 } 4500 SvUTF8_on(dest); 4501 } /* Unflagged string */ 4502 else if (len) { 4503 #ifdef USE_LOCALE_CTYPE 4504 if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */ 4505 if (IN_UTF8_CTYPE_LOCALE) { 4506 goto do_uni_folding; 4507 } 4508 for (; s < send; d++, s++) 4509 *d = (U8) toFOLD_LC(*s); 4510 } 4511 else 4512 #endif 4513 if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */ 4514 for (; s < send; d++, s++) 4515 *d = toFOLD(*s); 4516 } 4517 else { 4518 #ifdef USE_LOCALE_CTYPE 4519 do_uni_folding: 4520 #endif 4521 /* For ASCII and the Latin-1 range, there's only two troublesome 4522 * folds, \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full 4523 * casefolding becomes 'ss'; and \x{B5} (\N{MICRO SIGN}), which 4524 * under any fold becomes \x{3BC} (\N{GREEK SMALL LETTER MU}) -- 4525 * For the rest, the casefold is their lowercase. */ 4526 for (; s < send; d++, s++) { 4527 if (*s == MICRO_SIGN) { 4528 /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU}, 4529 * which is outside of the latin-1 range. There's a couple 4530 * of ways to deal with this -- khw discusses them in 4531 * pp_lc/uc, so go there :) What we do here is upgrade what 4532 * we had already casefolded, then enter an inner loop that 4533 * appends the rest of the characters as UTF-8. */ 4534 len = d - (U8*)SvPVX_const(dest); 4535 SvCUR_set(dest, len); 4536 len = sv_utf8_upgrade_flags_grow(dest, 4537 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE, 4538 /* The max expansion for latin1 4539 * chars is 1 byte becomes 2 */ 4540 (send -s) * 2 + 1); 4541 d = (U8*)SvPVX(dest) + len; 4542 4543 Copy(GREEK_SMALL_LETTER_MU_UTF8, d, small_mu_len, U8); 4544 d += small_mu_len; 4545 s++; 4546 for (; s < send; s++) { 4547 STRLEN ulen; 4548 UV fc = _to_uni_fold_flags(*s, tmpbuf, &ulen, flags); 4549 if UVCHR_IS_INVARIANT(fc) { 4550 if (full_folding 4551 && *s == LATIN_SMALL_LETTER_SHARP_S) 4552 { 4553 *d++ = 's'; 4554 *d++ = 's'; 4555 } 4556 else 4557 *d++ = (U8)fc; 4558 } 4559 else { 4560 Copy(tmpbuf, d, ulen, U8); 4561 d += ulen; 4562 } 4563 } 4564 break; 4565 } 4566 else if (full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) { 4567 /* Under full casefolding, LATIN SMALL LETTER SHARP S 4568 * becomes "ss", which may require growing the SV. */ 4569 if (SvLEN(dest) < ++min) { 4570 const UV o = d - (U8*)SvPVX_const(dest); 4571 d = o + (U8*) SvGROW(dest, min); 4572 } 4573 *(d)++ = 's'; 4574 *d = 's'; 4575 } 4576 else { /* If it's not one of those two, the fold is their lower 4577 case */ 4578 *d = toLOWER_LATIN1(*s); 4579 } 4580 } 4581 } 4582 } 4583 *d = '\0'; 4584 SvCUR_set(dest, d - (U8*)SvPVX_const(dest)); 4585 4586 #ifdef USE_LOCALE_CTYPE 4587 if (IN_LC_RUNTIME(LC_CTYPE)) { 4588 TAINT; 4589 SvTAINTED_on(dest); 4590 } 4591 #endif 4592 if (SvTAINTED(source)) 4593 SvTAINT(dest); 4594 SvSETMAGIC(dest); 4595 RETURN; 4596 } 4597 4598 /* Arrays. */ 4599 4600 PP(pp_aslice) 4601 { 4602 dSP; dMARK; dORIGMARK; 4603 AV *const av = MUTABLE_AV(POPs); 4604 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET); 4605 4606 if (SvTYPE(av) == SVt_PVAV) { 4607 const bool localizing = PL_op->op_private & OPpLVAL_INTRO; 4608 bool can_preserve = FALSE; 4609 4610 if (localizing) { 4611 MAGIC *mg; 4612 HV *stash; 4613 4614 can_preserve = SvCANEXISTDELETE(av); 4615 } 4616 4617 if (lval && localizing) { 4618 SV **svp; 4619 SSize_t max = -1; 4620 for (svp = MARK + 1; svp <= SP; svp++) { 4621 const SSize_t elem = SvIV(*svp); 4622 if (elem > max) 4623 max = elem; 4624 } 4625 if (max > AvMAX(av)) 4626 av_extend(av, max); 4627 } 4628 4629 while (++MARK <= SP) { 4630 SV **svp; 4631 SSize_t elem = SvIV(*MARK); 4632 bool preeminent = TRUE; 4633 4634 if (localizing && can_preserve) { 4635 /* If we can determine whether the element exist, 4636 * Try to preserve the existenceness of a tied array 4637 * element by using EXISTS and DELETE if possible. 4638 * Fallback to FETCH and STORE otherwise. */ 4639 preeminent = av_exists(av, elem); 4640 } 4641 4642 svp = av_fetch(av, elem, lval); 4643 if (lval) { 4644 if (!svp || !*svp) 4645 DIE(aTHX_ PL_no_aelem, elem); 4646 if (localizing) { 4647 if (preeminent) 4648 save_aelem(av, elem, svp); 4649 else 4650 SAVEADELETE(av, elem); 4651 } 4652 } 4653 *MARK = svp ? *svp : &PL_sv_undef; 4654 } 4655 } 4656 if (GIMME_V != G_ARRAY) { 4657 MARK = ORIGMARK; 4658 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef; 4659 SP = MARK; 4660 } 4661 RETURN; 4662 } 4663 4664 PP(pp_kvaslice) 4665 { 4666 dSP; dMARK; 4667 AV *const av = MUTABLE_AV(POPs); 4668 I32 lval = (PL_op->op_flags & OPf_MOD); 4669 SSize_t items = SP - MARK; 4670 4671 if (PL_op->op_private & OPpMAYBE_LVSUB) { 4672 const I32 flags = is_lvalue_sub(); 4673 if (flags) { 4674 if (!(flags & OPpENTERSUB_INARGS)) 4675 /* diag_listed_as: Can't modify %s in %s */ 4676 Perl_croak(aTHX_ "Can't modify index/value array slice in list assignment"); 4677 lval = flags; 4678 } 4679 } 4680 4681 MEXTEND(SP,items); 4682 while (items > 1) { 4683 *(MARK+items*2-1) = *(MARK+items); 4684 items--; 4685 } 4686 items = SP-MARK; 4687 SP += items; 4688 4689 while (++MARK <= SP) { 4690 SV **svp; 4691 4692 svp = av_fetch(av, SvIV(*MARK), lval); 4693 if (lval) { 4694 if (!svp || !*svp || *svp == &PL_sv_undef) { 4695 DIE(aTHX_ PL_no_aelem, SvIV(*MARK)); 4696 } 4697 *MARK = sv_mortalcopy(*MARK); 4698 } 4699 *++MARK = svp ? *svp : &PL_sv_undef; 4700 } 4701 if (GIMME_V != G_ARRAY) { 4702 MARK = SP - items*2; 4703 *++MARK = items > 0 ? *SP : &PL_sv_undef; 4704 SP = MARK; 4705 } 4706 RETURN; 4707 } 4708 4709 4710 PP(pp_aeach) 4711 { 4712 dSP; 4713 AV *array = MUTABLE_AV(POPs); 4714 const U8 gimme = GIMME_V; 4715 IV *iterp = Perl_av_iter_p(aTHX_ array); 4716 const IV current = (*iterp)++; 4717 4718 if (current > av_tindex(array)) { 4719 *iterp = 0; 4720 if (gimme == G_SCALAR) 4721 RETPUSHUNDEF; 4722 else 4723 RETURN; 4724 } 4725 4726 EXTEND(SP, 2); 4727 mPUSHi(current); 4728 if (gimme == G_ARRAY) { 4729 SV **const element = av_fetch(array, current, 0); 4730 PUSHs(element ? *element : &PL_sv_undef); 4731 } 4732 RETURN; 4733 } 4734 4735 /* also used for: pp_avalues()*/ 4736 PP(pp_akeys) 4737 { 4738 dSP; 4739 AV *array = MUTABLE_AV(POPs); 4740 const U8 gimme = GIMME_V; 4741 4742 *Perl_av_iter_p(aTHX_ array) = 0; 4743 4744 if (gimme == G_SCALAR) { 4745 dTARGET; 4746 PUSHi(av_tindex(array) + 1); 4747 } 4748 else if (gimme == G_ARRAY) { 4749 if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) { 4750 const I32 flags = is_lvalue_sub(); 4751 if (flags && !(flags & OPpENTERSUB_INARGS)) 4752 /* diag_listed_as: Can't modify %s in %s */ 4753 Perl_croak(aTHX_ 4754 "Can't modify keys on array in list assignment"); 4755 } 4756 { 4757 IV n = Perl_av_len(aTHX_ array); 4758 IV i; 4759 4760 EXTEND(SP, n + 1); 4761 4762 if ( PL_op->op_type == OP_AKEYS 4763 || ( PL_op->op_type == OP_AVHVSWITCH 4764 && (PL_op->op_private & 3) + OP_AEACH == OP_AKEYS )) 4765 { 4766 for (i = 0; i <= n; i++) { 4767 mPUSHi(i); 4768 } 4769 } 4770 else { 4771 for (i = 0; i <= n; i++) { 4772 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0); 4773 PUSHs(elem ? *elem : &PL_sv_undef); 4774 } 4775 } 4776 } 4777 } 4778 RETURN; 4779 } 4780 4781 /* Associative arrays. */ 4782 4783 PP(pp_each) 4784 { 4785 dSP; 4786 HV * hash = MUTABLE_HV(POPs); 4787 HE *entry; 4788 const U8 gimme = GIMME_V; 4789 4790 entry = hv_iternext(hash); 4791 4792 EXTEND(SP, 2); 4793 if (entry) { 4794 SV* const sv = hv_iterkeysv(entry); 4795 PUSHs(sv); 4796 if (gimme == G_ARRAY) { 4797 SV *val; 4798 val = hv_iterval(hash, entry); 4799 PUSHs(val); 4800 } 4801 } 4802 else if (gimme == G_SCALAR) 4803 RETPUSHUNDEF; 4804 4805 RETURN; 4806 } 4807 4808 STATIC OP * 4809 S_do_delete_local(pTHX) 4810 { 4811 dSP; 4812 const U8 gimme = GIMME_V; 4813 const MAGIC *mg; 4814 HV *stash; 4815 const bool sliced = !!(PL_op->op_private & OPpSLICE); 4816 SV **unsliced_keysv = sliced ? NULL : sp--; 4817 SV * const osv = POPs; 4818 SV **mark = sliced ? PL_stack_base + POPMARK : unsliced_keysv-1; 4819 dORIGMARK; 4820 const bool tied = SvRMAGICAL(osv) 4821 && mg_find((const SV *)osv, PERL_MAGIC_tied); 4822 const bool can_preserve = SvCANEXISTDELETE(osv); 4823 const U32 type = SvTYPE(osv); 4824 SV ** const end = sliced ? SP : unsliced_keysv; 4825 4826 if (type == SVt_PVHV) { /* hash element */ 4827 HV * const hv = MUTABLE_HV(osv); 4828 while (++MARK <= end) { 4829 SV * const keysv = *MARK; 4830 SV *sv = NULL; 4831 bool preeminent = TRUE; 4832 if (can_preserve) 4833 preeminent = hv_exists_ent(hv, keysv, 0); 4834 if (tied) { 4835 HE *he = hv_fetch_ent(hv, keysv, 1, 0); 4836 if (he) 4837 sv = HeVAL(he); 4838 else 4839 preeminent = FALSE; 4840 } 4841 else { 4842 sv = hv_delete_ent(hv, keysv, 0, 0); 4843 if (preeminent) 4844 SvREFCNT_inc_simple_void(sv); /* De-mortalize */ 4845 } 4846 if (preeminent) { 4847 if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv)); 4848 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM); 4849 if (tied) { 4850 *MARK = sv_mortalcopy(sv); 4851 mg_clear(sv); 4852 } else 4853 *MARK = sv; 4854 } 4855 else { 4856 SAVEHDELETE(hv, keysv); 4857 *MARK = &PL_sv_undef; 4858 } 4859 } 4860 } 4861 else if (type == SVt_PVAV) { /* array element */ 4862 if (PL_op->op_flags & OPf_SPECIAL) { 4863 AV * const av = MUTABLE_AV(osv); 4864 while (++MARK <= end) { 4865 SSize_t idx = SvIV(*MARK); 4866 SV *sv = NULL; 4867 bool preeminent = TRUE; 4868 if (can_preserve) 4869 preeminent = av_exists(av, idx); 4870 if (tied) { 4871 SV **svp = av_fetch(av, idx, 1); 4872 if (svp) 4873 sv = *svp; 4874 else 4875 preeminent = FALSE; 4876 } 4877 else { 4878 sv = av_delete(av, idx, 0); 4879 if (preeminent) 4880 SvREFCNT_inc_simple_void(sv); /* De-mortalize */ 4881 } 4882 if (preeminent) { 4883 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM); 4884 if (tied) { 4885 *MARK = sv_mortalcopy(sv); 4886 mg_clear(sv); 4887 } else 4888 *MARK = sv; 4889 } 4890 else { 4891 SAVEADELETE(av, idx); 4892 *MARK = &PL_sv_undef; 4893 } 4894 } 4895 } 4896 else 4897 DIE(aTHX_ "panic: avhv_delete no longer supported"); 4898 } 4899 else 4900 DIE(aTHX_ "Not a HASH reference"); 4901 if (sliced) { 4902 if (gimme == G_VOID) 4903 SP = ORIGMARK; 4904 else if (gimme == G_SCALAR) { 4905 MARK = ORIGMARK; 4906 if (SP > MARK) 4907 *++MARK = *SP; 4908 else 4909 *++MARK = &PL_sv_undef; 4910 SP = MARK; 4911 } 4912 } 4913 else if (gimme != G_VOID) 4914 PUSHs(*unsliced_keysv); 4915 4916 RETURN; 4917 } 4918 4919 PP(pp_delete) 4920 { 4921 dSP; 4922 U8 gimme; 4923 I32 discard; 4924 4925 if (PL_op->op_private & OPpLVAL_INTRO) 4926 return do_delete_local(); 4927 4928 gimme = GIMME_V; 4929 discard = (gimme == G_VOID) ? G_DISCARD : 0; 4930 4931 if (PL_op->op_private & (OPpSLICE|OPpKVSLICE)) { 4932 dMARK; dORIGMARK; 4933 HV * const hv = MUTABLE_HV(POPs); 4934 const U32 hvtype = SvTYPE(hv); 4935 int skip = 0; 4936 if (PL_op->op_private & OPpKVSLICE) { 4937 SSize_t items = SP - MARK; 4938 4939 MEXTEND(SP,items); 4940 while (items > 1) { 4941 *(MARK+items*2-1) = *(MARK+items); 4942 items--; 4943 } 4944 items = SP - MARK; 4945 SP += items; 4946 skip = 1; 4947 } 4948 if (hvtype == SVt_PVHV) { /* hash element */ 4949 while ((MARK += (1+skip)) <= SP) { 4950 SV * const sv = hv_delete_ent(hv, *(MARK-skip), discard, 0); 4951 *MARK = sv ? sv : &PL_sv_undef; 4952 } 4953 } 4954 else if (hvtype == SVt_PVAV) { /* array element */ 4955 if (PL_op->op_flags & OPf_SPECIAL) { 4956 while ((MARK += (1+skip)) <= SP) { 4957 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*(MARK-skip)), discard); 4958 *MARK = sv ? sv : &PL_sv_undef; 4959 } 4960 } 4961 } 4962 else 4963 DIE(aTHX_ "Not a HASH reference"); 4964 if (discard) 4965 SP = ORIGMARK; 4966 else if (gimme == G_SCALAR) { 4967 MARK = ORIGMARK; 4968 if (SP > MARK) 4969 *++MARK = *SP; 4970 else 4971 *++MARK = &PL_sv_undef; 4972 SP = MARK; 4973 } 4974 } 4975 else { 4976 SV *keysv = POPs; 4977 HV * const hv = MUTABLE_HV(POPs); 4978 SV *sv = NULL; 4979 if (SvTYPE(hv) == SVt_PVHV) 4980 sv = hv_delete_ent(hv, keysv, discard, 0); 4981 else if (SvTYPE(hv) == SVt_PVAV) { 4982 if (PL_op->op_flags & OPf_SPECIAL) 4983 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard); 4984 else 4985 DIE(aTHX_ "panic: avhv_delete no longer supported"); 4986 } 4987 else 4988 DIE(aTHX_ "Not a HASH reference"); 4989 if (!sv) 4990 sv = &PL_sv_undef; 4991 if (!discard) 4992 PUSHs(sv); 4993 } 4994 RETURN; 4995 } 4996 4997 PP(pp_exists) 4998 { 4999 dSP; 5000 SV *tmpsv; 5001 HV *hv; 5002 5003 if (UNLIKELY( PL_op->op_private & OPpEXISTS_SUB )) { 5004 GV *gv; 5005 SV * const sv = POPs; 5006 CV * const cv = sv_2cv(sv, &hv, &gv, 0); 5007 if (cv) 5008 RETPUSHYES; 5009 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv)) 5010 RETPUSHYES; 5011 RETPUSHNO; 5012 } 5013 tmpsv = POPs; 5014 hv = MUTABLE_HV(POPs); 5015 if (LIKELY( SvTYPE(hv) == SVt_PVHV )) { 5016 if (hv_exists_ent(hv, tmpsv, 0)) 5017 RETPUSHYES; 5018 } 5019 else if (SvTYPE(hv) == SVt_PVAV) { 5020 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */ 5021 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv))) 5022 RETPUSHYES; 5023 } 5024 } 5025 else { 5026 DIE(aTHX_ "Not a HASH reference"); 5027 } 5028 RETPUSHNO; 5029 } 5030 5031 PP(pp_hslice) 5032 { 5033 dSP; dMARK; dORIGMARK; 5034 HV * const hv = MUTABLE_HV(POPs); 5035 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET); 5036 const bool localizing = PL_op->op_private & OPpLVAL_INTRO; 5037 bool can_preserve = FALSE; 5038 5039 if (localizing) { 5040 MAGIC *mg; 5041 HV *stash; 5042 5043 if (SvCANEXISTDELETE(hv)) 5044 can_preserve = TRUE; 5045 } 5046 5047 while (++MARK <= SP) { 5048 SV * const keysv = *MARK; 5049 SV **svp; 5050 HE *he; 5051 bool preeminent = TRUE; 5052 5053 if (localizing && can_preserve) { 5054 /* If we can determine whether the element exist, 5055 * try to preserve the existenceness of a tied hash 5056 * element by using EXISTS and DELETE if possible. 5057 * Fallback to FETCH and STORE otherwise. */ 5058 preeminent = hv_exists_ent(hv, keysv, 0); 5059 } 5060 5061 he = hv_fetch_ent(hv, keysv, lval, 0); 5062 svp = he ? &HeVAL(he) : NULL; 5063 5064 if (lval) { 5065 if (!svp || !*svp || *svp == &PL_sv_undef) { 5066 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv)); 5067 } 5068 if (localizing) { 5069 if (HvNAME_get(hv) && isGV_or_RVCV(*svp)) 5070 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL)); 5071 else if (preeminent) 5072 save_helem_flags(hv, keysv, svp, 5073 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC); 5074 else 5075 SAVEHDELETE(hv, keysv); 5076 } 5077 } 5078 *MARK = svp && *svp ? *svp : &PL_sv_undef; 5079 } 5080 if (GIMME_V != G_ARRAY) { 5081 MARK = ORIGMARK; 5082 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef; 5083 SP = MARK; 5084 } 5085 RETURN; 5086 } 5087 5088 PP(pp_kvhslice) 5089 { 5090 dSP; dMARK; 5091 HV * const hv = MUTABLE_HV(POPs); 5092 I32 lval = (PL_op->op_flags & OPf_MOD); 5093 SSize_t items = SP - MARK; 5094 5095 if (PL_op->op_private & OPpMAYBE_LVSUB) { 5096 const I32 flags = is_lvalue_sub(); 5097 if (flags) { 5098 if (!(flags & OPpENTERSUB_INARGS)) 5099 /* diag_listed_as: Can't modify %s in %s */ 5100 Perl_croak(aTHX_ "Can't modify key/value hash slice in %s assignment", 5101 GIMME_V == G_ARRAY ? "list" : "scalar"); 5102 lval = flags; 5103 } 5104 } 5105 5106 MEXTEND(SP,items); 5107 while (items > 1) { 5108 *(MARK+items*2-1) = *(MARK+items); 5109 items--; 5110 } 5111 items = SP-MARK; 5112 SP += items; 5113 5114 while (++MARK <= SP) { 5115 SV * const keysv = *MARK; 5116 SV **svp; 5117 HE *he; 5118 5119 he = hv_fetch_ent(hv, keysv, lval, 0); 5120 svp = he ? &HeVAL(he) : NULL; 5121 5122 if (lval) { 5123 if (!svp || !*svp || *svp == &PL_sv_undef) { 5124 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv)); 5125 } 5126 *MARK = sv_mortalcopy(*MARK); 5127 } 5128 *++MARK = svp && *svp ? *svp : &PL_sv_undef; 5129 } 5130 if (GIMME_V != G_ARRAY) { 5131 MARK = SP - items*2; 5132 *++MARK = items > 0 ? *SP : &PL_sv_undef; 5133 SP = MARK; 5134 } 5135 RETURN; 5136 } 5137 5138 /* List operators. */ 5139 5140 PP(pp_list) 5141 { 5142 I32 markidx = POPMARK; 5143 if (GIMME_V != G_ARRAY) { 5144 /* don't initialize mark here, EXTEND() may move the stack */ 5145 SV **mark; 5146 dSP; 5147 EXTEND(SP, 1); /* in case no arguments, as in @empty */ 5148 mark = PL_stack_base + markidx; 5149 if (++MARK <= SP) 5150 *MARK = *SP; /* unwanted list, return last item */ 5151 else 5152 *MARK = &PL_sv_undef; 5153 SP = MARK; 5154 PUTBACK; 5155 } 5156 return NORMAL; 5157 } 5158 5159 PP(pp_lslice) 5160 { 5161 dSP; 5162 SV ** const lastrelem = PL_stack_sp; 5163 SV ** const lastlelem = PL_stack_base + POPMARK; 5164 SV ** const firstlelem = PL_stack_base + POPMARK + 1; 5165 SV ** const firstrelem = lastlelem + 1; 5166 const U8 mod = PL_op->op_flags & OPf_MOD; 5167 5168 const I32 max = lastrelem - lastlelem; 5169 SV **lelem; 5170 5171 if (GIMME_V != G_ARRAY) { 5172 if (lastlelem < firstlelem) { 5173 EXTEND(SP, 1); 5174 *firstlelem = &PL_sv_undef; 5175 } 5176 else { 5177 I32 ix = SvIV(*lastlelem); 5178 if (ix < 0) 5179 ix += max; 5180 if (ix < 0 || ix >= max) 5181 *firstlelem = &PL_sv_undef; 5182 else 5183 *firstlelem = firstrelem[ix]; 5184 } 5185 SP = firstlelem; 5186 RETURN; 5187 } 5188 5189 if (max == 0) { 5190 SP = firstlelem - 1; 5191 RETURN; 5192 } 5193 5194 for (lelem = firstlelem; lelem <= lastlelem; lelem++) { 5195 I32 ix = SvIV(*lelem); 5196 if (ix < 0) 5197 ix += max; 5198 if (ix < 0 || ix >= max) 5199 *lelem = &PL_sv_undef; 5200 else { 5201 if (!(*lelem = firstrelem[ix])) 5202 *lelem = &PL_sv_undef; 5203 else if (mod && SvPADTMP(*lelem)) { 5204 *lelem = firstrelem[ix] = sv_mortalcopy(*lelem); 5205 } 5206 } 5207 } 5208 SP = lastlelem; 5209 RETURN; 5210 } 5211 5212 PP(pp_anonlist) 5213 { 5214 dSP; dMARK; 5215 const I32 items = SP - MARK; 5216 SV * const av = MUTABLE_SV(av_make(items, MARK+1)); 5217 SP = MARK; 5218 mXPUSHs((PL_op->op_flags & OPf_SPECIAL) 5219 ? newRV_noinc(av) : av); 5220 RETURN; 5221 } 5222 5223 PP(pp_anonhash) 5224 { 5225 dSP; dMARK; dORIGMARK; 5226 HV* const hv = newHV(); 5227 SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL 5228 ? newRV_noinc(MUTABLE_SV(hv)) 5229 : MUTABLE_SV(hv) ); 5230 5231 while (MARK < SP) { 5232 SV * const key = 5233 (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK); 5234 SV *val; 5235 if (MARK < SP) 5236 { 5237 MARK++; 5238 SvGETMAGIC(*MARK); 5239 val = newSV(0); 5240 sv_setsv_nomg(val, *MARK); 5241 } 5242 else 5243 { 5244 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash"); 5245 val = newSV(0); 5246 } 5247 (void)hv_store_ent(hv,key,val,0); 5248 } 5249 SP = ORIGMARK; 5250 XPUSHs(retval); 5251 RETURN; 5252 } 5253 5254 PP(pp_splice) 5255 { 5256 dSP; dMARK; dORIGMARK; 5257 int num_args = (SP - MARK); 5258 AV *ary = MUTABLE_AV(*++MARK); 5259 SV **src; 5260 SV **dst; 5261 SSize_t i; 5262 SSize_t offset; 5263 SSize_t length; 5264 SSize_t newlen; 5265 SSize_t after; 5266 SSize_t diff; 5267 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied); 5268 5269 if (mg) { 5270 return Perl_tied_method(aTHX_ SV_CONST(SPLICE), mark - 1, MUTABLE_SV(ary), mg, 5271 GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK, 5272 sp - mark); 5273 } 5274 5275 if (SvREADONLY(ary)) 5276 Perl_croak_no_modify(); 5277 5278 SP++; 5279 5280 if (++MARK < SP) { 5281 offset = i = SvIV(*MARK); 5282 if (offset < 0) 5283 offset += AvFILLp(ary) + 1; 5284 if (offset < 0) 5285 DIE(aTHX_ PL_no_aelem, i); 5286 if (++MARK < SP) { 5287 length = SvIVx(*MARK++); 5288 if (length < 0) { 5289 length += AvFILLp(ary) - offset + 1; 5290 if (length < 0) 5291 length = 0; 5292 } 5293 } 5294 else 5295 length = AvMAX(ary) + 1; /* close enough to infinity */ 5296 } 5297 else { 5298 offset = 0; 5299 length = AvMAX(ary) + 1; 5300 } 5301 if (offset > AvFILLp(ary) + 1) { 5302 if (num_args > 2) 5303 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" ); 5304 offset = AvFILLp(ary) + 1; 5305 } 5306 after = AvFILLp(ary) + 1 - (offset + length); 5307 if (after < 0) { /* not that much array */ 5308 length += after; /* offset+length now in array */ 5309 after = 0; 5310 if (!AvALLOC(ary)) 5311 av_extend(ary, 0); 5312 } 5313 5314 /* At this point, MARK .. SP-1 is our new LIST */ 5315 5316 newlen = SP - MARK; 5317 diff = newlen - length; 5318 if (newlen && !AvREAL(ary) && AvREIFY(ary)) 5319 av_reify(ary); 5320 5321 /* make new elements SVs now: avoid problems if they're from the array */ 5322 for (dst = MARK, i = newlen; i; i--) { 5323 SV * const h = *dst; 5324 *dst++ = newSVsv(h); 5325 } 5326 5327 if (diff < 0) { /* shrinking the area */ 5328 SV **tmparyval = NULL; 5329 if (newlen) { 5330 Newx(tmparyval, newlen, SV*); /* so remember insertion */ 5331 Copy(MARK, tmparyval, newlen, SV*); 5332 } 5333 5334 MARK = ORIGMARK + 1; 5335 if (GIMME_V == G_ARRAY) { /* copy return vals to stack */ 5336 const bool real = cBOOL(AvREAL(ary)); 5337 MEXTEND(MARK, length); 5338 if (real) 5339 EXTEND_MORTAL(length); 5340 for (i = 0, dst = MARK; i < length; i++) { 5341 if ((*dst = AvARRAY(ary)[i+offset])) { 5342 if (real) 5343 sv_2mortal(*dst); /* free them eventually */ 5344 } 5345 else 5346 *dst = &PL_sv_undef; 5347 dst++; 5348 } 5349 MARK += length - 1; 5350 } 5351 else { 5352 *MARK = AvARRAY(ary)[offset+length-1]; 5353 if (AvREAL(ary)) { 5354 sv_2mortal(*MARK); 5355 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--) 5356 SvREFCNT_dec(*dst++); /* free them now */ 5357 } 5358 if (!*MARK) 5359 *MARK = &PL_sv_undef; 5360 } 5361 AvFILLp(ary) += diff; 5362 5363 /* pull up or down? */ 5364 5365 if (offset < after) { /* easier to pull up */ 5366 if (offset) { /* esp. if nothing to pull */ 5367 src = &AvARRAY(ary)[offset-1]; 5368 dst = src - diff; /* diff is negative */ 5369 for (i = offset; i > 0; i--) /* can't trust Copy */ 5370 *dst-- = *src--; 5371 } 5372 dst = AvARRAY(ary); 5373 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */ 5374 AvMAX(ary) += diff; 5375 } 5376 else { 5377 if (after) { /* anything to pull down? */ 5378 src = AvARRAY(ary) + offset + length; 5379 dst = src + diff; /* diff is negative */ 5380 Move(src, dst, after, SV*); 5381 } 5382 dst = &AvARRAY(ary)[AvFILLp(ary)+1]; 5383 /* avoid later double free */ 5384 } 5385 i = -diff; 5386 while (i) 5387 dst[--i] = NULL; 5388 5389 if (newlen) { 5390 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* ); 5391 Safefree(tmparyval); 5392 } 5393 } 5394 else { /* no, expanding (or same) */ 5395 SV** tmparyval = NULL; 5396 if (length) { 5397 Newx(tmparyval, length, SV*); /* so remember deletion */ 5398 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*); 5399 } 5400 5401 if (diff > 0) { /* expanding */ 5402 /* push up or down? */ 5403 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) { 5404 if (offset) { 5405 src = AvARRAY(ary); 5406 dst = src - diff; 5407 Move(src, dst, offset, SV*); 5408 } 5409 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */ 5410 AvMAX(ary) += diff; 5411 AvFILLp(ary) += diff; 5412 } 5413 else { 5414 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */ 5415 av_extend(ary, AvFILLp(ary) + diff); 5416 AvFILLp(ary) += diff; 5417 5418 if (after) { 5419 dst = AvARRAY(ary) + AvFILLp(ary); 5420 src = dst - diff; 5421 for (i = after; i; i--) { 5422 *dst-- = *src--; 5423 } 5424 } 5425 } 5426 } 5427 5428 if (newlen) { 5429 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* ); 5430 } 5431 5432 MARK = ORIGMARK + 1; 5433 if (GIMME_V == G_ARRAY) { /* copy return vals to stack */ 5434 if (length) { 5435 const bool real = cBOOL(AvREAL(ary)); 5436 if (real) 5437 EXTEND_MORTAL(length); 5438 for (i = 0, dst = MARK; i < length; i++) { 5439 if ((*dst = tmparyval[i])) { 5440 if (real) 5441 sv_2mortal(*dst); /* free them eventually */ 5442 } 5443 else *dst = &PL_sv_undef; 5444 dst++; 5445 } 5446 } 5447 MARK += length - 1; 5448 } 5449 else if (length--) { 5450 *MARK = tmparyval[length]; 5451 if (AvREAL(ary)) { 5452 sv_2mortal(*MARK); 5453 while (length-- > 0) 5454 SvREFCNT_dec(tmparyval[length]); 5455 } 5456 if (!*MARK) 5457 *MARK = &PL_sv_undef; 5458 } 5459 else 5460 *MARK = &PL_sv_undef; 5461 Safefree(tmparyval); 5462 } 5463 5464 if (SvMAGICAL(ary)) 5465 mg_set(MUTABLE_SV(ary)); 5466 5467 SP = MARK; 5468 RETURN; 5469 } 5470 5471 PP(pp_push) 5472 { 5473 dSP; dMARK; dORIGMARK; dTARGET; 5474 AV * const ary = MUTABLE_AV(*++MARK); 5475 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied); 5476 5477 if (mg) { 5478 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg); 5479 PUSHMARK(MARK); 5480 PUTBACK; 5481 ENTER_with_name("call_PUSH"); 5482 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED); 5483 LEAVE_with_name("call_PUSH"); 5484 /* SPAGAIN; not needed: SP is assigned to immediately below */ 5485 } 5486 else { 5487 /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we 5488 * only need to save locally, not on the save stack */ 5489 U16 old_delaymagic = PL_delaymagic; 5490 5491 if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify(); 5492 PL_delaymagic = DM_DELAY; 5493 for (++MARK; MARK <= SP; MARK++) { 5494 SV *sv; 5495 if (*MARK) SvGETMAGIC(*MARK); 5496 sv = newSV(0); 5497 if (*MARK) 5498 sv_setsv_nomg(sv, *MARK); 5499 av_store(ary, AvFILLp(ary)+1, sv); 5500 } 5501 if (PL_delaymagic & DM_ARRAY_ISA) 5502 mg_set(MUTABLE_SV(ary)); 5503 PL_delaymagic = old_delaymagic; 5504 } 5505 SP = ORIGMARK; 5506 if (OP_GIMME(PL_op, 0) != G_VOID) { 5507 PUSHi( AvFILL(ary) + 1 ); 5508 } 5509 RETURN; 5510 } 5511 5512 /* also used for: pp_pop()*/ 5513 PP(pp_shift) 5514 { 5515 dSP; 5516 AV * const av = PL_op->op_flags & OPf_SPECIAL 5517 ? MUTABLE_AV(GvAVn(PL_defgv)) : MUTABLE_AV(POPs); 5518 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av); 5519 EXTEND(SP, 1); 5520 assert (sv); 5521 if (AvREAL(av)) 5522 (void)sv_2mortal(sv); 5523 PUSHs(sv); 5524 RETURN; 5525 } 5526 5527 PP(pp_unshift) 5528 { 5529 dSP; dMARK; dORIGMARK; dTARGET; 5530 AV *ary = MUTABLE_AV(*++MARK); 5531 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied); 5532 5533 if (mg) { 5534 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg); 5535 PUSHMARK(MARK); 5536 PUTBACK; 5537 ENTER_with_name("call_UNSHIFT"); 5538 call_sv(SV_CONST(UNSHIFT),G_SCALAR|G_DISCARD|G_METHOD_NAMED); 5539 LEAVE_with_name("call_UNSHIFT"); 5540 /* SPAGAIN; not needed: SP is assigned to immediately below */ 5541 } 5542 else { 5543 /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we 5544 * only need to save locally, not on the save stack */ 5545 U16 old_delaymagic = PL_delaymagic; 5546 SSize_t i = 0; 5547 5548 av_unshift(ary, SP - MARK); 5549 PL_delaymagic = DM_DELAY; 5550 while (MARK < SP) { 5551 SV * const sv = newSVsv(*++MARK); 5552 (void)av_store(ary, i++, sv); 5553 } 5554 if (PL_delaymagic & DM_ARRAY_ISA) 5555 mg_set(MUTABLE_SV(ary)); 5556 PL_delaymagic = old_delaymagic; 5557 } 5558 SP = ORIGMARK; 5559 if (OP_GIMME(PL_op, 0) != G_VOID) { 5560 PUSHi( AvFILL(ary) + 1 ); 5561 } 5562 RETURN; 5563 } 5564 5565 PP(pp_reverse) 5566 { 5567 dSP; dMARK; 5568 5569 if (GIMME_V == G_ARRAY) { 5570 if (PL_op->op_private & OPpREVERSE_INPLACE) { 5571 AV *av; 5572 5573 /* See pp_sort() */ 5574 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV); 5575 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */ 5576 av = MUTABLE_AV((*SP)); 5577 /* In-place reversing only happens in void context for the array 5578 * assignment. We don't need to push anything on the stack. */ 5579 SP = MARK; 5580 5581 if (SvMAGICAL(av)) { 5582 SSize_t i, j; 5583 SV *tmp = sv_newmortal(); 5584 /* For SvCANEXISTDELETE */ 5585 HV *stash; 5586 const MAGIC *mg; 5587 bool can_preserve = SvCANEXISTDELETE(av); 5588 5589 for (i = 0, j = av_tindex(av); i < j; ++i, --j) { 5590 SV *begin, *end; 5591 5592 if (can_preserve) { 5593 if (!av_exists(av, i)) { 5594 if (av_exists(av, j)) { 5595 SV *sv = av_delete(av, j, 0); 5596 begin = *av_fetch(av, i, TRUE); 5597 sv_setsv_mg(begin, sv); 5598 } 5599 continue; 5600 } 5601 else if (!av_exists(av, j)) { 5602 SV *sv = av_delete(av, i, 0); 5603 end = *av_fetch(av, j, TRUE); 5604 sv_setsv_mg(end, sv); 5605 continue; 5606 } 5607 } 5608 5609 begin = *av_fetch(av, i, TRUE); 5610 end = *av_fetch(av, j, TRUE); 5611 sv_setsv(tmp, begin); 5612 sv_setsv_mg(begin, end); 5613 sv_setsv_mg(end, tmp); 5614 } 5615 } 5616 else { 5617 SV **begin = AvARRAY(av); 5618 5619 if (begin) { 5620 SV **end = begin + AvFILLp(av); 5621 5622 while (begin < end) { 5623 SV * const tmp = *begin; 5624 *begin++ = *end; 5625 *end-- = tmp; 5626 } 5627 } 5628 } 5629 } 5630 else { 5631 SV **oldsp = SP; 5632 MARK++; 5633 while (MARK < SP) { 5634 SV * const tmp = *MARK; 5635 *MARK++ = *SP; 5636 *SP-- = tmp; 5637 } 5638 /* safe as long as stack cannot get extended in the above */ 5639 SP = oldsp; 5640 } 5641 } 5642 else { 5643 char *up; 5644 dTARGET; 5645 STRLEN len; 5646 5647 SvUTF8_off(TARG); /* decontaminate */ 5648 if (SP - MARK > 1) { 5649 do_join(TARG, &PL_sv_no, MARK, SP); 5650 SP = MARK + 1; 5651 SETs(TARG); 5652 } else if (SP > MARK) { 5653 sv_setsv(TARG, *SP); 5654 SETs(TARG); 5655 } else { 5656 sv_setsv(TARG, DEFSV); 5657 XPUSHs(TARG); 5658 } 5659 5660 up = SvPV_force(TARG, len); 5661 if (len > 1) { 5662 char *down; 5663 if (DO_UTF8(TARG)) { /* first reverse each character */ 5664 U8* s = (U8*)SvPVX(TARG); 5665 const U8* send = (U8*)(s + len); 5666 while (s < send) { 5667 if (UTF8_IS_INVARIANT(*s)) { 5668 s++; 5669 continue; 5670 } 5671 else { 5672 if (!utf8_to_uvchr_buf(s, send, 0)) 5673 break; 5674 up = (char*)s; 5675 s += UTF8SKIP(s); 5676 down = (char*)(s - 1); 5677 /* reverse this character */ 5678 while (down > up) { 5679 const char tmp = *up; 5680 *up++ = *down; 5681 *down-- = tmp; 5682 } 5683 } 5684 } 5685 up = SvPVX(TARG); 5686 } 5687 down = SvPVX(TARG) + len - 1; 5688 while (down > up) { 5689 const char tmp = *up; 5690 *up++ = *down; 5691 *down-- = tmp; 5692 } 5693 (void)SvPOK_only_UTF8(TARG); 5694 } 5695 } 5696 RETURN; 5697 } 5698 5699 PP(pp_split) 5700 { 5701 dSP; dTARG; 5702 AV *ary = ( (PL_op->op_private & OPpSPLIT_ASSIGN) /* @a = split */ 5703 && (PL_op->op_flags & OPf_STACKED)) /* @{expr} = split */ 5704 ? (AV *)POPs : NULL; 5705 IV limit = POPi; /* note, negative is forever */ 5706 SV * const sv = POPs; 5707 STRLEN len; 5708 const char *s = SvPV_const(sv, len); 5709 const bool do_utf8 = DO_UTF8(sv); 5710 const bool in_uni_8_bit = IN_UNI_8_BIT; 5711 const char *strend = s + len; 5712 PMOP *pm = cPMOPx(PL_op); 5713 REGEXP *rx; 5714 SV *dstr; 5715 const char *m; 5716 SSize_t iters = 0; 5717 const STRLEN slen = do_utf8 5718 ? utf8_length((U8*)s, (U8*)strend) 5719 : (STRLEN)(strend - s); 5720 SSize_t maxiters = slen + 10; 5721 I32 trailing_empty = 0; 5722 const char *orig; 5723 const IV origlimit = limit; 5724 I32 realarray = 0; 5725 I32 base; 5726 const U8 gimme = GIMME_V; 5727 bool gimme_scalar; 5728 I32 oldsave = PL_savestack_ix; 5729 U32 make_mortal = SVs_TEMP; 5730 bool multiline = 0; 5731 MAGIC *mg = NULL; 5732 5733 rx = PM_GETRE(pm); 5734 5735 TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET && 5736 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE))); 5737 5738 /* handle @ary = split(...) optimisation */ 5739 if (PL_op->op_private & OPpSPLIT_ASSIGN) { 5740 if (!(PL_op->op_flags & OPf_STACKED)) { 5741 if (PL_op->op_private & OPpSPLIT_LEX) { 5742 if (PL_op->op_private & OPpLVAL_INTRO) 5743 SAVECLEARSV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)); 5744 ary = (AV *)PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff); 5745 } 5746 else { 5747 GV *gv = 5748 #ifdef USE_ITHREADS 5749 MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)); 5750 #else 5751 pm->op_pmreplrootu.op_pmtargetgv; 5752 #endif 5753 if (PL_op->op_private & OPpLVAL_INTRO) 5754 ary = save_ary(gv); 5755 else 5756 ary = GvAVn(gv); 5757 } 5758 /* skip anything pushed by OPpLVAL_INTRO above */ 5759 oldsave = PL_savestack_ix; 5760 } 5761 5762 realarray = 1; 5763 PUTBACK; 5764 av_extend(ary,0); 5765 (void)sv_2mortal(SvREFCNT_inc_simple_NN(sv)); 5766 av_clear(ary); 5767 SPAGAIN; 5768 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) { 5769 PUSHMARK(SP); 5770 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg)); 5771 } 5772 else { 5773 if (!AvREAL(ary)) { 5774 I32 i; 5775 AvREAL_on(ary); 5776 AvREIFY_off(ary); 5777 for (i = AvFILLp(ary); i >= 0; i--) 5778 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */ 5779 } 5780 /* temporarily switch stacks */ 5781 SAVESWITCHSTACK(PL_curstack, ary); 5782 make_mortal = 0; 5783 } 5784 } 5785 5786 base = SP - PL_stack_base; 5787 orig = s; 5788 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) { 5789 if (do_utf8) { 5790 while (s < strend && isSPACE_utf8_safe(s, strend)) 5791 s += UTF8SKIP(s); 5792 } 5793 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) { 5794 while (s < strend && isSPACE_LC(*s)) 5795 s++; 5796 } 5797 else if (in_uni_8_bit) { 5798 while (s < strend && isSPACE_L1(*s)) 5799 s++; 5800 } 5801 else { 5802 while (s < strend && isSPACE(*s)) 5803 s++; 5804 } 5805 } 5806 if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) { 5807 multiline = 1; 5808 } 5809 5810 gimme_scalar = gimme == G_SCALAR && !ary; 5811 5812 if (!limit) 5813 limit = maxiters + 2; 5814 if (RX_EXTFLAGS(rx) & RXf_WHITE) { 5815 while (--limit) { 5816 m = s; 5817 /* this one uses 'm' and is a negative test */ 5818 if (do_utf8) { 5819 while (m < strend && ! isSPACE_utf8_safe(m, strend) ) { 5820 const int t = UTF8SKIP(m); 5821 /* isSPACE_utf8_safe returns FALSE for malform utf8 */ 5822 if (strend - m < t) 5823 m = strend; 5824 else 5825 m += t; 5826 } 5827 } 5828 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) 5829 { 5830 while (m < strend && !isSPACE_LC(*m)) 5831 ++m; 5832 } 5833 else if (in_uni_8_bit) { 5834 while (m < strend && !isSPACE_L1(*m)) 5835 ++m; 5836 } else { 5837 while (m < strend && !isSPACE(*m)) 5838 ++m; 5839 } 5840 if (m >= strend) 5841 break; 5842 5843 if (gimme_scalar) { 5844 iters++; 5845 if (m-s == 0) 5846 trailing_empty++; 5847 else 5848 trailing_empty = 0; 5849 } else { 5850 dstr = newSVpvn_flags(s, m-s, 5851 (do_utf8 ? SVf_UTF8 : 0) | make_mortal); 5852 XPUSHs(dstr); 5853 } 5854 5855 /* skip the whitespace found last */ 5856 if (do_utf8) 5857 s = m + UTF8SKIP(m); 5858 else 5859 s = m + 1; 5860 5861 /* this one uses 's' and is a positive test */ 5862 if (do_utf8) { 5863 while (s < strend && isSPACE_utf8_safe(s, strend) ) 5864 s += UTF8SKIP(s); 5865 } 5866 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) 5867 { 5868 while (s < strend && isSPACE_LC(*s)) 5869 ++s; 5870 } 5871 else if (in_uni_8_bit) { 5872 while (s < strend && isSPACE_L1(*s)) 5873 ++s; 5874 } else { 5875 while (s < strend && isSPACE(*s)) 5876 ++s; 5877 } 5878 } 5879 } 5880 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) { 5881 while (--limit) { 5882 for (m = s; m < strend && *m != '\n'; m++) 5883 ; 5884 m++; 5885 if (m >= strend) 5886 break; 5887 5888 if (gimme_scalar) { 5889 iters++; 5890 if (m-s == 0) 5891 trailing_empty++; 5892 else 5893 trailing_empty = 0; 5894 } else { 5895 dstr = newSVpvn_flags(s, m-s, 5896 (do_utf8 ? SVf_UTF8 : 0) | make_mortal); 5897 XPUSHs(dstr); 5898 } 5899 s = m; 5900 } 5901 } 5902 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) { 5903 /* 5904 Pre-extend the stack, either the number of bytes or 5905 characters in the string or a limited amount, triggered by: 5906 5907 my ($x, $y) = split //, $str; 5908 or 5909 split //, $str, $i; 5910 */ 5911 if (!gimme_scalar) { 5912 const IV items = limit - 1; 5913 /* setting it to -1 will trigger a panic in EXTEND() */ 5914 const SSize_t sslen = slen > SSize_t_MAX ? -1 : (SSize_t)slen; 5915 if (items >=0 && items < sslen) 5916 EXTEND(SP, items); 5917 else 5918 EXTEND(SP, sslen); 5919 } 5920 5921 if (do_utf8) { 5922 while (--limit) { 5923 /* keep track of how many bytes we skip over */ 5924 m = s; 5925 s += UTF8SKIP(s); 5926 if (gimme_scalar) { 5927 iters++; 5928 if (s-m == 0) 5929 trailing_empty++; 5930 else 5931 trailing_empty = 0; 5932 } else { 5933 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal); 5934 5935 PUSHs(dstr); 5936 } 5937 5938 if (s >= strend) 5939 break; 5940 } 5941 } else { 5942 while (--limit) { 5943 if (gimme_scalar) { 5944 iters++; 5945 } else { 5946 dstr = newSVpvn(s, 1); 5947 5948 5949 if (make_mortal) 5950 sv_2mortal(dstr); 5951 5952 PUSHs(dstr); 5953 } 5954 5955 s++; 5956 5957 if (s >= strend) 5958 break; 5959 } 5960 } 5961 } 5962 else if (do_utf8 == (RX_UTF8(rx) != 0) && 5963 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx) 5964 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL) 5965 && !(RX_EXTFLAGS(rx) & RXf_IS_ANCHORED)) { 5966 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL); 5967 SV * const csv = CALLREG_INTUIT_STRING(rx); 5968 5969 len = RX_MINLENRET(rx); 5970 if (len == 1 && !RX_UTF8(rx) && !tail) { 5971 const char c = *SvPV_nolen_const(csv); 5972 while (--limit) { 5973 for (m = s; m < strend && *m != c; m++) 5974 ; 5975 if (m >= strend) 5976 break; 5977 if (gimme_scalar) { 5978 iters++; 5979 if (m-s == 0) 5980 trailing_empty++; 5981 else 5982 trailing_empty = 0; 5983 } else { 5984 dstr = newSVpvn_flags(s, m-s, 5985 (do_utf8 ? SVf_UTF8 : 0) | make_mortal); 5986 XPUSHs(dstr); 5987 } 5988 /* The rx->minlen is in characters but we want to step 5989 * s ahead by bytes. */ 5990 if (do_utf8) 5991 s = (char*)utf8_hop((U8*)m, len); 5992 else 5993 s = m + len; /* Fake \n at the end */ 5994 } 5995 } 5996 else { 5997 while (s < strend && --limit && 5998 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend, 5999 csv, multiline ? FBMrf_MULTILINE : 0)) ) 6000 { 6001 if (gimme_scalar) { 6002 iters++; 6003 if (m-s == 0) 6004 trailing_empty++; 6005 else 6006 trailing_empty = 0; 6007 } else { 6008 dstr = newSVpvn_flags(s, m-s, 6009 (do_utf8 ? SVf_UTF8 : 0) | make_mortal); 6010 XPUSHs(dstr); 6011 } 6012 /* The rx->minlen is in characters but we want to step 6013 * s ahead by bytes. */ 6014 if (do_utf8) 6015 s = (char*)utf8_hop((U8*)m, len); 6016 else 6017 s = m + len; /* Fake \n at the end */ 6018 } 6019 } 6020 } 6021 else { 6022 maxiters += slen * RX_NPARENS(rx); 6023 while (s < strend && --limit) 6024 { 6025 I32 rex_return; 6026 PUTBACK; 6027 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1, 6028 sv, NULL, 0); 6029 SPAGAIN; 6030 if (rex_return == 0) 6031 break; 6032 TAINT_IF(RX_MATCH_TAINTED(rx)); 6033 /* we never pass the REXEC_COPY_STR flag, so it should 6034 * never get copied */ 6035 assert(!RX_MATCH_COPIED(rx)); 6036 m = RX_OFFS(rx)[0].start + orig; 6037 6038 if (gimme_scalar) { 6039 iters++; 6040 if (m-s == 0) 6041 trailing_empty++; 6042 else 6043 trailing_empty = 0; 6044 } else { 6045 dstr = newSVpvn_flags(s, m-s, 6046 (do_utf8 ? SVf_UTF8 : 0) | make_mortal); 6047 XPUSHs(dstr); 6048 } 6049 if (RX_NPARENS(rx)) { 6050 I32 i; 6051 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) { 6052 s = RX_OFFS(rx)[i].start + orig; 6053 m = RX_OFFS(rx)[i].end + orig; 6054 6055 /* japhy (07/27/01) -- the (m && s) test doesn't catch 6056 parens that didn't match -- they should be set to 6057 undef, not the empty string */ 6058 if (gimme_scalar) { 6059 iters++; 6060 if (m-s == 0) 6061 trailing_empty++; 6062 else 6063 trailing_empty = 0; 6064 } else { 6065 if (m >= orig && s >= orig) { 6066 dstr = newSVpvn_flags(s, m-s, 6067 (do_utf8 ? SVf_UTF8 : 0) 6068 | make_mortal); 6069 } 6070 else 6071 dstr = &PL_sv_undef; /* undef, not "" */ 6072 XPUSHs(dstr); 6073 } 6074 6075 } 6076 } 6077 s = RX_OFFS(rx)[0].end + orig; 6078 } 6079 } 6080 6081 if (!gimme_scalar) { 6082 iters = (SP - PL_stack_base) - base; 6083 } 6084 if (iters > maxiters) 6085 DIE(aTHX_ "Split loop"); 6086 6087 /* keep field after final delim? */ 6088 if (s < strend || (iters && origlimit)) { 6089 if (!gimme_scalar) { 6090 const STRLEN l = strend - s; 6091 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal); 6092 XPUSHs(dstr); 6093 } 6094 iters++; 6095 } 6096 else if (!origlimit) { 6097 if (gimme_scalar) { 6098 iters -= trailing_empty; 6099 } else { 6100 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) { 6101 if (TOPs && !make_mortal) 6102 sv_2mortal(TOPs); 6103 *SP-- = NULL; 6104 iters--; 6105 } 6106 } 6107 } 6108 6109 PUTBACK; 6110 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */ 6111 SPAGAIN; 6112 if (realarray) { 6113 if (!mg) { 6114 if (SvSMAGICAL(ary)) { 6115 PUTBACK; 6116 mg_set(MUTABLE_SV(ary)); 6117 SPAGAIN; 6118 } 6119 if (gimme == G_ARRAY) { 6120 EXTEND(SP, iters); 6121 Copy(AvARRAY(ary), SP + 1, iters, SV*); 6122 SP += iters; 6123 RETURN; 6124 } 6125 } 6126 else { 6127 PUTBACK; 6128 ENTER_with_name("call_PUSH"); 6129 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED); 6130 LEAVE_with_name("call_PUSH"); 6131 SPAGAIN; 6132 if (gimme == G_ARRAY) { 6133 SSize_t i; 6134 /* EXTEND should not be needed - we just popped them */ 6135 EXTEND(SP, iters); 6136 for (i=0; i < iters; i++) { 6137 SV **svp = av_fetch(ary, i, FALSE); 6138 PUSHs((svp) ? *svp : &PL_sv_undef); 6139 } 6140 RETURN; 6141 } 6142 } 6143 } 6144 else { 6145 if (gimme == G_ARRAY) 6146 RETURN; 6147 } 6148 6149 GETTARGET; 6150 XPUSHi(iters); 6151 RETURN; 6152 } 6153 6154 PP(pp_once) 6155 { 6156 dSP; 6157 SV *const sv = PAD_SVl(PL_op->op_targ); 6158 6159 if (SvPADSTALE(sv)) { 6160 /* First time. */ 6161 SvPADSTALE_off(sv); 6162 RETURNOP(cLOGOP->op_other); 6163 } 6164 RETURNOP(cLOGOP->op_next); 6165 } 6166 6167 PP(pp_lock) 6168 { 6169 dSP; 6170 dTOPss; 6171 SV *retsv = sv; 6172 SvLOCK(sv); 6173 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV 6174 || SvTYPE(retsv) == SVt_PVCV) { 6175 retsv = refto(retsv); 6176 } 6177 SETs(retsv); 6178 RETURN; 6179 } 6180 6181 6182 /* used for: pp_padany(), pp_custom(); plus any system ops 6183 * that aren't implemented on a particular platform */ 6184 6185 PP(unimplemented_op) 6186 { 6187 const Optype op_type = PL_op->op_type; 6188 /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope 6189 with out of range op numbers - it only "special" cases op_custom. 6190 Secondly, as the three ops we "panic" on are padmy, mapstart and custom, 6191 if we get here for a custom op then that means that the custom op didn't 6192 have an implementation. Given that OP_NAME() looks up the custom op 6193 by its pp_addr, likely it will return NULL, unless someone (unhelpfully) 6194 registers &PL_unimplemented_op as the address of their custom op. 6195 NULL doesn't generate a useful error message. "custom" does. */ 6196 const char *const name = op_type >= OP_max 6197 ? "[out of range]" : PL_op_name[PL_op->op_type]; 6198 if(OP_IS_SOCKET(op_type)) 6199 DIE(aTHX_ PL_no_sock_func, name); 6200 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name, op_type); 6201 } 6202 6203 static void 6204 S_maybe_unwind_defav(pTHX) 6205 { 6206 if (CX_CUR()->cx_type & CXp_HASARGS) { 6207 PERL_CONTEXT *cx = CX_CUR(); 6208 6209 assert(CxHASARGS(cx)); 6210 cx_popsub_args(cx); 6211 cx->cx_type &= ~CXp_HASARGS; 6212 } 6213 } 6214 6215 /* For sorting out arguments passed to a &CORE:: subroutine */ 6216 PP(pp_coreargs) 6217 { 6218 dSP; 6219 int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0; 6220 int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0; 6221 AV * const at_ = GvAV(PL_defgv); 6222 SV **svp = at_ ? AvARRAY(at_) : NULL; 6223 I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0; 6224 I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0; 6225 bool seen_question = 0; 6226 const char *err = NULL; 6227 const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK; 6228 6229 /* Count how many args there are first, to get some idea how far to 6230 extend the stack. */ 6231 while (oa) { 6232 if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; } 6233 maxargs++; 6234 if (oa & OA_OPTIONAL) seen_question = 1; 6235 if (!seen_question) minargs++; 6236 oa >>= 4; 6237 } 6238 6239 if(numargs < minargs) err = "Not enough"; 6240 else if(numargs > maxargs) err = "Too many"; 6241 if (err) 6242 /* diag_listed_as: Too many arguments for %s */ 6243 Perl_croak(aTHX_ 6244 "%s arguments for %s", err, 6245 opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv) 6246 ); 6247 6248 /* Reset the stack pointer. Without this, we end up returning our own 6249 arguments in list context, in addition to the values we are supposed 6250 to return. nextstate usually does this on sub entry, but we need 6251 to run the next op with the caller's hints, so we cannot have a 6252 nextstate. */ 6253 SP = PL_stack_base + CX_CUR()->blk_oldsp; 6254 6255 if(!maxargs) RETURN; 6256 6257 /* We do this here, rather than with a separate pushmark op, as it has 6258 to come in between two things this function does (stack reset and 6259 arg pushing). This seems the easiest way to do it. */ 6260 if (pushmark) { 6261 PUTBACK; 6262 (void)Perl_pp_pushmark(aTHX); 6263 } 6264 6265 EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs); 6266 PUTBACK; /* The code below can die in various places. */ 6267 6268 oa = PL_opargs[opnum] >> OASHIFT; 6269 for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) { 6270 whicharg++; 6271 switch (oa & 7) { 6272 case OA_SCALAR: 6273 try_defsv: 6274 if (!numargs && defgv && whicharg == minargs + 1) { 6275 PUSHs(DEFSV); 6276 } 6277 else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL); 6278 break; 6279 case OA_LIST: 6280 while (numargs--) { 6281 PUSHs(svp && *svp ? *svp : &PL_sv_undef); 6282 svp++; 6283 } 6284 RETURN; 6285 case OA_AVREF: 6286 if (!numargs) { 6287 GV *gv; 6288 if (CvUNIQUE(find_runcv_where(FIND_RUNCV_level_eq,1,NULL))) 6289 gv = PL_argvgv; 6290 else { 6291 S_maybe_unwind_defav(aTHX); 6292 gv = PL_defgv; 6293 } 6294 PUSHs((SV *)GvAVn(gv)); 6295 break; 6296 } 6297 if (!svp || !*svp || !SvROK(*svp) 6298 || SvTYPE(SvRV(*svp)) != SVt_PVAV) 6299 DIE(aTHX_ 6300 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/ 6301 "Type of arg %d to &CORE::%s must be array reference", 6302 whicharg, PL_op_desc[opnum] 6303 ); 6304 PUSHs(SvRV(*svp)); 6305 break; 6306 case OA_HVREF: 6307 if (!svp || !*svp || !SvROK(*svp) 6308 || ( SvTYPE(SvRV(*svp)) != SVt_PVHV 6309 && ( opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN 6310 || SvTYPE(SvRV(*svp)) != SVt_PVAV ))) 6311 DIE(aTHX_ 6312 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/ 6313 "Type of arg %d to &CORE::%s must be hash%s reference", 6314 whicharg, PL_op_desc[opnum], 6315 opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN 6316 ? "" 6317 : " or array" 6318 ); 6319 PUSHs(SvRV(*svp)); 6320 break; 6321 case OA_FILEREF: 6322 if (!numargs) PUSHs(NULL); 6323 else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp))) 6324 /* no magic here, as the prototype will have added an extra 6325 refgen and we just want what was there before that */ 6326 PUSHs(SvRV(*svp)); 6327 else { 6328 const bool constr = PL_op->op_private & whicharg; 6329 PUSHs(S_rv2gv(aTHX_ 6330 svp && *svp ? *svp : &PL_sv_undef, 6331 constr, cBOOL(CopHINTS_get(PL_curcop) & HINT_STRICT_REFS), 6332 !constr 6333 )); 6334 } 6335 break; 6336 case OA_SCALARREF: 6337 if (!numargs) goto try_defsv; 6338 else { 6339 const bool wantscalar = 6340 PL_op->op_private & OPpCOREARGS_SCALARMOD; 6341 if (!svp || !*svp || !SvROK(*svp) 6342 /* We have to permit globrefs even for the \$ proto, as 6343 *foo is indistinguishable from ${\*foo}, and the proto- 6344 type permits the latter. */ 6345 || SvTYPE(SvRV(*svp)) > ( 6346 wantscalar ? SVt_PVLV 6347 : opnum == OP_LOCK || opnum == OP_UNDEF 6348 ? SVt_PVCV 6349 : SVt_PVHV 6350 ) 6351 ) 6352 DIE(aTHX_ 6353 "Type of arg %d to &CORE::%s must be %s", 6354 whicharg, PL_op_name[opnum], 6355 wantscalar 6356 ? "scalar reference" 6357 : opnum == OP_LOCK || opnum == OP_UNDEF 6358 ? "reference to one of [$@%&*]" 6359 : "reference to one of [$@%*]" 6360 ); 6361 PUSHs(SvRV(*svp)); 6362 if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv) { 6363 /* Undo @_ localisation, so that sub exit does not undo 6364 part of our undeffing. */ 6365 S_maybe_unwind_defav(aTHX); 6366 } 6367 } 6368 break; 6369 default: 6370 DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7)); 6371 } 6372 oa = oa >> 4; 6373 } 6374 6375 RETURN; 6376 } 6377 6378 /* Implement CORE::keys(),values(),each(). 6379 * 6380 * We won't know until run-time whether the arg is an array or hash, 6381 * so this op calls 6382 * 6383 * pp_keys/pp_values/pp_each 6384 * or 6385 * pp_akeys/pp_avalues/pp_aeach 6386 * 6387 * as appropriate (or whatever pp function actually implements the OP_FOO 6388 * functionality for each FOO). 6389 */ 6390 6391 PP(pp_avhvswitch) 6392 { 6393 dVAR; dSP; 6394 return PL_ppaddr[ 6395 (SvTYPE(TOPs) == SVt_PVAV ? OP_AEACH : OP_EACH) 6396 + (PL_op->op_private & OPpAVHVSWITCH_MASK) 6397 ](aTHX); 6398 } 6399 6400 PP(pp_runcv) 6401 { 6402 dSP; 6403 CV *cv; 6404 if (PL_op->op_private & OPpOFFBYONE) { 6405 cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL); 6406 } 6407 else cv = find_runcv(NULL); 6408 XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv))); 6409 RETURN; 6410 } 6411 6412 static void 6413 S_localise_aelem_lval(pTHX_ AV * const av, SV * const keysv, 6414 const bool can_preserve) 6415 { 6416 const SSize_t ix = SvIV(keysv); 6417 if (can_preserve ? av_exists(av, ix) : TRUE) { 6418 SV ** const svp = av_fetch(av, ix, 1); 6419 if (!svp || !*svp) 6420 Perl_croak(aTHX_ PL_no_aelem, ix); 6421 save_aelem(av, ix, svp); 6422 } 6423 else 6424 SAVEADELETE(av, ix); 6425 } 6426 6427 static void 6428 S_localise_helem_lval(pTHX_ HV * const hv, SV * const keysv, 6429 const bool can_preserve) 6430 { 6431 if (can_preserve ? hv_exists_ent(hv, keysv, 0) : TRUE) { 6432 HE * const he = hv_fetch_ent(hv, keysv, 1, 0); 6433 SV ** const svp = he ? &HeVAL(he) : NULL; 6434 if (!svp || !*svp) 6435 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(keysv)); 6436 save_helem_flags(hv, keysv, svp, 0); 6437 } 6438 else 6439 SAVEHDELETE(hv, keysv); 6440 } 6441 6442 static void 6443 S_localise_gv_slot(pTHX_ GV *gv, U8 type) 6444 { 6445 if (type == OPpLVREF_SV) { 6446 save_pushptrptr(gv, SvREFCNT_inc_simple(GvSV(gv)), SAVEt_GVSV); 6447 GvSV(gv) = 0; 6448 } 6449 else if (type == OPpLVREF_AV) 6450 /* XXX Inefficient, as it creates a new AV, which we are 6451 about to clobber. */ 6452 save_ary(gv); 6453 else { 6454 assert(type == OPpLVREF_HV); 6455 /* XXX Likewise inefficient. */ 6456 save_hash(gv); 6457 } 6458 } 6459 6460 6461 PP(pp_refassign) 6462 { 6463 dSP; 6464 SV * const key = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL; 6465 SV * const left = PL_op->op_flags & OPf_STACKED ? POPs : NULL; 6466 dTOPss; 6467 const char *bad = NULL; 6468 const U8 type = PL_op->op_private & OPpLVREF_TYPE; 6469 if (!SvROK(sv)) DIE(aTHX_ "Assigned value is not a reference"); 6470 switch (type) { 6471 case OPpLVREF_SV: 6472 if (SvTYPE(SvRV(sv)) > SVt_PVLV) 6473 bad = " SCALAR"; 6474 break; 6475 case OPpLVREF_AV: 6476 if (SvTYPE(SvRV(sv)) != SVt_PVAV) 6477 bad = "n ARRAY"; 6478 break; 6479 case OPpLVREF_HV: 6480 if (SvTYPE(SvRV(sv)) != SVt_PVHV) 6481 bad = " HASH"; 6482 break; 6483 case OPpLVREF_CV: 6484 if (SvTYPE(SvRV(sv)) != SVt_PVCV) 6485 bad = " CODE"; 6486 } 6487 if (bad) 6488 /* diag_listed_as: Assigned value is not %s reference */ 6489 DIE(aTHX_ "Assigned value is not a%s reference", bad); 6490 { 6491 MAGIC *mg; 6492 HV *stash; 6493 switch (left ? SvTYPE(left) : 0) { 6494 case 0: 6495 { 6496 SV * const old = PAD_SV(ARGTARG); 6497 PAD_SETSV(ARGTARG, SvREFCNT_inc_NN(SvRV(sv))); 6498 SvREFCNT_dec(old); 6499 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) 6500 == OPpLVAL_INTRO) 6501 SAVECLEARSV(PAD_SVl(ARGTARG)); 6502 break; 6503 } 6504 case SVt_PVGV: 6505 if (PL_op->op_private & OPpLVAL_INTRO) { 6506 S_localise_gv_slot(aTHX_ (GV *)left, type); 6507 } 6508 gv_setref(left, sv); 6509 SvSETMAGIC(left); 6510 break; 6511 case SVt_PVAV: 6512 assert(key); 6513 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) { 6514 S_localise_aelem_lval(aTHX_ (AV *)left, key, 6515 SvCANEXISTDELETE(left)); 6516 } 6517 av_store((AV *)left, SvIV(key), SvREFCNT_inc_simple_NN(SvRV(sv))); 6518 break; 6519 case SVt_PVHV: 6520 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) { 6521 assert(key); 6522 S_localise_helem_lval(aTHX_ (HV *)left, key, 6523 SvCANEXISTDELETE(left)); 6524 } 6525 (void)hv_store_ent((HV *)left, key, SvREFCNT_inc_simple_NN(SvRV(sv)), 0); 6526 } 6527 if (PL_op->op_flags & OPf_MOD) 6528 SETs(sv_2mortal(newSVsv(sv))); 6529 /* XXX else can weak references go stale before they are read, e.g., 6530 in leavesub? */ 6531 RETURN; 6532 } 6533 } 6534 6535 PP(pp_lvref) 6536 { 6537 dSP; 6538 SV * const ret = sv_2mortal(newSV_type(SVt_PVMG)); 6539 SV * const elem = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL; 6540 SV * const arg = PL_op->op_flags & OPf_STACKED ? POPs : NULL; 6541 MAGIC * const mg = sv_magicext(ret, arg, PERL_MAGIC_lvref, 6542 &PL_vtbl_lvref, (char *)elem, 6543 elem ? HEf_SVKEY : (I32)ARGTARG); 6544 mg->mg_private = PL_op->op_private; 6545 if (PL_op->op_private & OPpLVREF_ITER) 6546 mg->mg_flags |= MGf_PERSIST; 6547 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) { 6548 if (elem) { 6549 MAGIC *mg; 6550 HV *stash; 6551 assert(arg); 6552 { 6553 const bool can_preserve = SvCANEXISTDELETE(arg); 6554 if (SvTYPE(arg) == SVt_PVAV) 6555 S_localise_aelem_lval(aTHX_ (AV *)arg, elem, can_preserve); 6556 else 6557 S_localise_helem_lval(aTHX_ (HV *)arg, elem, can_preserve); 6558 } 6559 } 6560 else if (arg) { 6561 S_localise_gv_slot(aTHX_ (GV *)arg, 6562 PL_op->op_private & OPpLVREF_TYPE); 6563 } 6564 else if (!(PL_op->op_private & OPpPAD_STATE)) 6565 SAVECLEARSV(PAD_SVl(ARGTARG)); 6566 } 6567 XPUSHs(ret); 6568 RETURN; 6569 } 6570 6571 PP(pp_lvrefslice) 6572 { 6573 dSP; dMARK; 6574 AV * const av = (AV *)POPs; 6575 const bool localizing = PL_op->op_private & OPpLVAL_INTRO; 6576 bool can_preserve = FALSE; 6577 6578 if (UNLIKELY(localizing)) { 6579 MAGIC *mg; 6580 HV *stash; 6581 SV **svp; 6582 6583 can_preserve = SvCANEXISTDELETE(av); 6584 6585 if (SvTYPE(av) == SVt_PVAV) { 6586 SSize_t max = -1; 6587 6588 for (svp = MARK + 1; svp <= SP; svp++) { 6589 const SSize_t elem = SvIV(*svp); 6590 if (elem > max) 6591 max = elem; 6592 } 6593 if (max > AvMAX(av)) 6594 av_extend(av, max); 6595 } 6596 } 6597 6598 while (++MARK <= SP) { 6599 SV * const elemsv = *MARK; 6600 if (SvTYPE(av) == SVt_PVAV) 6601 S_localise_aelem_lval(aTHX_ av, elemsv, can_preserve); 6602 else 6603 S_localise_helem_lval(aTHX_ (HV *)av, elemsv, can_preserve); 6604 *MARK = sv_2mortal(newSV_type(SVt_PVMG)); 6605 sv_magic(*MARK,(SV *)av,PERL_MAGIC_lvref,(char *)elemsv,HEf_SVKEY); 6606 } 6607 RETURN; 6608 } 6609 6610 PP(pp_lvavref) 6611 { 6612 if (PL_op->op_flags & OPf_STACKED) 6613 Perl_pp_rv2av(aTHX); 6614 else 6615 Perl_pp_padav(aTHX); 6616 { 6617 dSP; 6618 dTOPss; 6619 SETs(0); /* special alias marker that aassign recognises */ 6620 XPUSHs(sv); 6621 RETURN; 6622 } 6623 } 6624 6625 PP(pp_anonconst) 6626 { 6627 dSP; 6628 dTOPss; 6629 SETs(sv_2mortal((SV *)newCONSTSUB(SvTYPE(CopSTASH(PL_curcop))==SVt_PVHV 6630 ? CopSTASH(PL_curcop) 6631 : NULL, 6632 NULL, SvREFCNT_inc_simple_NN(sv)))); 6633 RETURN; 6634 } 6635 6636 6637 /* process one subroutine argument - typically when the sub has a signature: 6638 * introduce PL_curpad[op_targ] and assign to it the value 6639 * for $: (OPf_STACKED ? *sp : $_[N]) 6640 * for @/%: @_[N..$#_] 6641 * 6642 * It's equivalent to 6643 * my $foo = $_[N]; 6644 * or 6645 * my $foo = (value-on-stack) 6646 * or 6647 * my @foo = @_[N..$#_] 6648 * etc 6649 */ 6650 6651 PP(pp_argelem) 6652 { 6653 dTARG; 6654 SV *val; 6655 SV ** padentry; 6656 OP *o = PL_op; 6657 AV *defav = GvAV(PL_defgv); /* @_ */ 6658 IV ix = PTR2IV(cUNOP_AUXo->op_aux); 6659 IV argc; 6660 6661 /* do 'my $var, @var or %var' action */ 6662 padentry = &(PAD_SVl(o->op_targ)); 6663 save_clearsv(padentry); 6664 targ = *padentry; 6665 6666 if ((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_SV) { 6667 if (o->op_flags & OPf_STACKED) { 6668 dSP; 6669 val = POPs; 6670 PUTBACK; 6671 } 6672 else { 6673 SV **svp; 6674 /* should already have been checked */ 6675 assert(ix >= 0); 6676 #if IVSIZE > PTRSIZE 6677 assert(ix <= SSize_t_MAX); 6678 #endif 6679 6680 svp = av_fetch(defav, ix, FALSE); 6681 val = svp ? *svp : &PL_sv_undef; 6682 } 6683 6684 /* $var = $val */ 6685 6686 /* cargo-culted from pp_sassign */ 6687 assert(TAINTING_get || !TAINT_get); 6688 if (UNLIKELY(TAINT_get) && !SvTAINTED(val)) 6689 TAINT_NOT; 6690 6691 SvSetMagicSV(targ, val); 6692 return o->op_next; 6693 } 6694 6695 /* must be AV or HV */ 6696 6697 assert(!(o->op_flags & OPf_STACKED)); 6698 argc = ((IV)AvFILL(defav) + 1) - ix; 6699 6700 /* This is a copy of the relevant parts of pp_aassign(). 6701 */ 6702 if ((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_AV) { 6703 IV i; 6704 6705 if (AvFILL((AV*)targ) > -1) { 6706 /* target should usually be empty. If we get get 6707 * here, someone's been doing some weird closure tricks. 6708 * Make a copy of all args before clearing the array, 6709 * to avoid the equivalent of @a = ($a[0]) prematurely freeing 6710 * elements. See similar code in pp_aassign. 6711 */ 6712 for (i = 0; i < argc; i++) { 6713 SV **svp = av_fetch(defav, ix + i, FALSE); 6714 SV *newsv = newSV(0); 6715 sv_setsv_flags(newsv, 6716 svp ? *svp : &PL_sv_undef, 6717 (SV_DO_COW_SVSETSV|SV_NOSTEAL)); 6718 if (!av_store(defav, ix + i, newsv)) 6719 SvREFCNT_dec_NN(newsv); 6720 } 6721 av_clear((AV*)targ); 6722 } 6723 6724 if (argc <= 0) 6725 return o->op_next; 6726 6727 av_extend((AV*)targ, argc); 6728 6729 i = 0; 6730 while (argc--) { 6731 SV *tmpsv; 6732 SV **svp = av_fetch(defav, ix + i, FALSE); 6733 SV *val = svp ? *svp : &PL_sv_undef; 6734 tmpsv = newSV(0); 6735 sv_setsv(tmpsv, val); 6736 av_store((AV*)targ, i++, tmpsv); 6737 TAINT_NOT; 6738 } 6739 6740 } 6741 else { 6742 IV i; 6743 6744 assert((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_HV); 6745 6746 if (SvRMAGICAL(targ) || HvUSEDKEYS((HV*)targ)) { 6747 /* see "target should usually be empty" comment above */ 6748 for (i = 0; i < argc; i++) { 6749 SV **svp = av_fetch(defav, ix + i, FALSE); 6750 SV *newsv = newSV(0); 6751 sv_setsv_flags(newsv, 6752 svp ? *svp : &PL_sv_undef, 6753 (SV_DO_COW_SVSETSV|SV_NOSTEAL)); 6754 if (!av_store(defav, ix + i, newsv)) 6755 SvREFCNT_dec_NN(newsv); 6756 } 6757 hv_clear((HV*)targ); 6758 } 6759 6760 if (argc <= 0) 6761 return o->op_next; 6762 assert(argc % 2 == 0); 6763 6764 i = 0; 6765 while (argc) { 6766 SV *tmpsv; 6767 SV **svp; 6768 SV *key; 6769 SV *val; 6770 6771 svp = av_fetch(defav, ix + i++, FALSE); 6772 key = svp ? *svp : &PL_sv_undef; 6773 svp = av_fetch(defav, ix + i++, FALSE); 6774 val = svp ? *svp : &PL_sv_undef; 6775 6776 argc -= 2; 6777 if (UNLIKELY(SvGMAGICAL(key))) 6778 key = sv_mortalcopy(key); 6779 tmpsv = newSV(0); 6780 sv_setsv(tmpsv, val); 6781 hv_store_ent((HV*)targ, key, tmpsv, 0); 6782 TAINT_NOT; 6783 } 6784 } 6785 6786 return o->op_next; 6787 } 6788 6789 /* Handle a default value for one subroutine argument (typically as part 6790 * of a subroutine signature). 6791 * It's equivalent to 6792 * @_ > op_targ ? $_[op_targ] : result_of(op_other) 6793 * 6794 * Intended to be used where op_next is an OP_ARGELEM 6795 * 6796 * We abuse the op_targ field slightly: it's an index into @_ rather than 6797 * into PL_curpad. 6798 */ 6799 6800 PP(pp_argdefelem) 6801 { 6802 OP * const o = PL_op; 6803 AV *defav = GvAV(PL_defgv); /* @_ */ 6804 IV ix = (IV)o->op_targ; 6805 6806 assert(ix >= 0); 6807 #if IVSIZE > PTRSIZE 6808 assert(ix <= SSize_t_MAX); 6809 #endif 6810 6811 if (AvFILL(defav) >= ix) { 6812 dSP; 6813 SV **svp = av_fetch(defav, ix, FALSE); 6814 SV *val = svp ? *svp : &PL_sv_undef; 6815 XPUSHs(val); 6816 RETURN; 6817 } 6818 return cLOGOPo->op_other; 6819 } 6820 6821 6822 static SV * 6823 S_find_runcv_name(void) 6824 { 6825 dTHX; 6826 CV *cv; 6827 GV *gv; 6828 SV *sv; 6829 6830 cv = find_runcv(0); 6831 if (!cv) 6832 return &PL_sv_no; 6833 6834 gv = CvGV(cv); 6835 if (!gv) 6836 return &PL_sv_no; 6837 6838 sv = sv_2mortal(newSV(0)); 6839 gv_fullname4(sv, gv, NULL, TRUE); 6840 return sv; 6841 } 6842 6843 /* Check a a subs arguments - i.e. that it has the correct number of args 6844 * (and anything else we might think of in future). Typically used with 6845 * signatured subs. 6846 */ 6847 6848 PP(pp_argcheck) 6849 { 6850 OP * const o = PL_op; 6851 UNOP_AUX_item *aux = cUNOP_AUXo->op_aux; 6852 IV params = aux[0].iv; 6853 IV opt_params = aux[1].iv; 6854 char slurpy = (char)(aux[2].iv); 6855 AV *defav = GvAV(PL_defgv); /* @_ */ 6856 IV argc; 6857 bool too_few; 6858 6859 assert(!SvMAGICAL(defav)); 6860 argc = (AvFILLp(defav) + 1); 6861 too_few = (argc < (params - opt_params)); 6862 6863 if (UNLIKELY(too_few || (!slurpy && argc > params))) 6864 /* diag_listed_as: Too few arguments for subroutine '%s' */ 6865 /* diag_listed_as: Too many arguments for subroutine '%s' */ 6866 Perl_croak_caller("Too %s arguments for subroutine '%" SVf "'", 6867 too_few ? "few" : "many", S_find_runcv_name()); 6868 6869 if (UNLIKELY(slurpy == '%' && argc > params && (argc - params) % 2)) 6870 /* diag_listed_as: Odd name/value argument for subroutine '%s' */ 6871 Perl_croak_caller("Odd name/value argument for subroutine '%" SVf "'", 6872 S_find_runcv_name()); 6873 6874 return NORMAL; 6875 } 6876 6877 /* 6878 * ex: set ts=8 sts=4 sw=4 et: 6879 */ 6880