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 MEXTEND(SP, 1); 1697 PUSHs(sv); 1698 MARK[1] = &PL_sv_undef; 1699 } 1700 SP = MARK + 2; 1701 } 1702 tryAMAGICbin_MG(repeat_amg, AMGf_assign); 1703 sv = POPs; 1704 } 1705 1706 if (SvIOKp(sv)) { 1707 if (SvUOK(sv)) { 1708 const UV uv = SvUV_nomg(sv); 1709 if (uv > IV_MAX) 1710 count = IV_MAX; /* The best we can do? */ 1711 else 1712 count = uv; 1713 } else { 1714 count = SvIV_nomg(sv); 1715 } 1716 } 1717 else if (SvNOKp(sv)) { 1718 const NV nv = SvNV_nomg(sv); 1719 infnan = Perl_isinfnan(nv); 1720 if (UNLIKELY(infnan)) { 1721 count = 0; 1722 } else { 1723 if (nv < 0.0) 1724 count = -1; /* An arbitrary negative integer */ 1725 else 1726 count = (IV)nv; 1727 } 1728 } 1729 else 1730 count = SvIV_nomg(sv); 1731 1732 if (infnan) { 1733 Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC), 1734 "Non-finite repeat count does nothing"); 1735 } else if (count < 0) { 1736 count = 0; 1737 Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC), 1738 "Negative repeat count does nothing"); 1739 } 1740 1741 if (gimme == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) { 1742 dMARK; 1743 const SSize_t items = SP - MARK; 1744 const U8 mod = PL_op->op_flags & OPf_MOD; 1745 1746 if (count > 1) { 1747 SSize_t max; 1748 1749 if ( items > SSize_t_MAX / count /* max would overflow */ 1750 /* repeatcpy would overflow */ 1751 || items > I32_MAX / (I32)sizeof(SV *) 1752 ) 1753 Perl_croak(aTHX_ "%s","Out of memory during list extend"); 1754 max = items * count; 1755 MEXTEND(MARK, max); 1756 1757 while (SP > MARK) { 1758 if (*SP) { 1759 if (mod && SvPADTMP(*SP)) { 1760 *SP = sv_mortalcopy(*SP); 1761 } 1762 SvTEMP_off((*SP)); 1763 } 1764 SP--; 1765 } 1766 MARK++; 1767 repeatcpy((char*)(MARK + items), (char*)MARK, 1768 items * sizeof(const SV *), count - 1); 1769 SP += max; 1770 } 1771 else if (count <= 0) 1772 SP = MARK; 1773 } 1774 else { /* Note: mark already snarfed by pp_list */ 1775 SV * const tmpstr = POPs; 1776 STRLEN len; 1777 bool isutf; 1778 1779 if (TARG != tmpstr) 1780 sv_setsv_nomg(TARG, tmpstr); 1781 SvPV_force_nomg(TARG, len); 1782 isutf = DO_UTF8(TARG); 1783 if (count != 1) { 1784 if (count < 1) 1785 SvCUR_set(TARG, 0); 1786 else { 1787 STRLEN max; 1788 1789 if ( len > (MEM_SIZE_MAX-1) / (UV)count /* max would overflow */ 1790 || len > (U32)I32_MAX /* repeatcpy would overflow */ 1791 ) 1792 Perl_croak(aTHX_ "%s", 1793 "Out of memory during string extend"); 1794 max = (UV)count * len + 1; 1795 SvGROW(TARG, max); 1796 1797 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1); 1798 SvCUR_set(TARG, SvCUR(TARG) * count); 1799 } 1800 *SvEND(TARG) = '\0'; 1801 } 1802 if (isutf) 1803 (void)SvPOK_only_UTF8(TARG); 1804 else 1805 (void)SvPOK_only(TARG); 1806 1807 PUSHTARG; 1808 } 1809 RETURN; 1810 } 1811 1812 PP(pp_subtract) 1813 { 1814 dSP; dATARGET; bool useleft; SV *svl, *svr; 1815 tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric); 1816 svr = TOPs; 1817 svl = TOPm1s; 1818 1819 #ifdef PERL_PRESERVE_IVUV 1820 1821 /* special-case some simple common cases */ 1822 if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) { 1823 IV il, ir; 1824 U32 flags = (svl->sv_flags & svr->sv_flags); 1825 if (flags & SVf_IOK) { 1826 /* both args are simple IVs */ 1827 UV topl, topr; 1828 il = SvIVX(svl); 1829 ir = SvIVX(svr); 1830 do_iv: 1831 topl = ((UV)il) >> (UVSIZE * 8 - 2); 1832 topr = ((UV)ir) >> (UVSIZE * 8 - 2); 1833 1834 /* if both are in a range that can't under/overflow, do a 1835 * simple integer subtract: if the top of both numbers 1836 * are 00 or 11, then it's safe */ 1837 if (!( ((topl+1) | (topr+1)) & 2)) { 1838 SP--; 1839 TARGi(il - ir, 0); /* args not GMG, so can't be tainted */ 1840 SETs(TARG); 1841 RETURN; 1842 } 1843 goto generic; 1844 } 1845 else if (flags & SVf_NOK) { 1846 /* both args are NVs */ 1847 NV nl = SvNVX(svl); 1848 NV nr = SvNVX(svr); 1849 1850 if ( 1851 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) 1852 !Perl_isnan(nl) && nl == (NV)(il = (IV)nl) 1853 && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr) 1854 #else 1855 nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr) 1856 #endif 1857 ) 1858 /* nothing was lost by converting to IVs */ 1859 goto do_iv; 1860 SP--; 1861 TARGn(nl - nr, 0); /* args not GMG, so can't be tainted */ 1862 SETs(TARG); 1863 RETURN; 1864 } 1865 } 1866 1867 generic: 1868 1869 useleft = USE_LEFT(svl); 1870 /* See comments in pp_add (in pp_hot.c) about Overflow, and how 1871 "bad things" happen if you rely on signed integers wrapping. */ 1872 if (SvIV_please_nomg(svr)) { 1873 /* Unless the left argument is integer in range we are going to have to 1874 use NV maths. Hence only attempt to coerce the right argument if 1875 we know the left is integer. */ 1876 UV auv = 0; 1877 bool auvok = FALSE; 1878 bool a_valid = 0; 1879 1880 if (!useleft) { 1881 auv = 0; 1882 a_valid = auvok = 1; 1883 /* left operand is undef, treat as zero. */ 1884 } else { 1885 /* Left operand is defined, so is it IV? */ 1886 if (SvIV_please_nomg(svl)) { 1887 if ((auvok = SvUOK(svl))) 1888 auv = SvUVX(svl); 1889 else { 1890 const IV aiv = SvIVX(svl); 1891 if (aiv >= 0) { 1892 auv = aiv; 1893 auvok = 1; /* Now acting as a sign flag. */ 1894 } else { /* 2s complement assumption for IV_MIN */ 1895 auv = (aiv == IV_MIN) ? (UV)aiv : (UV)-aiv; 1896 } 1897 } 1898 a_valid = 1; 1899 } 1900 } 1901 if (a_valid) { 1902 bool result_good = 0; 1903 UV result; 1904 UV buv; 1905 bool buvok = SvUOK(svr); 1906 1907 if (buvok) 1908 buv = SvUVX(svr); 1909 else { 1910 const IV biv = SvIVX(svr); 1911 if (biv >= 0) { 1912 buv = biv; 1913 buvok = 1; 1914 } else 1915 buv = (biv == IV_MIN) ? (UV)biv : (UV)-biv; 1916 } 1917 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve, 1918 else "IV" now, independent of how it came in. 1919 if a, b represents positive, A, B negative, a maps to -A etc 1920 a - b => (a - b) 1921 A - b => -(a + b) 1922 a - B => (a + b) 1923 A - B => -(a - b) 1924 all UV maths. negate result if A negative. 1925 subtract if signs same, add if signs differ. */ 1926 1927 if (auvok ^ buvok) { 1928 /* Signs differ. */ 1929 result = auv + buv; 1930 if (result >= auv) 1931 result_good = 1; 1932 } else { 1933 /* Signs same */ 1934 if (auv >= buv) { 1935 result = auv - buv; 1936 /* Must get smaller */ 1937 if (result <= auv) 1938 result_good = 1; 1939 } else { 1940 result = buv - auv; 1941 if (result <= buv) { 1942 /* result really should be -(auv-buv). as its negation 1943 of true value, need to swap our result flag */ 1944 auvok = !auvok; 1945 result_good = 1; 1946 } 1947 } 1948 } 1949 if (result_good) { 1950 SP--; 1951 if (auvok) 1952 SETu( result ); 1953 else { 1954 /* Negate result */ 1955 if (result <= (UV)IV_MIN) 1956 SETi(result == (UV)IV_MIN 1957 ? IV_MIN : -(IV)result); 1958 else { 1959 /* result valid, but out of range for IV. */ 1960 SETn( -(NV)result ); 1961 } 1962 } 1963 RETURN; 1964 } /* Overflow, drop through to NVs. */ 1965 } 1966 } 1967 #else 1968 useleft = USE_LEFT(svl); 1969 #endif 1970 { 1971 NV value = SvNV_nomg(svr); 1972 (void)POPs; 1973 1974 if (!useleft) { 1975 /* left operand is undef, treat as zero - value */ 1976 SETn(-value); 1977 RETURN; 1978 } 1979 SETn( SvNV_nomg(svl) - value ); 1980 RETURN; 1981 } 1982 } 1983 1984 #define IV_BITS (IVSIZE * 8) 1985 1986 static UV S_uv_shift(UV uv, int shift, bool left) 1987 { 1988 if (shift < 0) { 1989 shift = -shift; 1990 left = !left; 1991 } 1992 if (shift >= IV_BITS) { 1993 return 0; 1994 } 1995 return left ? uv << shift : uv >> shift; 1996 } 1997 1998 static IV S_iv_shift(IV iv, int shift, bool left) 1999 { 2000 if (shift < 0) { 2001 shift = -shift; 2002 left = !left; 2003 } 2004 if (shift >= IV_BITS) { 2005 return iv < 0 && !left ? -1 : 0; 2006 } 2007 return left ? iv << shift : iv >> shift; 2008 } 2009 2010 #define UV_LEFT_SHIFT(uv, shift) S_uv_shift(uv, shift, TRUE) 2011 #define UV_RIGHT_SHIFT(uv, shift) S_uv_shift(uv, shift, FALSE) 2012 #define IV_LEFT_SHIFT(iv, shift) S_iv_shift(iv, shift, TRUE) 2013 #define IV_RIGHT_SHIFT(iv, shift) S_iv_shift(iv, shift, FALSE) 2014 2015 PP(pp_left_shift) 2016 { 2017 dSP; dATARGET; SV *svl, *svr; 2018 tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric); 2019 svr = POPs; 2020 svl = TOPs; 2021 { 2022 const IV shift = SvIV_nomg(svr); 2023 if (PL_op->op_private & HINT_INTEGER) { 2024 SETi(IV_LEFT_SHIFT(SvIV_nomg(svl), shift)); 2025 } 2026 else { 2027 SETu(UV_LEFT_SHIFT(SvUV_nomg(svl), shift)); 2028 } 2029 RETURN; 2030 } 2031 } 2032 2033 PP(pp_right_shift) 2034 { 2035 dSP; dATARGET; SV *svl, *svr; 2036 tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric); 2037 svr = POPs; 2038 svl = TOPs; 2039 { 2040 const IV shift = SvIV_nomg(svr); 2041 if (PL_op->op_private & HINT_INTEGER) { 2042 SETi(IV_RIGHT_SHIFT(SvIV_nomg(svl), shift)); 2043 } 2044 else { 2045 SETu(UV_RIGHT_SHIFT(SvUV_nomg(svl), shift)); 2046 } 2047 RETURN; 2048 } 2049 } 2050 2051 PP(pp_lt) 2052 { 2053 dSP; 2054 SV *left, *right; 2055 2056 tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric); 2057 right = POPs; 2058 left = TOPs; 2059 SETs(boolSV( 2060 (SvIOK_notUV(left) && SvIOK_notUV(right)) 2061 ? (SvIVX(left) < SvIVX(right)) 2062 : (do_ncmp(left, right) == -1) 2063 )); 2064 RETURN; 2065 } 2066 2067 PP(pp_gt) 2068 { 2069 dSP; 2070 SV *left, *right; 2071 2072 tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric); 2073 right = POPs; 2074 left = TOPs; 2075 SETs(boolSV( 2076 (SvIOK_notUV(left) && SvIOK_notUV(right)) 2077 ? (SvIVX(left) > SvIVX(right)) 2078 : (do_ncmp(left, right) == 1) 2079 )); 2080 RETURN; 2081 } 2082 2083 PP(pp_le) 2084 { 2085 dSP; 2086 SV *left, *right; 2087 2088 tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric); 2089 right = POPs; 2090 left = TOPs; 2091 SETs(boolSV( 2092 (SvIOK_notUV(left) && SvIOK_notUV(right)) 2093 ? (SvIVX(left) <= SvIVX(right)) 2094 : (do_ncmp(left, right) <= 0) 2095 )); 2096 RETURN; 2097 } 2098 2099 PP(pp_ge) 2100 { 2101 dSP; 2102 SV *left, *right; 2103 2104 tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric); 2105 right = POPs; 2106 left = TOPs; 2107 SETs(boolSV( 2108 (SvIOK_notUV(left) && SvIOK_notUV(right)) 2109 ? (SvIVX(left) >= SvIVX(right)) 2110 : ( (do_ncmp(left, right) & 2) == 0) 2111 )); 2112 RETURN; 2113 } 2114 2115 PP(pp_ne) 2116 { 2117 dSP; 2118 SV *left, *right; 2119 2120 tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric); 2121 right = POPs; 2122 left = TOPs; 2123 SETs(boolSV( 2124 (SvIOK_notUV(left) && SvIOK_notUV(right)) 2125 ? (SvIVX(left) != SvIVX(right)) 2126 : (do_ncmp(left, right) != 0) 2127 )); 2128 RETURN; 2129 } 2130 2131 /* compare left and right SVs. Returns: 2132 * -1: < 2133 * 0: == 2134 * 1: > 2135 * 2: left or right was a NaN 2136 */ 2137 I32 2138 Perl_do_ncmp(pTHX_ SV* const left, SV * const right) 2139 { 2140 PERL_ARGS_ASSERT_DO_NCMP; 2141 #ifdef PERL_PRESERVE_IVUV 2142 /* Fortunately it seems NaN isn't IOK */ 2143 if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) { 2144 if (!SvUOK(left)) { 2145 const IV leftiv = SvIVX(left); 2146 if (!SvUOK(right)) { 2147 /* ## IV <=> IV ## */ 2148 const IV rightiv = SvIVX(right); 2149 return (leftiv > rightiv) - (leftiv < rightiv); 2150 } 2151 /* ## IV <=> UV ## */ 2152 if (leftiv < 0) 2153 /* As (b) is a UV, it's >=0, so it must be < */ 2154 return -1; 2155 { 2156 const UV rightuv = SvUVX(right); 2157 return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv); 2158 } 2159 } 2160 2161 if (SvUOK(right)) { 2162 /* ## UV <=> UV ## */ 2163 const UV leftuv = SvUVX(left); 2164 const UV rightuv = SvUVX(right); 2165 return (leftuv > rightuv) - (leftuv < rightuv); 2166 } 2167 /* ## UV <=> IV ## */ 2168 { 2169 const IV rightiv = SvIVX(right); 2170 if (rightiv < 0) 2171 /* As (a) is a UV, it's >=0, so it cannot be < */ 2172 return 1; 2173 { 2174 const UV leftuv = SvUVX(left); 2175 return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv); 2176 } 2177 } 2178 NOT_REACHED; /* NOTREACHED */ 2179 } 2180 #endif 2181 { 2182 NV const rnv = SvNV_nomg(right); 2183 NV const lnv = SvNV_nomg(left); 2184 2185 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) 2186 if (Perl_isnan(lnv) || Perl_isnan(rnv)) { 2187 return 2; 2188 } 2189 return (lnv > rnv) - (lnv < rnv); 2190 #else 2191 if (lnv < rnv) 2192 return -1; 2193 if (lnv > rnv) 2194 return 1; 2195 if (lnv == rnv) 2196 return 0; 2197 return 2; 2198 #endif 2199 } 2200 } 2201 2202 2203 PP(pp_ncmp) 2204 { 2205 dSP; 2206 SV *left, *right; 2207 I32 value; 2208 tryAMAGICbin_MG(ncmp_amg, AMGf_numeric); 2209 right = POPs; 2210 left = TOPs; 2211 value = do_ncmp(left, right); 2212 if (value == 2) { 2213 SETs(&PL_sv_undef); 2214 } 2215 else { 2216 dTARGET; 2217 SETi(value); 2218 } 2219 RETURN; 2220 } 2221 2222 2223 /* also used for: pp_sge() pp_sgt() pp_slt() */ 2224 2225 PP(pp_sle) 2226 { 2227 dSP; 2228 2229 int amg_type = sle_amg; 2230 int multiplier = 1; 2231 int rhs = 1; 2232 2233 switch (PL_op->op_type) { 2234 case OP_SLT: 2235 amg_type = slt_amg; 2236 /* cmp < 0 */ 2237 rhs = 0; 2238 break; 2239 case OP_SGT: 2240 amg_type = sgt_amg; 2241 /* cmp > 0 */ 2242 multiplier = -1; 2243 rhs = 0; 2244 break; 2245 case OP_SGE: 2246 amg_type = sge_amg; 2247 /* cmp >= 0 */ 2248 multiplier = -1; 2249 break; 2250 } 2251 2252 tryAMAGICbin_MG(amg_type, AMGf_set); 2253 { 2254 dPOPTOPssrl; 2255 const int cmp = 2256 #ifdef USE_LOCALE_COLLATE 2257 (IN_LC_RUNTIME(LC_COLLATE)) 2258 ? sv_cmp_locale_flags(left, right, 0) 2259 : 2260 #endif 2261 sv_cmp_flags(left, right, 0); 2262 SETs(boolSV(cmp * multiplier < rhs)); 2263 RETURN; 2264 } 2265 } 2266 2267 PP(pp_seq) 2268 { 2269 dSP; 2270 tryAMAGICbin_MG(seq_amg, AMGf_set); 2271 { 2272 dPOPTOPssrl; 2273 SETs(boolSV(sv_eq_flags(left, right, 0))); 2274 RETURN; 2275 } 2276 } 2277 2278 PP(pp_sne) 2279 { 2280 dSP; 2281 tryAMAGICbin_MG(sne_amg, AMGf_set); 2282 { 2283 dPOPTOPssrl; 2284 SETs(boolSV(!sv_eq_flags(left, right, 0))); 2285 RETURN; 2286 } 2287 } 2288 2289 PP(pp_scmp) 2290 { 2291 dSP; dTARGET; 2292 tryAMAGICbin_MG(scmp_amg, 0); 2293 { 2294 dPOPTOPssrl; 2295 const int cmp = 2296 #ifdef USE_LOCALE_COLLATE 2297 (IN_LC_RUNTIME(LC_COLLATE)) 2298 ? sv_cmp_locale_flags(left, right, 0) 2299 : 2300 #endif 2301 sv_cmp_flags(left, right, 0); 2302 SETi( cmp ); 2303 RETURN; 2304 } 2305 } 2306 2307 PP(pp_bit_and) 2308 { 2309 dSP; dATARGET; 2310 tryAMAGICbin_MG(band_amg, AMGf_assign); 2311 { 2312 dPOPTOPssrl; 2313 if (SvNIOKp(left) || SvNIOKp(right)) { 2314 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left); 2315 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right); 2316 if (PL_op->op_private & HINT_INTEGER) { 2317 const IV i = SvIV_nomg(left) & SvIV_nomg(right); 2318 SETi(i); 2319 } 2320 else { 2321 const UV u = SvUV_nomg(left) & SvUV_nomg(right); 2322 SETu(u); 2323 } 2324 if (left_ro_nonnum && left != TARG) SvNIOK_off(left); 2325 if (right_ro_nonnum) SvNIOK_off(right); 2326 } 2327 else { 2328 do_vop(PL_op->op_type, TARG, left, right); 2329 SETTARG; 2330 } 2331 RETURN; 2332 } 2333 } 2334 2335 PP(pp_nbit_and) 2336 { 2337 dSP; 2338 tryAMAGICbin_MG(band_amg, AMGf_assign|AMGf_numarg); 2339 { 2340 dATARGET; dPOPTOPssrl; 2341 if (PL_op->op_private & HINT_INTEGER) { 2342 const IV i = SvIV_nomg(left) & SvIV_nomg(right); 2343 SETi(i); 2344 } 2345 else { 2346 const UV u = SvUV_nomg(left) & SvUV_nomg(right); 2347 SETu(u); 2348 } 2349 } 2350 RETURN; 2351 } 2352 2353 PP(pp_sbit_and) 2354 { 2355 dSP; 2356 tryAMAGICbin_MG(sband_amg, AMGf_assign); 2357 { 2358 dATARGET; dPOPTOPssrl; 2359 do_vop(OP_BIT_AND, TARG, left, right); 2360 RETSETTARG; 2361 } 2362 } 2363 2364 /* also used for: pp_bit_xor() */ 2365 2366 PP(pp_bit_or) 2367 { 2368 dSP; dATARGET; 2369 const int op_type = PL_op->op_type; 2370 2371 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign); 2372 { 2373 dPOPTOPssrl; 2374 if (SvNIOKp(left) || SvNIOKp(right)) { 2375 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left); 2376 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right); 2377 if (PL_op->op_private & HINT_INTEGER) { 2378 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0); 2379 const IV r = SvIV_nomg(right); 2380 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r); 2381 SETi(result); 2382 } 2383 else { 2384 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0); 2385 const UV r = SvUV_nomg(right); 2386 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r); 2387 SETu(result); 2388 } 2389 if (left_ro_nonnum && left != TARG) SvNIOK_off(left); 2390 if (right_ro_nonnum) SvNIOK_off(right); 2391 } 2392 else { 2393 do_vop(op_type, TARG, left, right); 2394 SETTARG; 2395 } 2396 RETURN; 2397 } 2398 } 2399 2400 /* also used for: pp_nbit_xor() */ 2401 2402 PP(pp_nbit_or) 2403 { 2404 dSP; 2405 const int op_type = PL_op->op_type; 2406 2407 tryAMAGICbin_MG((op_type == OP_NBIT_OR ? bor_amg : bxor_amg), 2408 AMGf_assign|AMGf_numarg); 2409 { 2410 dATARGET; dPOPTOPssrl; 2411 if (PL_op->op_private & HINT_INTEGER) { 2412 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0); 2413 const IV r = SvIV_nomg(right); 2414 const IV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r); 2415 SETi(result); 2416 } 2417 else { 2418 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0); 2419 const UV r = SvUV_nomg(right); 2420 const UV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r); 2421 SETu(result); 2422 } 2423 } 2424 RETURN; 2425 } 2426 2427 /* also used for: pp_sbit_xor() */ 2428 2429 PP(pp_sbit_or) 2430 { 2431 dSP; 2432 const int op_type = PL_op->op_type; 2433 2434 tryAMAGICbin_MG((op_type == OP_SBIT_OR ? sbor_amg : sbxor_amg), 2435 AMGf_assign); 2436 { 2437 dATARGET; dPOPTOPssrl; 2438 do_vop(op_type == OP_SBIT_OR ? OP_BIT_OR : OP_BIT_XOR, TARG, left, 2439 right); 2440 RETSETTARG; 2441 } 2442 } 2443 2444 PERL_STATIC_INLINE bool 2445 S_negate_string(pTHX) 2446 { 2447 dTARGET; dSP; 2448 STRLEN len; 2449 const char *s; 2450 SV * const sv = TOPs; 2451 if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv))) 2452 return FALSE; 2453 s = SvPV_nomg_const(sv, len); 2454 if (isIDFIRST(*s)) { 2455 sv_setpvs(TARG, "-"); 2456 sv_catsv(TARG, sv); 2457 } 2458 else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) { 2459 sv_setsv_nomg(TARG, sv); 2460 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-'; 2461 } 2462 else return FALSE; 2463 SETTARG; 2464 return TRUE; 2465 } 2466 2467 PP(pp_negate) 2468 { 2469 dSP; dTARGET; 2470 tryAMAGICun_MG(neg_amg, AMGf_numeric); 2471 if (S_negate_string(aTHX)) return NORMAL; 2472 { 2473 SV * const sv = TOPs; 2474 2475 if (SvIOK(sv)) { 2476 /* It's publicly an integer */ 2477 oops_its_an_int: 2478 if (SvIsUV(sv)) { 2479 if (SvIVX(sv) == IV_MIN) { 2480 /* 2s complement assumption. */ 2481 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == 2482 IV_MIN */ 2483 return NORMAL; 2484 } 2485 else if (SvUVX(sv) <= IV_MAX) { 2486 SETi(-SvIVX(sv)); 2487 return NORMAL; 2488 } 2489 } 2490 else if (SvIVX(sv) != IV_MIN) { 2491 SETi(-SvIVX(sv)); 2492 return NORMAL; 2493 } 2494 #ifdef PERL_PRESERVE_IVUV 2495 else { 2496 SETu((UV)IV_MIN); 2497 return NORMAL; 2498 } 2499 #endif 2500 } 2501 if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv))) 2502 SETn(-SvNV_nomg(sv)); 2503 else if (SvPOKp(sv) && SvIV_please_nomg(sv)) 2504 goto oops_its_an_int; 2505 else 2506 SETn(-SvNV_nomg(sv)); 2507 } 2508 return NORMAL; 2509 } 2510 2511 PP(pp_not) 2512 { 2513 dSP; 2514 SV *sv; 2515 2516 tryAMAGICun_MG(not_amg, AMGf_set); 2517 sv = *PL_stack_sp; 2518 *PL_stack_sp = boolSV(!SvTRUE_nomg_NN(sv)); 2519 return NORMAL; 2520 } 2521 2522 static void 2523 S_scomplement(pTHX_ SV *targ, SV *sv) 2524 { 2525 U8 *tmps; 2526 I32 anum; 2527 STRLEN len; 2528 2529 sv_copypv_nomg(TARG, sv); 2530 tmps = (U8*)SvPV_nomg(TARG, len); 2531 2532 if (SvUTF8(TARG)) { 2533 if (len && ! utf8_to_bytes(tmps, &len)) { 2534 Perl_croak(aTHX_ FATAL_ABOVE_FF_MSG, PL_op_desc[PL_op->op_type]); 2535 } 2536 SvCUR(TARG) = len; 2537 SvUTF8_off(TARG); 2538 } 2539 2540 anum = len; 2541 2542 #ifdef LIBERAL 2543 { 2544 long *tmpl; 2545 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++) 2546 *tmps = ~*tmps; 2547 tmpl = (long*)tmps; 2548 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++) 2549 *tmpl = ~*tmpl; 2550 tmps = (U8*)tmpl; 2551 } 2552 #endif 2553 for ( ; anum > 0; anum--, tmps++) 2554 *tmps = ~*tmps; 2555 } 2556 2557 PP(pp_complement) 2558 { 2559 dSP; dTARGET; 2560 tryAMAGICun_MG(compl_amg, AMGf_numeric); 2561 { 2562 dTOPss; 2563 if (SvNIOKp(sv)) { 2564 if (PL_op->op_private & HINT_INTEGER) { 2565 const IV i = ~SvIV_nomg(sv); 2566 SETi(i); 2567 } 2568 else { 2569 const UV u = ~SvUV_nomg(sv); 2570 SETu(u); 2571 } 2572 } 2573 else { 2574 S_scomplement(aTHX_ TARG, sv); 2575 SETTARG; 2576 } 2577 return NORMAL; 2578 } 2579 } 2580 2581 PP(pp_ncomplement) 2582 { 2583 dSP; 2584 tryAMAGICun_MG(compl_amg, AMGf_numeric|AMGf_numarg); 2585 { 2586 dTARGET; dTOPss; 2587 if (PL_op->op_private & HINT_INTEGER) { 2588 const IV i = ~SvIV_nomg(sv); 2589 SETi(i); 2590 } 2591 else { 2592 const UV u = ~SvUV_nomg(sv); 2593 SETu(u); 2594 } 2595 } 2596 return NORMAL; 2597 } 2598 2599 PP(pp_scomplement) 2600 { 2601 dSP; 2602 tryAMAGICun_MG(scompl_amg, AMGf_numeric); 2603 { 2604 dTARGET; dTOPss; 2605 S_scomplement(aTHX_ TARG, sv); 2606 SETTARG; 2607 return NORMAL; 2608 } 2609 } 2610 2611 /* integer versions of some of the above */ 2612 2613 PP(pp_i_multiply) 2614 { 2615 dSP; dATARGET; 2616 tryAMAGICbin_MG(mult_amg, AMGf_assign); 2617 { 2618 dPOPTOPiirl_nomg; 2619 SETi( left * right ); 2620 RETURN; 2621 } 2622 } 2623 2624 PP(pp_i_divide) 2625 { 2626 IV num; 2627 dSP; dATARGET; 2628 tryAMAGICbin_MG(div_amg, AMGf_assign); 2629 { 2630 dPOPTOPssrl; 2631 IV value = SvIV_nomg(right); 2632 if (value == 0) 2633 DIE(aTHX_ "Illegal division by zero"); 2634 num = SvIV_nomg(left); 2635 2636 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */ 2637 if (value == -1) 2638 value = - num; 2639 else 2640 value = num / value; 2641 SETi(value); 2642 RETURN; 2643 } 2644 } 2645 2646 PP(pp_i_modulo) 2647 { 2648 /* This is the vanilla old i_modulo. */ 2649 dSP; dATARGET; 2650 tryAMAGICbin_MG(modulo_amg, AMGf_assign); 2651 { 2652 dPOPTOPiirl_nomg; 2653 if (!right) 2654 DIE(aTHX_ "Illegal modulus zero"); 2655 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */ 2656 if (right == -1) 2657 SETi( 0 ); 2658 else 2659 SETi( left % right ); 2660 RETURN; 2661 } 2662 } 2663 2664 #if defined(__GLIBC__) && IVSIZE == 8 \ 2665 && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8)) 2666 2667 PP(pp_i_modulo_glibc_bugfix) 2668 { 2669 /* This is the i_modulo with the workaround for the _moddi3 bug 2670 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround). 2671 * See below for pp_i_modulo. */ 2672 dSP; dATARGET; 2673 tryAMAGICbin_MG(modulo_amg, AMGf_assign); 2674 { 2675 dPOPTOPiirl_nomg; 2676 if (!right) 2677 DIE(aTHX_ "Illegal modulus zero"); 2678 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */ 2679 if (right == -1) 2680 SETi( 0 ); 2681 else 2682 SETi( left % PERL_ABS(right) ); 2683 RETURN; 2684 } 2685 } 2686 #endif 2687 2688 PP(pp_i_add) 2689 { 2690 dSP; dATARGET; 2691 tryAMAGICbin_MG(add_amg, AMGf_assign); 2692 { 2693 dPOPTOPiirl_ul_nomg; 2694 SETi( left + right ); 2695 RETURN; 2696 } 2697 } 2698 2699 PP(pp_i_subtract) 2700 { 2701 dSP; dATARGET; 2702 tryAMAGICbin_MG(subtr_amg, AMGf_assign); 2703 { 2704 dPOPTOPiirl_ul_nomg; 2705 SETi( left - right ); 2706 RETURN; 2707 } 2708 } 2709 2710 PP(pp_i_lt) 2711 { 2712 dSP; 2713 tryAMAGICbin_MG(lt_amg, AMGf_set); 2714 { 2715 dPOPTOPiirl_nomg; 2716 SETs(boolSV(left < right)); 2717 RETURN; 2718 } 2719 } 2720 2721 PP(pp_i_gt) 2722 { 2723 dSP; 2724 tryAMAGICbin_MG(gt_amg, AMGf_set); 2725 { 2726 dPOPTOPiirl_nomg; 2727 SETs(boolSV(left > right)); 2728 RETURN; 2729 } 2730 } 2731 2732 PP(pp_i_le) 2733 { 2734 dSP; 2735 tryAMAGICbin_MG(le_amg, AMGf_set); 2736 { 2737 dPOPTOPiirl_nomg; 2738 SETs(boolSV(left <= right)); 2739 RETURN; 2740 } 2741 } 2742 2743 PP(pp_i_ge) 2744 { 2745 dSP; 2746 tryAMAGICbin_MG(ge_amg, AMGf_set); 2747 { 2748 dPOPTOPiirl_nomg; 2749 SETs(boolSV(left >= right)); 2750 RETURN; 2751 } 2752 } 2753 2754 PP(pp_i_eq) 2755 { 2756 dSP; 2757 tryAMAGICbin_MG(eq_amg, AMGf_set); 2758 { 2759 dPOPTOPiirl_nomg; 2760 SETs(boolSV(left == right)); 2761 RETURN; 2762 } 2763 } 2764 2765 PP(pp_i_ne) 2766 { 2767 dSP; 2768 tryAMAGICbin_MG(ne_amg, AMGf_set); 2769 { 2770 dPOPTOPiirl_nomg; 2771 SETs(boolSV(left != right)); 2772 RETURN; 2773 } 2774 } 2775 2776 PP(pp_i_ncmp) 2777 { 2778 dSP; dTARGET; 2779 tryAMAGICbin_MG(ncmp_amg, 0); 2780 { 2781 dPOPTOPiirl_nomg; 2782 I32 value; 2783 2784 if (left > right) 2785 value = 1; 2786 else if (left < right) 2787 value = -1; 2788 else 2789 value = 0; 2790 SETi(value); 2791 RETURN; 2792 } 2793 } 2794 2795 PP(pp_i_negate) 2796 { 2797 dSP; dTARGET; 2798 tryAMAGICun_MG(neg_amg, 0); 2799 if (S_negate_string(aTHX)) return NORMAL; 2800 { 2801 SV * const sv = TOPs; 2802 IV const i = SvIV_nomg(sv); 2803 SETi(-i); 2804 return NORMAL; 2805 } 2806 } 2807 2808 /* High falutin' math. */ 2809 2810 PP(pp_atan2) 2811 { 2812 dSP; dTARGET; 2813 tryAMAGICbin_MG(atan2_amg, 0); 2814 { 2815 dPOPTOPnnrl_nomg; 2816 SETn(Perl_atan2(left, right)); 2817 RETURN; 2818 } 2819 } 2820 2821 2822 /* also used for: pp_cos() pp_exp() pp_log() pp_sqrt() */ 2823 2824 PP(pp_sin) 2825 { 2826 dSP; dTARGET; 2827 int amg_type = fallback_amg; 2828 const char *neg_report = NULL; 2829 const int op_type = PL_op->op_type; 2830 2831 switch (op_type) { 2832 case OP_SIN: amg_type = sin_amg; break; 2833 case OP_COS: amg_type = cos_amg; break; 2834 case OP_EXP: amg_type = exp_amg; break; 2835 case OP_LOG: amg_type = log_amg; neg_report = "log"; break; 2836 case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break; 2837 } 2838 2839 assert(amg_type != fallback_amg); 2840 2841 tryAMAGICun_MG(amg_type, 0); 2842 { 2843 SV * const arg = TOPs; 2844 const NV value = SvNV_nomg(arg); 2845 #ifdef NV_NAN 2846 NV result = NV_NAN; 2847 #else 2848 NV result = 0.0; 2849 #endif 2850 if (neg_report) { /* log or sqrt */ 2851 if ( 2852 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) 2853 ! Perl_isnan(value) && 2854 #endif 2855 (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0))) { 2856 SET_NUMERIC_STANDARD(); 2857 /* diag_listed_as: Can't take log of %g */ 2858 DIE(aTHX_ "Can't take %s of %" NVgf, neg_report, value); 2859 } 2860 } 2861 switch (op_type) { 2862 default: 2863 case OP_SIN: result = Perl_sin(value); break; 2864 case OP_COS: result = Perl_cos(value); break; 2865 case OP_EXP: result = Perl_exp(value); break; 2866 case OP_LOG: result = Perl_log(value); break; 2867 case OP_SQRT: result = Perl_sqrt(value); break; 2868 } 2869 SETn(result); 2870 return NORMAL; 2871 } 2872 } 2873 2874 /* Support Configure command-line overrides for rand() functions. 2875 After 5.005, perhaps we should replace this by Configure support 2876 for drand48(), random(), or rand(). For 5.005, though, maintain 2877 compatibility by calling rand() but allow the user to override it. 2878 See INSTALL for details. --Andy Dougherty 15 July 1998 2879 */ 2880 /* Now it's after 5.005, and Configure supports drand48() and random(), 2881 in addition to rand(). So the overrides should not be needed any more. 2882 --Jarkko Hietaniemi 27 September 1998 2883 */ 2884 2885 PP(pp_rand) 2886 { 2887 if (!PL_srand_called) { 2888 (void)seedDrand01((Rand_seed_t)seed()); 2889 PL_srand_called = TRUE; 2890 } 2891 { 2892 dSP; 2893 NV value; 2894 2895 if (MAXARG < 1) 2896 { 2897 EXTEND(SP, 1); 2898 value = 1.0; 2899 } 2900 else { 2901 SV * const sv = POPs; 2902 if(!sv) 2903 value = 1.0; 2904 else 2905 value = SvNV(sv); 2906 } 2907 /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */ 2908 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) 2909 if (! Perl_isnan(value) && value == 0.0) 2910 #else 2911 if (value == 0.0) 2912 #endif 2913 value = 1.0; 2914 { 2915 dTARGET; 2916 PUSHs(TARG); 2917 PUTBACK; 2918 value *= Drand01(); 2919 sv_setnv_mg(TARG, value); 2920 } 2921 } 2922 return NORMAL; 2923 } 2924 2925 PP(pp_srand) 2926 { 2927 dSP; dTARGET; 2928 UV anum; 2929 2930 if (MAXARG >= 1 && (TOPs || POPs)) { 2931 SV *top; 2932 char *pv; 2933 STRLEN len; 2934 int flags; 2935 2936 top = POPs; 2937 pv = SvPV(top, len); 2938 flags = grok_number(pv, len, &anum); 2939 2940 if (!(flags & IS_NUMBER_IN_UV)) { 2941 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW), 2942 "Integer overflow in srand"); 2943 anum = UV_MAX; 2944 } 2945 (void)srand48_deterministic((Rand_seed_t)anum); 2946 } 2947 else { 2948 anum = seed(); 2949 (void)seedDrand01((Rand_seed_t)anum); 2950 } 2951 2952 PL_srand_called = TRUE; 2953 if (anum) 2954 XPUSHu(anum); 2955 else { 2956 /* Historically srand always returned true. We can avoid breaking 2957 that like this: */ 2958 sv_setpvs(TARG, "0 but true"); 2959 XPUSHTARG; 2960 } 2961 RETURN; 2962 } 2963 2964 PP(pp_int) 2965 { 2966 dSP; dTARGET; 2967 tryAMAGICun_MG(int_amg, AMGf_numeric); 2968 { 2969 SV * const sv = TOPs; 2970 const IV iv = SvIV_nomg(sv); 2971 /* XXX it's arguable that compiler casting to IV might be subtly 2972 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which 2973 else preferring IV has introduced a subtle behaviour change bug. OTOH 2974 relying on floating point to be accurate is a bug. */ 2975 2976 if (!SvOK(sv)) { 2977 SETu(0); 2978 } 2979 else if (SvIOK(sv)) { 2980 if (SvIsUV(sv)) 2981 SETu(SvUV_nomg(sv)); 2982 else 2983 SETi(iv); 2984 } 2985 else { 2986 const NV value = SvNV_nomg(sv); 2987 if (UNLIKELY(Perl_isinfnan(value))) 2988 SETn(value); 2989 else if (value >= 0.0) { 2990 if (value < (NV)UV_MAX + 0.5) { 2991 SETu(U_V(value)); 2992 } else { 2993 SETn(Perl_floor(value)); 2994 } 2995 } 2996 else { 2997 if (value > (NV)IV_MIN - 0.5) { 2998 SETi(I_V(value)); 2999 } else { 3000 SETn(Perl_ceil(value)); 3001 } 3002 } 3003 } 3004 } 3005 return NORMAL; 3006 } 3007 3008 PP(pp_abs) 3009 { 3010 dSP; dTARGET; 3011 tryAMAGICun_MG(abs_amg, AMGf_numeric); 3012 { 3013 SV * const sv = TOPs; 3014 /* This will cache the NV value if string isn't actually integer */ 3015 const IV iv = SvIV_nomg(sv); 3016 3017 if (!SvOK(sv)) { 3018 SETu(0); 3019 } 3020 else if (SvIOK(sv)) { 3021 /* IVX is precise */ 3022 if (SvIsUV(sv)) { 3023 SETu(SvUV_nomg(sv)); /* force it to be numeric only */ 3024 } else { 3025 if (iv >= 0) { 3026 SETi(iv); 3027 } else { 3028 if (iv != IV_MIN) { 3029 SETi(-iv); 3030 } else { 3031 /* 2s complement assumption. Also, not really needed as 3032 IV_MIN and -IV_MIN should both be %100...00 and NV-able */ 3033 SETu((UV)IV_MIN); 3034 } 3035 } 3036 } 3037 } else{ 3038 const NV value = SvNV_nomg(sv); 3039 if (value < 0.0) 3040 SETn(-value); 3041 else 3042 SETn(value); 3043 } 3044 } 3045 return NORMAL; 3046 } 3047 3048 3049 /* also used for: pp_hex() */ 3050 3051 PP(pp_oct) 3052 { 3053 dSP; dTARGET; 3054 const char *tmps; 3055 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES; 3056 STRLEN len; 3057 NV result_nv; 3058 UV result_uv; 3059 SV* const sv = TOPs; 3060 3061 tmps = (SvPV_const(sv, len)); 3062 if (DO_UTF8(sv)) { 3063 /* If Unicode, try to downgrade 3064 * If not possible, croak. */ 3065 SV* const tsv = sv_2mortal(newSVsv(sv)); 3066 3067 SvUTF8_on(tsv); 3068 sv_utf8_downgrade(tsv, FALSE); 3069 tmps = SvPV_const(tsv, len); 3070 } 3071 if (PL_op->op_type == OP_HEX) 3072 goto hex; 3073 3074 while (*tmps && len && isSPACE(*tmps)) 3075 tmps++, len--; 3076 if (*tmps == '0') 3077 tmps++, len--; 3078 if (isALPHA_FOLD_EQ(*tmps, 'x')) { 3079 hex: 3080 result_uv = grok_hex (tmps, &len, &flags, &result_nv); 3081 } 3082 else if (isALPHA_FOLD_EQ(*tmps, 'b')) 3083 result_uv = grok_bin (tmps, &len, &flags, &result_nv); 3084 else 3085 result_uv = grok_oct (tmps, &len, &flags, &result_nv); 3086 3087 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) { 3088 SETn(result_nv); 3089 } 3090 else { 3091 SETu(result_uv); 3092 } 3093 return NORMAL; 3094 } 3095 3096 /* String stuff. */ 3097 3098 3099 PP(pp_length) 3100 { 3101 dSP; dTARGET; 3102 SV * const sv = TOPs; 3103 3104 U32 in_bytes = IN_BYTES; 3105 /* Simplest case shortcut: 3106 * set svflags to just the SVf_POK|SVs_GMG|SVf_UTF8 from the SV, 3107 * with the SVf_UTF8 flag inverted if under 'use bytes' (HINT_BYTES 3108 * set) 3109 */ 3110 U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8); 3111 3112 STATIC_ASSERT_STMT(SVf_UTF8 == (HINT_BYTES << 26)); 3113 SETs(TARG); 3114 3115 if (LIKELY(svflags == SVf_POK)) 3116 goto simple_pv; 3117 3118 if (svflags & SVs_GMG) 3119 mg_get(sv); 3120 3121 if (SvOK(sv)) { 3122 STRLEN len; 3123 if (!IN_BYTES) { /* reread to avoid using an C auto/register */ 3124 if ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == SVf_POK) 3125 goto simple_pv; 3126 if ( SvPOK(sv) && (PL_op->op_private & OPpTRUEBOOL)) { 3127 /* no need to convert from bytes to chars */ 3128 len = SvCUR(sv); 3129 goto return_bool; 3130 } 3131 len = sv_len_utf8_nomg(sv); 3132 } 3133 else { 3134 /* unrolled SvPV_nomg_const(sv,len) */ 3135 if (SvPOK_nog(sv)) { 3136 simple_pv: 3137 len = SvCUR(sv); 3138 if (PL_op->op_private & OPpTRUEBOOL) { 3139 return_bool: 3140 SETs(len ? &PL_sv_yes : &PL_sv_zero); 3141 return NORMAL; 3142 } 3143 } 3144 else { 3145 (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN); 3146 } 3147 } 3148 TARGi((IV)(len), 1); 3149 } 3150 else { 3151 if (!SvPADTMP(TARG)) { 3152 /* OPpTARGET_MY: targ is var in '$lex = length()' */ 3153 sv_set_undef(TARG); 3154 SvSETMAGIC(TARG); 3155 } 3156 else 3157 /* TARG is on stack at this point and is overwriten by SETs. 3158 * This branch is the odd one out, so put TARG by default on 3159 * stack earlier to let local SP go out of liveness sooner */ 3160 SETs(&PL_sv_undef); 3161 } 3162 return NORMAL; /* no putback, SP didn't move in this opcode */ 3163 } 3164 3165 3166 /* Returns false if substring is completely outside original string. 3167 No length is indicated by len_iv = 0 and len_is_uv = 0. len_is_uv must 3168 always be true for an explicit 0. 3169 */ 3170 bool 3171 Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv, 3172 bool pos1_is_uv, IV len_iv, 3173 bool len_is_uv, STRLEN *posp, 3174 STRLEN *lenp) 3175 { 3176 IV pos2_iv; 3177 int pos2_is_uv; 3178 3179 PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS; 3180 3181 if (!pos1_is_uv && pos1_iv < 0 && curlen) { 3182 pos1_is_uv = curlen-1 > ~(UV)pos1_iv; 3183 pos1_iv += curlen; 3184 } 3185 if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen) 3186 return FALSE; 3187 3188 if (len_iv || len_is_uv) { 3189 if (!len_is_uv && len_iv < 0) { 3190 pos2_iv = curlen + len_iv; 3191 if (curlen) 3192 pos2_is_uv = curlen-1 > ~(UV)len_iv; 3193 else 3194 pos2_is_uv = 0; 3195 } else { /* len_iv >= 0 */ 3196 if (!pos1_is_uv && pos1_iv < 0) { 3197 pos2_iv = pos1_iv + len_iv; 3198 pos2_is_uv = (UV)len_iv > (UV)IV_MAX; 3199 } else { 3200 if ((UV)len_iv > curlen-(UV)pos1_iv) 3201 pos2_iv = curlen; 3202 else 3203 pos2_iv = pos1_iv+len_iv; 3204 pos2_is_uv = 1; 3205 } 3206 } 3207 } 3208 else { 3209 pos2_iv = curlen; 3210 pos2_is_uv = 1; 3211 } 3212 3213 if (!pos2_is_uv && pos2_iv < 0) { 3214 if (!pos1_is_uv && pos1_iv < 0) 3215 return FALSE; 3216 pos2_iv = 0; 3217 } 3218 else if (!pos1_is_uv && pos1_iv < 0) 3219 pos1_iv = 0; 3220 3221 if ((UV)pos2_iv < (UV)pos1_iv) 3222 pos2_iv = pos1_iv; 3223 if ((UV)pos2_iv > curlen) 3224 pos2_iv = curlen; 3225 3226 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */ 3227 *posp = (STRLEN)( (UV)pos1_iv ); 3228 *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv ); 3229 3230 return TRUE; 3231 } 3232 3233 PP(pp_substr) 3234 { 3235 dSP; dTARGET; 3236 SV *sv; 3237 STRLEN curlen; 3238 STRLEN utf8_curlen; 3239 SV * pos_sv; 3240 IV pos1_iv; 3241 int pos1_is_uv; 3242 SV * len_sv; 3243 IV len_iv = 0; 3244 int len_is_uv = 0; 3245 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET; 3246 const bool rvalue = (GIMME_V != G_VOID); 3247 const char *tmps; 3248 SV *repl_sv = NULL; 3249 const char *repl = NULL; 3250 STRLEN repl_len; 3251 int num_args = PL_op->op_private & 7; 3252 bool repl_need_utf8_upgrade = FALSE; 3253 3254 if (num_args > 2) { 3255 if (num_args > 3) { 3256 if(!(repl_sv = POPs)) num_args--; 3257 } 3258 if ((len_sv = POPs)) { 3259 len_iv = SvIV(len_sv); 3260 len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1; 3261 } 3262 else num_args--; 3263 } 3264 pos_sv = POPs; 3265 pos1_iv = SvIV(pos_sv); 3266 pos1_is_uv = SvIOK_UV(pos_sv); 3267 sv = POPs; 3268 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) { 3269 assert(!repl_sv); 3270 repl_sv = POPs; 3271 } 3272 if (lvalue && !repl_sv) { 3273 SV * ret; 3274 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */ 3275 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0); 3276 LvTYPE(ret) = 'x'; 3277 LvTARG(ret) = SvREFCNT_inc_simple(sv); 3278 LvTARGOFF(ret) = 3279 pos1_is_uv || pos1_iv >= 0 3280 ? (STRLEN)(UV)pos1_iv 3281 : (LvFLAGS(ret) |= LVf_NEG_OFF, (STRLEN)(UV)-pos1_iv); 3282 LvTARGLEN(ret) = 3283 len_is_uv || len_iv > 0 3284 ? (STRLEN)(UV)len_iv 3285 : (LvFLAGS(ret) |= LVf_NEG_LEN, (STRLEN)(UV)-len_iv); 3286 3287 PUSHs(ret); /* avoid SvSETMAGIC here */ 3288 RETURN; 3289 } 3290 if (repl_sv) { 3291 repl = SvPV_const(repl_sv, repl_len); 3292 SvGETMAGIC(sv); 3293 if (SvROK(sv)) 3294 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), 3295 "Attempt to use reference as lvalue in substr" 3296 ); 3297 tmps = SvPV_force_nomg(sv, curlen); 3298 if (DO_UTF8(repl_sv) && repl_len) { 3299 if (!DO_UTF8(sv)) { 3300 /* Upgrade the dest, and recalculate tmps in case the buffer 3301 * got reallocated; curlen may also have been changed */ 3302 sv_utf8_upgrade_nomg(sv); 3303 tmps = SvPV_nomg(sv, curlen); 3304 } 3305 } 3306 else if (DO_UTF8(sv)) 3307 repl_need_utf8_upgrade = TRUE; 3308 } 3309 else tmps = SvPV_const(sv, curlen); 3310 if (DO_UTF8(sv)) { 3311 utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen); 3312 if (utf8_curlen == curlen) 3313 utf8_curlen = 0; 3314 else 3315 curlen = utf8_curlen; 3316 } 3317 else 3318 utf8_curlen = 0; 3319 3320 { 3321 STRLEN pos, len, byte_len, byte_pos; 3322 3323 if (!translate_substr_offsets( 3324 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len 3325 )) goto bound_fail; 3326 3327 byte_len = len; 3328 byte_pos = utf8_curlen 3329 ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos; 3330 3331 tmps += byte_pos; 3332 3333 if (rvalue) { 3334 SvTAINTED_off(TARG); /* decontaminate */ 3335 SvUTF8_off(TARG); /* decontaminate */ 3336 sv_setpvn(TARG, tmps, byte_len); 3337 #ifdef USE_LOCALE_COLLATE 3338 sv_unmagic(TARG, PERL_MAGIC_collxfrm); 3339 #endif 3340 if (utf8_curlen) 3341 SvUTF8_on(TARG); 3342 } 3343 3344 if (repl) { 3345 SV* repl_sv_copy = NULL; 3346 3347 if (repl_need_utf8_upgrade) { 3348 repl_sv_copy = newSVsv(repl_sv); 3349 sv_utf8_upgrade(repl_sv_copy); 3350 repl = SvPV_const(repl_sv_copy, repl_len); 3351 } 3352 if (!SvOK(sv)) 3353 SvPVCLEAR(sv); 3354 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0); 3355 SvREFCNT_dec(repl_sv_copy); 3356 } 3357 } 3358 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) 3359 SP++; 3360 else if (rvalue) { 3361 SvSETMAGIC(TARG); 3362 PUSHs(TARG); 3363 } 3364 RETURN; 3365 3366 bound_fail: 3367 if (repl) 3368 Perl_croak(aTHX_ "substr outside of string"); 3369 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string"); 3370 RETPUSHUNDEF; 3371 } 3372 3373 PP(pp_vec) 3374 { 3375 dSP; 3376 const IV size = POPi; 3377 SV* offsetsv = POPs; 3378 SV * const src = POPs; 3379 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET; 3380 SV * ret; 3381 UV retuv; 3382 STRLEN offset = 0; 3383 char errflags = 0; 3384 3385 /* extract a STRLEN-ranged integer value from offsetsv into offset, 3386 * or flag that its out of range */ 3387 { 3388 IV iv = SvIV(offsetsv); 3389 3390 /* avoid a large UV being wrapped to a negative value */ 3391 if (SvIOK_UV(offsetsv) && SvUVX(offsetsv) > (UV)IV_MAX) 3392 errflags = LVf_OUT_OF_RANGE; 3393 else if (iv < 0) 3394 errflags = (LVf_NEG_OFF|LVf_OUT_OF_RANGE); 3395 #if PTRSIZE < IVSIZE 3396 else if (iv > Size_t_MAX) 3397 errflags = LVf_OUT_OF_RANGE; 3398 #endif 3399 else 3400 offset = (STRLEN)iv; 3401 } 3402 3403 retuv = errflags ? 0 : do_vecget(src, offset, size); 3404 3405 if (lvalue) { /* it's an lvalue! */ 3406 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */ 3407 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0); 3408 LvTYPE(ret) = 'v'; 3409 LvTARG(ret) = SvREFCNT_inc_simple(src); 3410 LvTARGOFF(ret) = offset; 3411 LvTARGLEN(ret) = size; 3412 LvFLAGS(ret) = errflags; 3413 } 3414 else { 3415 dTARGET; 3416 SvTAINTED_off(TARG); /* decontaminate */ 3417 ret = TARG; 3418 } 3419 3420 sv_setuv(ret, retuv); 3421 if (!lvalue) 3422 SvSETMAGIC(ret); 3423 PUSHs(ret); 3424 RETURN; 3425 } 3426 3427 3428 /* also used for: pp_rindex() */ 3429 3430 PP(pp_index) 3431 { 3432 dSP; dTARGET; 3433 SV *big; 3434 SV *little; 3435 SV *temp = NULL; 3436 STRLEN biglen; 3437 STRLEN llen = 0; 3438 SSize_t offset = 0; 3439 SSize_t retval; 3440 const char *big_p; 3441 const char *little_p; 3442 bool big_utf8; 3443 bool little_utf8; 3444 const bool is_index = PL_op->op_type == OP_INDEX; 3445 const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0)); 3446 3447 if (threeargs) 3448 offset = POPi; 3449 little = POPs; 3450 big = POPs; 3451 big_p = SvPV_const(big, biglen); 3452 little_p = SvPV_const(little, llen); 3453 3454 big_utf8 = DO_UTF8(big); 3455 little_utf8 = DO_UTF8(little); 3456 if (big_utf8 ^ little_utf8) { 3457 /* One needs to be upgraded. */ 3458 if (little_utf8) { 3459 /* Well, maybe instead we might be able to downgrade the small 3460 string? */ 3461 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen, 3462 &little_utf8); 3463 if (little_utf8) { 3464 /* If the large string is ISO-8859-1, and it's not possible to 3465 convert the small string to ISO-8859-1, then there is no 3466 way that it could be found anywhere by index. */ 3467 retval = -1; 3468 goto push_result; 3469 } 3470 3471 /* At this point, pv is a malloc()ed string. So donate it to temp 3472 to ensure it will get free()d */ 3473 little = temp = newSV(0); 3474 sv_usepvn(temp, pv, llen); 3475 little_p = SvPVX(little); 3476 } else { 3477 temp = newSVpvn(little_p, llen); 3478 3479 sv_utf8_upgrade(temp); 3480 little = temp; 3481 little_p = SvPV_const(little, llen); 3482 } 3483 } 3484 if (SvGAMAGIC(big)) { 3485 /* Life just becomes a lot easier if I use a temporary here. 3486 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously) 3487 will trigger magic and overloading again, as will fbm_instr() 3488 */ 3489 big = newSVpvn_flags(big_p, biglen, 3490 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0)); 3491 big_p = SvPVX(big); 3492 } 3493 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) { 3494 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will 3495 warn on undef, and we've already triggered a warning with the 3496 SvPV_const some lines above. We can't remove that, as we need to 3497 call some SvPV to trigger overloading early and find out if the 3498 string is UTF-8. 3499 This is all getting too messy. The API isn't quite clean enough, 3500 because data access has side effects. 3501 */ 3502 little = newSVpvn_flags(little_p, llen, 3503 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0)); 3504 little_p = SvPVX(little); 3505 } 3506 3507 if (!threeargs) 3508 offset = is_index ? 0 : biglen; 3509 else { 3510 if (big_utf8 && offset > 0) 3511 offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN); 3512 if (!is_index) 3513 offset += llen; 3514 } 3515 if (offset < 0) 3516 offset = 0; 3517 else if (offset > (SSize_t)biglen) 3518 offset = biglen; 3519 if (!(little_p = is_index 3520 ? fbm_instr((unsigned char*)big_p + offset, 3521 (unsigned char*)big_p + biglen, little, 0) 3522 : rninstr(big_p, big_p + offset, 3523 little_p, little_p + llen))) 3524 retval = -1; 3525 else { 3526 retval = little_p - big_p; 3527 if (retval > 1 && big_utf8) 3528 retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN); 3529 } 3530 SvREFCNT_dec(temp); 3531 3532 push_result: 3533 /* OPpTRUEBOOL indicates an '== -1' has been optimised away */ 3534 if (PL_op->op_private & OPpTRUEBOOL) { 3535 PUSHs( ((retval != -1) ^ cBOOL(PL_op->op_private & OPpINDEX_BOOLNEG)) 3536 ? &PL_sv_yes : &PL_sv_no); 3537 if (PL_op->op_private & OPpTARGET_MY) 3538 /* $lex = (index() == -1) */ 3539 sv_setsv(TARG, TOPs); 3540 } 3541 else 3542 PUSHi(retval); 3543 RETURN; 3544 } 3545 3546 PP(pp_sprintf) 3547 { 3548 dSP; dMARK; dORIGMARK; dTARGET; 3549 SvTAINTED_off(TARG); 3550 do_sprintf(TARG, SP-MARK, MARK+1); 3551 TAINT_IF(SvTAINTED(TARG)); 3552 SP = ORIGMARK; 3553 PUSHTARG; 3554 RETURN; 3555 } 3556 3557 PP(pp_ord) 3558 { 3559 dSP; dTARGET; 3560 3561 SV *argsv = TOPs; 3562 STRLEN len; 3563 const U8 *s = (U8*)SvPV_const(argsv, len); 3564 3565 SETu(DO_UTF8(argsv) 3566 ? (len ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV) : 0) 3567 : (UV)(*s)); 3568 3569 return NORMAL; 3570 } 3571 3572 PP(pp_chr) 3573 { 3574 dSP; dTARGET; 3575 char *tmps; 3576 UV value; 3577 SV *top = TOPs; 3578 3579 SvGETMAGIC(top); 3580 if (UNLIKELY(SvAMAGIC(top))) 3581 top = sv_2num(top); 3582 if (UNLIKELY(isinfnansv(top))) 3583 Perl_croak(aTHX_ "Cannot chr %" NVgf, SvNV(top)); 3584 else { 3585 if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */ 3586 && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0) 3587 || 3588 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top))) 3589 && SvNV_nomg(top) < 0.0))) 3590 { 3591 if (ckWARN(WARN_UTF8)) { 3592 if (SvGMAGICAL(top)) { 3593 SV *top2 = sv_newmortal(); 3594 sv_setsv_nomg(top2, top); 3595 top = top2; 3596 } 3597 Perl_warner(aTHX_ packWARN(WARN_UTF8), 3598 "Invalid negative number (%" SVf ") in chr", SVfARG(top)); 3599 } 3600 value = UNICODE_REPLACEMENT; 3601 } else { 3602 value = SvUV_nomg(top); 3603 } 3604 } 3605 3606 SvUPGRADE(TARG,SVt_PV); 3607 3608 if (value > 255 && !IN_BYTES) { 3609 SvGROW(TARG, (STRLEN)UVCHR_SKIP(value)+1); 3610 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0); 3611 SvCUR_set(TARG, tmps - SvPVX_const(TARG)); 3612 *tmps = '\0'; 3613 (void)SvPOK_only(TARG); 3614 SvUTF8_on(TARG); 3615 SETTARG; 3616 return NORMAL; 3617 } 3618 3619 SvGROW(TARG,2); 3620 SvCUR_set(TARG, 1); 3621 tmps = SvPVX(TARG); 3622 *tmps++ = (char)value; 3623 *tmps = '\0'; 3624 (void)SvPOK_only(TARG); 3625 3626 SETTARG; 3627 return NORMAL; 3628 } 3629 3630 PP(pp_crypt) 3631 { 3632 #ifdef HAS_CRYPT 3633 dSP; dTARGET; 3634 dPOPTOPssrl; 3635 STRLEN len; 3636 const char *tmps = SvPV_const(left, len); 3637 3638 if (DO_UTF8(left)) { 3639 /* If Unicode, try to downgrade. 3640 * If not possible, croak. 3641 * Yes, we made this up. */ 3642 SV* const tsv = newSVpvn_flags(tmps, len, SVf_UTF8|SVs_TEMP); 3643 3644 sv_utf8_downgrade(tsv, FALSE); 3645 tmps = SvPV_const(tsv, len); 3646 } 3647 # ifdef USE_ITHREADS 3648 # ifdef HAS_CRYPT_R 3649 if (!PL_reentrant_buffer->_crypt_struct_buffer) { 3650 /* This should be threadsafe because in ithreads there is only 3651 * one thread per interpreter. If this would not be true, 3652 * we would need a mutex to protect this malloc. */ 3653 PL_reentrant_buffer->_crypt_struct_buffer = 3654 (struct crypt_data *)safemalloc(sizeof(struct crypt_data)); 3655 #if defined(__GLIBC__) || defined(__EMX__) 3656 if (PL_reentrant_buffer->_crypt_struct_buffer) { 3657 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0; 3658 #if (defined(__GLIBC__) && __GLIBC__ == 2) && \ 3659 (defined(__GLIBC_MINOR__) && __GLIBC_MINOR__ >= 2 && __GLIBC_MINOR__ < 4) 3660 /* work around glibc-2.2.5 bug, has been fixed at some 3661 * time in glibc-2.3.X */ 3662 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0; 3663 #endif 3664 } 3665 #endif 3666 } 3667 # endif /* HAS_CRYPT_R */ 3668 # endif /* USE_ITHREADS */ 3669 # ifdef FCRYPT 3670 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right))); 3671 # else 3672 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right))); 3673 # endif 3674 SvUTF8_off(TARG); 3675 SETTARG; 3676 RETURN; 3677 #else 3678 DIE(aTHX_ 3679 "The crypt() function is unimplemented due to excessive paranoia."); 3680 #endif 3681 } 3682 3683 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So 3684 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */ 3685 3686 3687 /* also used for: pp_lcfirst() */ 3688 3689 PP(pp_ucfirst) 3690 { 3691 /* Actually is both lcfirst() and ucfirst(). Only the first character 3692 * changes. This means that possibly we can change in-place, ie., just 3693 * take the source and change that one character and store it back, but not 3694 * if read-only etc, or if the length changes */ 3695 3696 dSP; 3697 SV *source = TOPs; 3698 STRLEN slen; /* slen is the byte length of the whole SV. */ 3699 STRLEN need; 3700 SV *dest; 3701 bool inplace; /* ? Convert first char only, in-place */ 3702 bool doing_utf8 = FALSE; /* ? using utf8 */ 3703 bool convert_source_to_utf8 = FALSE; /* ? need to convert */ 3704 const int op_type = PL_op->op_type; 3705 const U8 *s; 3706 U8 *d; 3707 U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; 3708 STRLEN ulen; /* ulen is the byte length of the original Unicode character 3709 * stored as UTF-8 at s. */ 3710 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or 3711 * lowercased) character stored in tmpbuf. May be either 3712 * UTF-8 or not, but in either case is the number of bytes */ 3713 3714 s = (const U8*)SvPV_const(source, slen); 3715 3716 /* We may be able to get away with changing only the first character, in 3717 * place, but not if read-only, etc. Later we may discover more reasons to 3718 * not convert in-place. */ 3719 inplace = !SvREADONLY(source) && SvPADTMP(source); 3720 3721 #ifdef USE_LOCALE_CTYPE 3722 3723 if (IN_LC_RUNTIME(LC_CTYPE)) { 3724 _CHECK_AND_WARN_PROBLEMATIC_LOCALE; 3725 } 3726 3727 #endif 3728 3729 /* First calculate what the changed first character should be. This affects 3730 * whether we can just swap it out, leaving the rest of the string unchanged, 3731 * or even if have to convert the dest to UTF-8 when the source isn't */ 3732 3733 if (! slen) { /* If empty */ 3734 need = 1; /* still need a trailing NUL */ 3735 ulen = 0; 3736 *tmpbuf = '\0'; 3737 } 3738 else if (DO_UTF8(source)) { /* Is the source utf8? */ 3739 doing_utf8 = TRUE; 3740 ulen = UTF8SKIP(s); 3741 if (op_type == OP_UCFIRST) { 3742 #ifdef USE_LOCALE_CTYPE 3743 _toTITLE_utf8_flags(s, s +slen, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE)); 3744 #else 3745 _toTITLE_utf8_flags(s, s +slen, tmpbuf, &tculen, 0); 3746 #endif 3747 } 3748 else { 3749 #ifdef USE_LOCALE_CTYPE 3750 _toLOWER_utf8_flags(s, s + slen, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE)); 3751 #else 3752 _toLOWER_utf8_flags(s, s + slen, tmpbuf, &tculen, 0); 3753 #endif 3754 } 3755 3756 /* we can't do in-place if the length changes. */ 3757 if (ulen != tculen) inplace = FALSE; 3758 need = slen + 1 - ulen + tculen; 3759 } 3760 else { /* Non-zero length, non-UTF-8, Need to consider locale and if 3761 * latin1 is treated as caseless. Note that a locale takes 3762 * precedence */ 3763 ulen = 1; /* Original character is 1 byte */ 3764 tculen = 1; /* Most characters will require one byte, but this will 3765 * need to be overridden for the tricky ones */ 3766 need = slen + 1; 3767 3768 if (op_type == OP_LCFIRST) { 3769 3770 /* lower case the first letter: no trickiness for any character */ 3771 #ifdef USE_LOCALE_CTYPE 3772 if (IN_LC_RUNTIME(LC_CTYPE)) { 3773 *tmpbuf = toLOWER_LC(*s); 3774 } 3775 else 3776 #endif 3777 { 3778 *tmpbuf = (IN_UNI_8_BIT) 3779 ? toLOWER_LATIN1(*s) 3780 : toLOWER(*s); 3781 } 3782 } 3783 #ifdef USE_LOCALE_CTYPE 3784 /* is ucfirst() */ 3785 else if (IN_LC_RUNTIME(LC_CTYPE)) { 3786 if (IN_UTF8_CTYPE_LOCALE) { 3787 goto do_uni_rules; 3788 } 3789 3790 *tmpbuf = (U8) toUPPER_LC(*s); /* This would be a bug if any 3791 locales have upper and title case 3792 different */ 3793 } 3794 #endif 3795 else if (! IN_UNI_8_BIT) { 3796 *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or 3797 * on EBCDIC machines whatever the 3798 * native function does */ 3799 } 3800 else { 3801 /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is 3802 * UTF-8, which we treat as not in locale), and cased latin1 */ 3803 UV title_ord; 3804 #ifdef USE_LOCALE_CTYPE 3805 do_uni_rules: 3806 #endif 3807 3808 title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's'); 3809 if (tculen > 1) { 3810 assert(tculen == 2); 3811 3812 /* If the result is an upper Latin1-range character, it can 3813 * still be represented in one byte, which is its ordinal */ 3814 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) { 3815 *tmpbuf = (U8) title_ord; 3816 tculen = 1; 3817 } 3818 else { 3819 /* Otherwise it became more than one ASCII character (in 3820 * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to 3821 * beyond Latin1, so the number of bytes changed, so can't 3822 * replace just the first character in place. */ 3823 inplace = FALSE; 3824 3825 /* If the result won't fit in a byte, the entire result 3826 * will have to be in UTF-8. Assume worst case sizing in 3827 * conversion. (all latin1 characters occupy at most two 3828 * bytes in utf8) */ 3829 if (title_ord > 255) { 3830 doing_utf8 = TRUE; 3831 convert_source_to_utf8 = TRUE; 3832 need = slen * 2 + 1; 3833 3834 /* The (converted) UTF-8 and UTF-EBCDIC lengths of all 3835 * (both) characters whose title case is above 255 is 3836 * 2. */ 3837 ulen = 2; 3838 } 3839 else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */ 3840 need = slen + 1 + 1; 3841 } 3842 } 3843 } 3844 } /* End of use Unicode (Latin1) semantics */ 3845 } /* End of changing the case of the first character */ 3846 3847 /* Here, have the first character's changed case stored in tmpbuf. Ready to 3848 * generate the result */ 3849 if (inplace) { 3850 3851 /* We can convert in place. This means we change just the first 3852 * character without disturbing the rest; no need to grow */ 3853 dest = source; 3854 s = d = (U8*)SvPV_force_nomg(source, slen); 3855 } else { 3856 dTARGET; 3857 3858 dest = TARG; 3859 3860 /* Here, we can't convert in place; we earlier calculated how much 3861 * space we will need, so grow to accommodate that */ 3862 SvUPGRADE(dest, SVt_PV); 3863 d = (U8*)SvGROW(dest, need); 3864 (void)SvPOK_only(dest); 3865 3866 SETs(dest); 3867 } 3868 3869 if (doing_utf8) { 3870 if (! inplace) { 3871 if (! convert_source_to_utf8) { 3872 3873 /* Here both source and dest are in UTF-8, but have to create 3874 * the entire output. We initialize the result to be the 3875 * title/lower cased first character, and then append the rest 3876 * of the string. */ 3877 sv_setpvn(dest, (char*)tmpbuf, tculen); 3878 if (slen > ulen) { 3879 sv_catpvn(dest, (char*)(s + ulen), slen - ulen); 3880 } 3881 } 3882 else { 3883 const U8 *const send = s + slen; 3884 3885 /* Here the dest needs to be in UTF-8, but the source isn't, 3886 * except we earlier UTF-8'd the first character of the source 3887 * into tmpbuf. First put that into dest, and then append the 3888 * rest of the source, converting it to UTF-8 as we go. */ 3889 3890 /* Assert tculen is 2 here because the only two characters that 3891 * get to this part of the code have 2-byte UTF-8 equivalents */ 3892 *d++ = *tmpbuf; 3893 *d++ = *(tmpbuf + 1); 3894 s++; /* We have just processed the 1st char */ 3895 3896 for (; s < send; s++) { 3897 d = uvchr_to_utf8(d, *s); 3898 } 3899 *d = '\0'; 3900 SvCUR_set(dest, d - (U8*)SvPVX_const(dest)); 3901 } 3902 SvUTF8_on(dest); 3903 } 3904 else { /* in-place UTF-8. Just overwrite the first character */ 3905 Copy(tmpbuf, d, tculen, U8); 3906 SvCUR_set(dest, need - 1); 3907 } 3908 3909 } 3910 else { /* Neither source nor dest are in or need to be UTF-8 */ 3911 if (slen) { 3912 if (inplace) { /* in-place, only need to change the 1st char */ 3913 *d = *tmpbuf; 3914 } 3915 else { /* Not in-place */ 3916 3917 /* Copy the case-changed character(s) from tmpbuf */ 3918 Copy(tmpbuf, d, tculen, U8); 3919 d += tculen - 1; /* Code below expects d to point to final 3920 * character stored */ 3921 } 3922 } 3923 else { /* empty source */ 3924 /* See bug #39028: Don't taint if empty */ 3925 *d = *s; 3926 } 3927 3928 /* In a "use bytes" we don't treat the source as UTF-8, but, still want 3929 * the destination to retain that flag */ 3930 if (SvUTF8(source) && ! IN_BYTES) 3931 SvUTF8_on(dest); 3932 3933 if (!inplace) { /* Finish the rest of the string, unchanged */ 3934 /* This will copy the trailing NUL */ 3935 Copy(s + 1, d + 1, slen, U8); 3936 SvCUR_set(dest, need - 1); 3937 } 3938 } 3939 #ifdef USE_LOCALE_CTYPE 3940 if (IN_LC_RUNTIME(LC_CTYPE)) { 3941 TAINT; 3942 SvTAINTED_on(dest); 3943 } 3944 #endif 3945 if (dest != source && SvTAINTED(source)) 3946 SvTAINT(dest); 3947 SvSETMAGIC(dest); 3948 return NORMAL; 3949 } 3950 3951 /* There's so much setup/teardown code common between uc and lc, I wonder if 3952 it would be worth merging the two, and just having a switch outside each 3953 of the three tight loops. There is less and less commonality though */ 3954 PP(pp_uc) 3955 { 3956 dSP; 3957 SV *source = TOPs; 3958 STRLEN len; 3959 STRLEN min; 3960 SV *dest; 3961 const U8 *s; 3962 U8 *d; 3963 3964 SvGETMAGIC(source); 3965 3966 if ( SvPADTMP(source) 3967 && !SvREADONLY(source) && SvPOK(source) 3968 && !DO_UTF8(source) 3969 && ( 3970 #ifdef USE_LOCALE_CTYPE 3971 (IN_LC_RUNTIME(LC_CTYPE)) 3972 ? ! IN_UTF8_CTYPE_LOCALE 3973 : 3974 #endif 3975 ! IN_UNI_8_BIT)) 3976 { 3977 3978 /* We can convert in place. The reason we can't if in UNI_8_BIT is to 3979 * make the loop tight, so we overwrite the source with the dest before 3980 * looking at it, and we need to look at the original source 3981 * afterwards. There would also need to be code added to handle 3982 * switching to not in-place in midstream if we run into characters 3983 * that change the length. Since being in locale overrides UNI_8_BIT, 3984 * that latter becomes irrelevant in the above test; instead for 3985 * locale, the size can't normally change, except if the locale is a 3986 * UTF-8 one */ 3987 dest = source; 3988 s = d = (U8*)SvPV_force_nomg(source, len); 3989 min = len + 1; 3990 } else { 3991 dTARGET; 3992 3993 dest = TARG; 3994 3995 s = (const U8*)SvPV_nomg_const(source, len); 3996 min = len + 1; 3997 3998 SvUPGRADE(dest, SVt_PV); 3999 d = (U8*)SvGROW(dest, min); 4000 (void)SvPOK_only(dest); 4001 4002 SETs(dest); 4003 } 4004 4005 #ifdef USE_LOCALE_CTYPE 4006 4007 if (IN_LC_RUNTIME(LC_CTYPE)) { 4008 _CHECK_AND_WARN_PROBLEMATIC_LOCALE; 4009 } 4010 4011 #endif 4012 4013 /* Overloaded values may have toggled the UTF-8 flag on source, so we need 4014 to check DO_UTF8 again here. */ 4015 4016 if (DO_UTF8(source)) { 4017 const U8 *const send = s + len; 4018 U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; 4019 4020 /* All occurrences of these are to be moved to follow any other marks. 4021 * This is context-dependent. We may not be passed enough context to 4022 * move the iota subscript beyond all of them, but we do the best we can 4023 * with what we're given. The result is always better than if we 4024 * hadn't done this. And, the problem would only arise if we are 4025 * passed a character without all its combining marks, which would be 4026 * the caller's mistake. The information this is based on comes from a 4027 * comment in Unicode SpecialCasing.txt, (and the Standard's text 4028 * itself) and so can't be checked properly to see if it ever gets 4029 * revised. But the likelihood of it changing is remote */ 4030 bool in_iota_subscript = FALSE; 4031 4032 while (s < send) { 4033 STRLEN u; 4034 STRLEN ulen; 4035 UV uv; 4036 if (in_iota_subscript && ! _is_utf8_mark(s)) { 4037 4038 /* A non-mark. Time to output the iota subscript */ 4039 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8); 4040 d += capital_iota_len; 4041 in_iota_subscript = FALSE; 4042 } 4043 4044 /* Then handle the current character. Get the changed case value 4045 * and copy it to the output buffer */ 4046 4047 u = UTF8SKIP(s); 4048 #ifdef USE_LOCALE_CTYPE 4049 uv = _toUPPER_utf8_flags(s, send, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE)); 4050 #else 4051 uv = _toUPPER_utf8_flags(s, send, tmpbuf, &ulen, 0); 4052 #endif 4053 #define GREEK_CAPITAL_LETTER_IOTA 0x0399 4054 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345 4055 if (uv == GREEK_CAPITAL_LETTER_IOTA 4056 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI) 4057 { 4058 in_iota_subscript = TRUE; 4059 } 4060 else { 4061 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) { 4062 /* If the eventually required minimum size outgrows the 4063 * available space, we need to grow. */ 4064 const UV o = d - (U8*)SvPVX_const(dest); 4065 4066 /* If someone uppercases one million U+03B0s we SvGROW() 4067 * one million times. Or we could try guessing how much to 4068 * allocate without allocating too much. Such is life. 4069 * See corresponding comment in lc code for another option 4070 * */ 4071 d = o + (U8*) SvGROW(dest, min); 4072 } 4073 Copy(tmpbuf, d, ulen, U8); 4074 d += ulen; 4075 } 4076 s += u; 4077 } 4078 if (in_iota_subscript) { 4079 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8); 4080 d += capital_iota_len; 4081 } 4082 SvUTF8_on(dest); 4083 *d = '\0'; 4084 4085 SvCUR_set(dest, d - (U8*)SvPVX_const(dest)); 4086 } 4087 else { /* Not UTF-8 */ 4088 if (len) { 4089 const U8 *const send = s + len; 4090 4091 /* Use locale casing if in locale; regular style if not treating 4092 * latin1 as having case; otherwise the latin1 casing. Do the 4093 * whole thing in a tight loop, for speed, */ 4094 #ifdef USE_LOCALE_CTYPE 4095 if (IN_LC_RUNTIME(LC_CTYPE)) { 4096 if (IN_UTF8_CTYPE_LOCALE) { 4097 goto do_uni_rules; 4098 } 4099 for (; s < send; d++, s++) 4100 *d = (U8) toUPPER_LC(*s); 4101 } 4102 else 4103 #endif 4104 if (! IN_UNI_8_BIT) { 4105 for (; s < send; d++, s++) { 4106 *d = toUPPER(*s); 4107 } 4108 } 4109 else { 4110 #ifdef USE_LOCALE_CTYPE 4111 do_uni_rules: 4112 #endif 4113 for (; s < send; d++, s++) { 4114 *d = toUPPER_LATIN1_MOD(*s); 4115 if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) { 4116 continue; 4117 } 4118 4119 /* The mainstream case is the tight loop above. To avoid 4120 * extra tests in that, all three characters that require 4121 * special handling are mapped by the MOD to the one tested 4122 * just above. 4123 * Use the source to distinguish between the three cases */ 4124 4125 #if UNICODE_MAJOR_VERSION > 2 \ 4126 || (UNICODE_MAJOR_VERSION == 2 && UNICODE_DOT_VERSION >= 1 \ 4127 && UNICODE_DOT_DOT_VERSION >= 8) 4128 if (*s == LATIN_SMALL_LETTER_SHARP_S) { 4129 4130 /* uc() of this requires 2 characters, but they are 4131 * ASCII. If not enough room, grow the string */ 4132 if (SvLEN(dest) < ++min) { 4133 const UV o = d - (U8*)SvPVX_const(dest); 4134 d = o + (U8*) SvGROW(dest, min); 4135 } 4136 *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */ 4137 continue; /* Back to the tight loop; still in ASCII */ 4138 } 4139 #endif 4140 4141 /* The other two special handling characters have their 4142 * upper cases outside the latin1 range, hence need to be 4143 * in UTF-8, so the whole result needs to be in UTF-8. So, 4144 * here we are somewhere in the middle of processing a 4145 * non-UTF-8 string, and realize that we will have to convert 4146 * the whole thing to UTF-8. What to do? There are 4147 * several possibilities. The simplest to code is to 4148 * convert what we have so far, set a flag, and continue on 4149 * in the loop. The flag would be tested each time through 4150 * the loop, and if set, the next character would be 4151 * converted to UTF-8 and stored. But, I (khw) didn't want 4152 * to slow down the mainstream case at all for this fairly 4153 * rare case, so I didn't want to add a test that didn't 4154 * absolutely have to be there in the loop, besides the 4155 * possibility that it would get too complicated for 4156 * optimizers to deal with. Another possibility is to just 4157 * give up, convert the source to UTF-8, and restart the 4158 * function that way. Another possibility is to convert 4159 * both what has already been processed and what is yet to 4160 * come separately to UTF-8, then jump into the loop that 4161 * handles UTF-8. But the most efficient time-wise of the 4162 * ones I could think of is what follows, and turned out to 4163 * not require much extra code. */ 4164 4165 /* Convert what we have so far into UTF-8, telling the 4166 * function that we know it should be converted, and to 4167 * allow extra space for what we haven't processed yet. 4168 * Assume the worst case space requirements for converting 4169 * what we haven't processed so far: that it will require 4170 * two bytes for each remaining source character, plus the 4171 * NUL at the end. This may cause the string pointer to 4172 * move, so re-find it. */ 4173 4174 len = d - (U8*)SvPVX_const(dest); 4175 SvCUR_set(dest, len); 4176 len = sv_utf8_upgrade_flags_grow(dest, 4177 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE, 4178 (send -s) * 2 + 1); 4179 d = (U8*)SvPVX(dest) + len; 4180 4181 /* Now process the remainder of the source, converting to 4182 * upper and UTF-8. If a resulting byte is invariant in 4183 * UTF-8, output it as-is, otherwise convert to UTF-8 and 4184 * append it to the output. */ 4185 for (; s < send; s++) { 4186 (void) _to_upper_title_latin1(*s, d, &len, 'S'); 4187 d += len; 4188 } 4189 4190 /* Here have processed the whole source; no need to continue 4191 * with the outer loop. Each character has been converted 4192 * to upper case and converted to UTF-8 */ 4193 4194 break; 4195 } /* End of processing all latin1-style chars */ 4196 } /* End of processing all chars */ 4197 } /* End of source is not empty */ 4198 4199 if (source != dest) { 4200 *d = '\0'; /* Here d points to 1 after last char, add NUL */ 4201 SvCUR_set(dest, d - (U8*)SvPVX_const(dest)); 4202 } 4203 } /* End of isn't utf8 */ 4204 #ifdef USE_LOCALE_CTYPE 4205 if (IN_LC_RUNTIME(LC_CTYPE)) { 4206 TAINT; 4207 SvTAINTED_on(dest); 4208 } 4209 #endif 4210 if (dest != source && SvTAINTED(source)) 4211 SvTAINT(dest); 4212 SvSETMAGIC(dest); 4213 return NORMAL; 4214 } 4215 4216 PP(pp_lc) 4217 { 4218 dSP; 4219 SV *source = TOPs; 4220 STRLEN len; 4221 STRLEN min; 4222 SV *dest; 4223 const U8 *s; 4224 U8 *d; 4225 4226 SvGETMAGIC(source); 4227 4228 if ( SvPADTMP(source) 4229 && !SvREADONLY(source) && SvPOK(source) 4230 && !DO_UTF8(source)) { 4231 4232 /* We can convert in place, as lowercasing anything in the latin1 range 4233 * (or else DO_UTF8 would have been on) doesn't lengthen it */ 4234 dest = source; 4235 s = d = (U8*)SvPV_force_nomg(source, len); 4236 min = len + 1; 4237 } else { 4238 dTARGET; 4239 4240 dest = TARG; 4241 4242 s = (const U8*)SvPV_nomg_const(source, len); 4243 min = len + 1; 4244 4245 SvUPGRADE(dest, SVt_PV); 4246 d = (U8*)SvGROW(dest, min); 4247 (void)SvPOK_only(dest); 4248 4249 SETs(dest); 4250 } 4251 4252 #ifdef USE_LOCALE_CTYPE 4253 4254 if (IN_LC_RUNTIME(LC_CTYPE)) { 4255 _CHECK_AND_WARN_PROBLEMATIC_LOCALE; 4256 } 4257 4258 #endif 4259 4260 /* Overloaded values may have toggled the UTF-8 flag on source, so we need 4261 to check DO_UTF8 again here. */ 4262 4263 if (DO_UTF8(source)) { 4264 const U8 *const send = s + len; 4265 U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; 4266 4267 while (s < send) { 4268 const STRLEN u = UTF8SKIP(s); 4269 STRLEN ulen; 4270 4271 #ifdef USE_LOCALE_CTYPE 4272 _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE)); 4273 #else 4274 _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, 0); 4275 #endif 4276 4277 /* Here is where we would do context-sensitive actions. See the 4278 * commit message for 86510fb15 for why there isn't any */ 4279 4280 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) { 4281 4282 /* If the eventually required minimum size outgrows the 4283 * available space, we need to grow. */ 4284 const UV o = d - (U8*)SvPVX_const(dest); 4285 4286 /* If someone lowercases one million U+0130s we SvGROW() one 4287 * million times. Or we could try guessing how much to 4288 * allocate without allocating too much. Such is life. 4289 * Another option would be to grow an extra byte or two more 4290 * each time we need to grow, which would cut down the million 4291 * to 500K, with little waste */ 4292 d = o + (U8*) SvGROW(dest, min); 4293 } 4294 4295 /* Copy the newly lowercased letter to the output buffer we're 4296 * building */ 4297 Copy(tmpbuf, d, ulen, U8); 4298 d += ulen; 4299 s += u; 4300 } /* End of looping through the source string */ 4301 SvUTF8_on(dest); 4302 *d = '\0'; 4303 SvCUR_set(dest, d - (U8*)SvPVX_const(dest)); 4304 } else { /* Not utf8 */ 4305 if (len) { 4306 const U8 *const send = s + len; 4307 4308 /* Use locale casing if in locale; regular style if not treating 4309 * latin1 as having case; otherwise the latin1 casing. Do the 4310 * whole thing in a tight loop, for speed, */ 4311 #ifdef USE_LOCALE_CTYPE 4312 if (IN_LC_RUNTIME(LC_CTYPE)) { 4313 for (; s < send; d++, s++) 4314 *d = toLOWER_LC(*s); 4315 } 4316 else 4317 #endif 4318 if (! IN_UNI_8_BIT) { 4319 for (; s < send; d++, s++) { 4320 *d = toLOWER(*s); 4321 } 4322 } 4323 else { 4324 for (; s < send; d++, s++) { 4325 *d = toLOWER_LATIN1(*s); 4326 } 4327 } 4328 } 4329 if (source != dest) { 4330 *d = '\0'; 4331 SvCUR_set(dest, d - (U8*)SvPVX_const(dest)); 4332 } 4333 } 4334 #ifdef USE_LOCALE_CTYPE 4335 if (IN_LC_RUNTIME(LC_CTYPE)) { 4336 TAINT; 4337 SvTAINTED_on(dest); 4338 } 4339 #endif 4340 if (dest != source && SvTAINTED(source)) 4341 SvTAINT(dest); 4342 SvSETMAGIC(dest); 4343 return NORMAL; 4344 } 4345 4346 PP(pp_quotemeta) 4347 { 4348 dSP; dTARGET; 4349 SV * const sv = TOPs; 4350 STRLEN len; 4351 const char *s = SvPV_const(sv,len); 4352 4353 SvUTF8_off(TARG); /* decontaminate */ 4354 if (len) { 4355 char *d; 4356 SvUPGRADE(TARG, SVt_PV); 4357 SvGROW(TARG, (len * 2) + 1); 4358 d = SvPVX(TARG); 4359 if (DO_UTF8(sv)) { 4360 while (len) { 4361 STRLEN ulen = UTF8SKIP(s); 4362 bool to_quote = FALSE; 4363 4364 if (UTF8_IS_INVARIANT(*s)) { 4365 if (_isQUOTEMETA(*s)) { 4366 to_quote = TRUE; 4367 } 4368 } 4369 else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(s, s + len)) { 4370 if ( 4371 #ifdef USE_LOCALE_CTYPE 4372 /* In locale, we quote all non-ASCII Latin1 chars. 4373 * Otherwise use the quoting rules */ 4374 4375 IN_LC_RUNTIME(LC_CTYPE) 4376 || 4377 #endif 4378 _isQUOTEMETA(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s + 1)))) 4379 { 4380 to_quote = TRUE; 4381 } 4382 } 4383 else if (is_QUOTEMETA_high(s)) { 4384 to_quote = TRUE; 4385 } 4386 4387 if (to_quote) { 4388 *d++ = '\\'; 4389 } 4390 if (ulen > len) 4391 ulen = len; 4392 len -= ulen; 4393 while (ulen--) 4394 *d++ = *s++; 4395 } 4396 SvUTF8_on(TARG); 4397 } 4398 else if (IN_UNI_8_BIT) { 4399 while (len--) { 4400 if (_isQUOTEMETA(*s)) 4401 *d++ = '\\'; 4402 *d++ = *s++; 4403 } 4404 } 4405 else { 4406 /* For non UNI_8_BIT (and hence in locale) just quote all \W 4407 * including everything above ASCII */ 4408 while (len--) { 4409 if (!isWORDCHAR_A(*s)) 4410 *d++ = '\\'; 4411 *d++ = *s++; 4412 } 4413 } 4414 *d = '\0'; 4415 SvCUR_set(TARG, d - SvPVX_const(TARG)); 4416 (void)SvPOK_only_UTF8(TARG); 4417 } 4418 else 4419 sv_setpvn(TARG, s, len); 4420 SETTARG; 4421 return NORMAL; 4422 } 4423 4424 PP(pp_fc) 4425 { 4426 dTARGET; 4427 dSP; 4428 SV *source = TOPs; 4429 STRLEN len; 4430 STRLEN min; 4431 SV *dest; 4432 const U8 *s; 4433 const U8 *send; 4434 U8 *d; 4435 U8 tmpbuf[UTF8_MAXBYTES_CASE + 1]; 4436 #if UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */ \ 4437 || (UNICODE_MAJOR_VERSION == 3 && ( UNICODE_DOT_VERSION > 0) \ 4438 || UNICODE_DOT_DOT_VERSION > 0) 4439 const bool full_folding = TRUE; /* This variable is here so we can easily 4440 move to more generality later */ 4441 #else 4442 const bool full_folding = FALSE; 4443 #endif 4444 const U8 flags = ( full_folding ? FOLD_FLAGS_FULL : 0 ) 4445 #ifdef USE_LOCALE_CTYPE 4446 | ( IN_LC_RUNTIME(LC_CTYPE) ? FOLD_FLAGS_LOCALE : 0 ) 4447 #endif 4448 ; 4449 4450 /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me. 4451 * You are welcome(?) -Hugmeir 4452 */ 4453 4454 SvGETMAGIC(source); 4455 4456 dest = TARG; 4457 4458 if (SvOK(source)) { 4459 s = (const U8*)SvPV_nomg_const(source, len); 4460 } else { 4461 if (ckWARN(WARN_UNINITIALIZED)) 4462 report_uninit(source); 4463 s = (const U8*)""; 4464 len = 0; 4465 } 4466 4467 min = len + 1; 4468 4469 SvUPGRADE(dest, SVt_PV); 4470 d = (U8*)SvGROW(dest, min); 4471 (void)SvPOK_only(dest); 4472 4473 SETs(dest); 4474 4475 send = s + len; 4476 4477 #ifdef USE_LOCALE_CTYPE 4478 4479 if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */ 4480 _CHECK_AND_WARN_PROBLEMATIC_LOCALE; 4481 } 4482 4483 #endif 4484 4485 if (DO_UTF8(source)) { /* UTF-8 flagged string. */ 4486 while (s < send) { 4487 const STRLEN u = UTF8SKIP(s); 4488 STRLEN ulen; 4489 4490 _toFOLD_utf8_flags(s, send, tmpbuf, &ulen, flags); 4491 4492 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) { 4493 const UV o = d - (U8*)SvPVX_const(dest); 4494 d = o + (U8*) SvGROW(dest, min); 4495 } 4496 4497 Copy(tmpbuf, d, ulen, U8); 4498 d += ulen; 4499 s += u; 4500 } 4501 SvUTF8_on(dest); 4502 } /* Unflagged string */ 4503 else if (len) { 4504 #ifdef USE_LOCALE_CTYPE 4505 if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */ 4506 if (IN_UTF8_CTYPE_LOCALE) { 4507 goto do_uni_folding; 4508 } 4509 for (; s < send; d++, s++) 4510 *d = (U8) toFOLD_LC(*s); 4511 } 4512 else 4513 #endif 4514 if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */ 4515 for (; s < send; d++, s++) 4516 *d = toFOLD(*s); 4517 } 4518 else { 4519 #ifdef USE_LOCALE_CTYPE 4520 do_uni_folding: 4521 #endif 4522 /* For ASCII and the Latin-1 range, there's only two troublesome 4523 * folds, \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full 4524 * casefolding becomes 'ss'; and \x{B5} (\N{MICRO SIGN}), which 4525 * under any fold becomes \x{3BC} (\N{GREEK SMALL LETTER MU}) -- 4526 * For the rest, the casefold is their lowercase. */ 4527 for (; s < send; d++, s++) { 4528 if (*s == MICRO_SIGN) { 4529 /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU}, 4530 * which is outside of the latin-1 range. There's a couple 4531 * of ways to deal with this -- khw discusses them in 4532 * pp_lc/uc, so go there :) What we do here is upgrade what 4533 * we had already casefolded, then enter an inner loop that 4534 * appends the rest of the characters as UTF-8. */ 4535 len = d - (U8*)SvPVX_const(dest); 4536 SvCUR_set(dest, len); 4537 len = sv_utf8_upgrade_flags_grow(dest, 4538 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE, 4539 /* The max expansion for latin1 4540 * chars is 1 byte becomes 2 */ 4541 (send -s) * 2 + 1); 4542 d = (U8*)SvPVX(dest) + len; 4543 4544 Copy(GREEK_SMALL_LETTER_MU_UTF8, d, small_mu_len, U8); 4545 d += small_mu_len; 4546 s++; 4547 for (; s < send; s++) { 4548 STRLEN ulen; 4549 UV fc = _to_uni_fold_flags(*s, tmpbuf, &ulen, flags); 4550 if UVCHR_IS_INVARIANT(fc) { 4551 if (full_folding 4552 && *s == LATIN_SMALL_LETTER_SHARP_S) 4553 { 4554 *d++ = 's'; 4555 *d++ = 's'; 4556 } 4557 else 4558 *d++ = (U8)fc; 4559 } 4560 else { 4561 Copy(tmpbuf, d, ulen, U8); 4562 d += ulen; 4563 } 4564 } 4565 break; 4566 } 4567 else if (full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) { 4568 /* Under full casefolding, LATIN SMALL LETTER SHARP S 4569 * becomes "ss", which may require growing the SV. */ 4570 if (SvLEN(dest) < ++min) { 4571 const UV o = d - (U8*)SvPVX_const(dest); 4572 d = o + (U8*) SvGROW(dest, min); 4573 } 4574 *(d)++ = 's'; 4575 *d = 's'; 4576 } 4577 else { /* If it's not one of those two, the fold is their lower 4578 case */ 4579 *d = toLOWER_LATIN1(*s); 4580 } 4581 } 4582 } 4583 } 4584 *d = '\0'; 4585 SvCUR_set(dest, d - (U8*)SvPVX_const(dest)); 4586 4587 #ifdef USE_LOCALE_CTYPE 4588 if (IN_LC_RUNTIME(LC_CTYPE)) { 4589 TAINT; 4590 SvTAINTED_on(dest); 4591 } 4592 #endif 4593 if (SvTAINTED(source)) 4594 SvTAINT(dest); 4595 SvSETMAGIC(dest); 4596 RETURN; 4597 } 4598 4599 /* Arrays. */ 4600 4601 PP(pp_aslice) 4602 { 4603 dSP; dMARK; dORIGMARK; 4604 AV *const av = MUTABLE_AV(POPs); 4605 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET); 4606 4607 if (SvTYPE(av) == SVt_PVAV) { 4608 const bool localizing = PL_op->op_private & OPpLVAL_INTRO; 4609 bool can_preserve = FALSE; 4610 4611 if (localizing) { 4612 MAGIC *mg; 4613 HV *stash; 4614 4615 can_preserve = SvCANEXISTDELETE(av); 4616 } 4617 4618 if (lval && localizing) { 4619 SV **svp; 4620 SSize_t max = -1; 4621 for (svp = MARK + 1; svp <= SP; svp++) { 4622 const SSize_t elem = SvIV(*svp); 4623 if (elem > max) 4624 max = elem; 4625 } 4626 if (max > AvMAX(av)) 4627 av_extend(av, max); 4628 } 4629 4630 while (++MARK <= SP) { 4631 SV **svp; 4632 SSize_t elem = SvIV(*MARK); 4633 bool preeminent = TRUE; 4634 4635 if (localizing && can_preserve) { 4636 /* If we can determine whether the element exist, 4637 * Try to preserve the existenceness of a tied array 4638 * element by using EXISTS and DELETE if possible. 4639 * Fallback to FETCH and STORE otherwise. */ 4640 preeminent = av_exists(av, elem); 4641 } 4642 4643 svp = av_fetch(av, elem, lval); 4644 if (lval) { 4645 if (!svp || !*svp) 4646 DIE(aTHX_ PL_no_aelem, elem); 4647 if (localizing) { 4648 if (preeminent) 4649 save_aelem(av, elem, svp); 4650 else 4651 SAVEADELETE(av, elem); 4652 } 4653 } 4654 *MARK = svp ? *svp : &PL_sv_undef; 4655 } 4656 } 4657 if (GIMME_V != G_ARRAY) { 4658 MARK = ORIGMARK; 4659 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef; 4660 SP = MARK; 4661 } 4662 RETURN; 4663 } 4664 4665 PP(pp_kvaslice) 4666 { 4667 dSP; dMARK; 4668 AV *const av = MUTABLE_AV(POPs); 4669 I32 lval = (PL_op->op_flags & OPf_MOD); 4670 SSize_t items = SP - MARK; 4671 4672 if (PL_op->op_private & OPpMAYBE_LVSUB) { 4673 const I32 flags = is_lvalue_sub(); 4674 if (flags) { 4675 if (!(flags & OPpENTERSUB_INARGS)) 4676 /* diag_listed_as: Can't modify %s in %s */ 4677 Perl_croak(aTHX_ "Can't modify index/value array slice in list assignment"); 4678 lval = flags; 4679 } 4680 } 4681 4682 MEXTEND(SP,items); 4683 while (items > 1) { 4684 *(MARK+items*2-1) = *(MARK+items); 4685 items--; 4686 } 4687 items = SP-MARK; 4688 SP += items; 4689 4690 while (++MARK <= SP) { 4691 SV **svp; 4692 4693 svp = av_fetch(av, SvIV(*MARK), lval); 4694 if (lval) { 4695 if (!svp || !*svp || *svp == &PL_sv_undef) { 4696 DIE(aTHX_ PL_no_aelem, SvIV(*MARK)); 4697 } 4698 *MARK = sv_mortalcopy(*MARK); 4699 } 4700 *++MARK = svp ? *svp : &PL_sv_undef; 4701 } 4702 if (GIMME_V != G_ARRAY) { 4703 MARK = SP - items*2; 4704 *++MARK = items > 0 ? *SP : &PL_sv_undef; 4705 SP = MARK; 4706 } 4707 RETURN; 4708 } 4709 4710 4711 PP(pp_aeach) 4712 { 4713 dSP; 4714 AV *array = MUTABLE_AV(POPs); 4715 const U8 gimme = GIMME_V; 4716 IV *iterp = Perl_av_iter_p(aTHX_ array); 4717 const IV current = (*iterp)++; 4718 4719 if (current > av_tindex(array)) { 4720 *iterp = 0; 4721 if (gimme == G_SCALAR) 4722 RETPUSHUNDEF; 4723 else 4724 RETURN; 4725 } 4726 4727 EXTEND(SP, 2); 4728 mPUSHi(current); 4729 if (gimme == G_ARRAY) { 4730 SV **const element = av_fetch(array, current, 0); 4731 PUSHs(element ? *element : &PL_sv_undef); 4732 } 4733 RETURN; 4734 } 4735 4736 /* also used for: pp_avalues()*/ 4737 PP(pp_akeys) 4738 { 4739 dSP; 4740 AV *array = MUTABLE_AV(POPs); 4741 const U8 gimme = GIMME_V; 4742 4743 *Perl_av_iter_p(aTHX_ array) = 0; 4744 4745 if (gimme == G_SCALAR) { 4746 dTARGET; 4747 PUSHi(av_tindex(array) + 1); 4748 } 4749 else if (gimme == G_ARRAY) { 4750 if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) { 4751 const I32 flags = is_lvalue_sub(); 4752 if (flags && !(flags & OPpENTERSUB_INARGS)) 4753 /* diag_listed_as: Can't modify %s in %s */ 4754 Perl_croak(aTHX_ 4755 "Can't modify keys on array in list assignment"); 4756 } 4757 { 4758 IV n = Perl_av_len(aTHX_ array); 4759 IV i; 4760 4761 EXTEND(SP, n + 1); 4762 4763 if ( PL_op->op_type == OP_AKEYS 4764 || ( PL_op->op_type == OP_AVHVSWITCH 4765 && (PL_op->op_private & 3) + OP_AEACH == OP_AKEYS )) 4766 { 4767 for (i = 0; i <= n; i++) { 4768 mPUSHi(i); 4769 } 4770 } 4771 else { 4772 for (i = 0; i <= n; i++) { 4773 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0); 4774 PUSHs(elem ? *elem : &PL_sv_undef); 4775 } 4776 } 4777 } 4778 } 4779 RETURN; 4780 } 4781 4782 /* Associative arrays. */ 4783 4784 PP(pp_each) 4785 { 4786 dSP; 4787 HV * hash = MUTABLE_HV(POPs); 4788 HE *entry; 4789 const U8 gimme = GIMME_V; 4790 4791 entry = hv_iternext(hash); 4792 4793 EXTEND(SP, 2); 4794 if (entry) { 4795 SV* const sv = hv_iterkeysv(entry); 4796 PUSHs(sv); 4797 if (gimme == G_ARRAY) { 4798 SV *val; 4799 val = hv_iterval(hash, entry); 4800 PUSHs(val); 4801 } 4802 } 4803 else if (gimme == G_SCALAR) 4804 RETPUSHUNDEF; 4805 4806 RETURN; 4807 } 4808 4809 STATIC OP * 4810 S_do_delete_local(pTHX) 4811 { 4812 dSP; 4813 const U8 gimme = GIMME_V; 4814 const MAGIC *mg; 4815 HV *stash; 4816 const bool sliced = !!(PL_op->op_private & OPpSLICE); 4817 SV **unsliced_keysv = sliced ? NULL : sp--; 4818 SV * const osv = POPs; 4819 SV **mark = sliced ? PL_stack_base + POPMARK : unsliced_keysv-1; 4820 dORIGMARK; 4821 const bool tied = SvRMAGICAL(osv) 4822 && mg_find((const SV *)osv, PERL_MAGIC_tied); 4823 const bool can_preserve = SvCANEXISTDELETE(osv); 4824 const U32 type = SvTYPE(osv); 4825 SV ** const end = sliced ? SP : unsliced_keysv; 4826 4827 if (type == SVt_PVHV) { /* hash element */ 4828 HV * const hv = MUTABLE_HV(osv); 4829 while (++MARK <= end) { 4830 SV * const keysv = *MARK; 4831 SV *sv = NULL; 4832 bool preeminent = TRUE; 4833 if (can_preserve) 4834 preeminent = hv_exists_ent(hv, keysv, 0); 4835 if (tied) { 4836 HE *he = hv_fetch_ent(hv, keysv, 1, 0); 4837 if (he) 4838 sv = HeVAL(he); 4839 else 4840 preeminent = FALSE; 4841 } 4842 else { 4843 sv = hv_delete_ent(hv, keysv, 0, 0); 4844 if (preeminent) 4845 SvREFCNT_inc_simple_void(sv); /* De-mortalize */ 4846 } 4847 if (preeminent) { 4848 if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv)); 4849 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM); 4850 if (tied) { 4851 *MARK = sv_mortalcopy(sv); 4852 mg_clear(sv); 4853 } else 4854 *MARK = sv; 4855 } 4856 else { 4857 SAVEHDELETE(hv, keysv); 4858 *MARK = &PL_sv_undef; 4859 } 4860 } 4861 } 4862 else if (type == SVt_PVAV) { /* array element */ 4863 if (PL_op->op_flags & OPf_SPECIAL) { 4864 AV * const av = MUTABLE_AV(osv); 4865 while (++MARK <= end) { 4866 SSize_t idx = SvIV(*MARK); 4867 SV *sv = NULL; 4868 bool preeminent = TRUE; 4869 if (can_preserve) 4870 preeminent = av_exists(av, idx); 4871 if (tied) { 4872 SV **svp = av_fetch(av, idx, 1); 4873 if (svp) 4874 sv = *svp; 4875 else 4876 preeminent = FALSE; 4877 } 4878 else { 4879 sv = av_delete(av, idx, 0); 4880 if (preeminent) 4881 SvREFCNT_inc_simple_void(sv); /* De-mortalize */ 4882 } 4883 if (preeminent) { 4884 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM); 4885 if (tied) { 4886 *MARK = sv_mortalcopy(sv); 4887 mg_clear(sv); 4888 } else 4889 *MARK = sv; 4890 } 4891 else { 4892 SAVEADELETE(av, idx); 4893 *MARK = &PL_sv_undef; 4894 } 4895 } 4896 } 4897 else 4898 DIE(aTHX_ "panic: avhv_delete no longer supported"); 4899 } 4900 else 4901 DIE(aTHX_ "Not a HASH reference"); 4902 if (sliced) { 4903 if (gimme == G_VOID) 4904 SP = ORIGMARK; 4905 else if (gimme == G_SCALAR) { 4906 MARK = ORIGMARK; 4907 if (SP > MARK) 4908 *++MARK = *SP; 4909 else 4910 *++MARK = &PL_sv_undef; 4911 SP = MARK; 4912 } 4913 } 4914 else if (gimme != G_VOID) 4915 PUSHs(*unsliced_keysv); 4916 4917 RETURN; 4918 } 4919 4920 PP(pp_delete) 4921 { 4922 dSP; 4923 U8 gimme; 4924 I32 discard; 4925 4926 if (PL_op->op_private & OPpLVAL_INTRO) 4927 return do_delete_local(); 4928 4929 gimme = GIMME_V; 4930 discard = (gimme == G_VOID) ? G_DISCARD : 0; 4931 4932 if (PL_op->op_private & (OPpSLICE|OPpKVSLICE)) { 4933 dMARK; dORIGMARK; 4934 HV * const hv = MUTABLE_HV(POPs); 4935 const U32 hvtype = SvTYPE(hv); 4936 int skip = 0; 4937 if (PL_op->op_private & OPpKVSLICE) { 4938 SSize_t items = SP - MARK; 4939 4940 MEXTEND(SP,items); 4941 while (items > 1) { 4942 *(MARK+items*2-1) = *(MARK+items); 4943 items--; 4944 } 4945 items = SP - MARK; 4946 SP += items; 4947 skip = 1; 4948 } 4949 if (hvtype == SVt_PVHV) { /* hash element */ 4950 while ((MARK += (1+skip)) <= SP) { 4951 SV * const sv = hv_delete_ent(hv, *(MARK-skip), discard, 0); 4952 *MARK = sv ? sv : &PL_sv_undef; 4953 } 4954 } 4955 else if (hvtype == SVt_PVAV) { /* array element */ 4956 if (PL_op->op_flags & OPf_SPECIAL) { 4957 while ((MARK += (1+skip)) <= SP) { 4958 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*(MARK-skip)), discard); 4959 *MARK = sv ? sv : &PL_sv_undef; 4960 } 4961 } 4962 } 4963 else 4964 DIE(aTHX_ "Not a HASH reference"); 4965 if (discard) 4966 SP = ORIGMARK; 4967 else if (gimme == G_SCALAR) { 4968 MARK = ORIGMARK; 4969 if (SP > MARK) 4970 *++MARK = *SP; 4971 else 4972 *++MARK = &PL_sv_undef; 4973 SP = MARK; 4974 } 4975 } 4976 else { 4977 SV *keysv = POPs; 4978 HV * const hv = MUTABLE_HV(POPs); 4979 SV *sv = NULL; 4980 if (SvTYPE(hv) == SVt_PVHV) 4981 sv = hv_delete_ent(hv, keysv, discard, 0); 4982 else if (SvTYPE(hv) == SVt_PVAV) { 4983 if (PL_op->op_flags & OPf_SPECIAL) 4984 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard); 4985 else 4986 DIE(aTHX_ "panic: avhv_delete no longer supported"); 4987 } 4988 else 4989 DIE(aTHX_ "Not a HASH reference"); 4990 if (!sv) 4991 sv = &PL_sv_undef; 4992 if (!discard) 4993 PUSHs(sv); 4994 } 4995 RETURN; 4996 } 4997 4998 PP(pp_exists) 4999 { 5000 dSP; 5001 SV *tmpsv; 5002 HV *hv; 5003 5004 if (UNLIKELY( PL_op->op_private & OPpEXISTS_SUB )) { 5005 GV *gv; 5006 SV * const sv = POPs; 5007 CV * const cv = sv_2cv(sv, &hv, &gv, 0); 5008 if (cv) 5009 RETPUSHYES; 5010 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv)) 5011 RETPUSHYES; 5012 RETPUSHNO; 5013 } 5014 tmpsv = POPs; 5015 hv = MUTABLE_HV(POPs); 5016 if (LIKELY( SvTYPE(hv) == SVt_PVHV )) { 5017 if (hv_exists_ent(hv, tmpsv, 0)) 5018 RETPUSHYES; 5019 } 5020 else if (SvTYPE(hv) == SVt_PVAV) { 5021 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */ 5022 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv))) 5023 RETPUSHYES; 5024 } 5025 } 5026 else { 5027 DIE(aTHX_ "Not a HASH reference"); 5028 } 5029 RETPUSHNO; 5030 } 5031 5032 PP(pp_hslice) 5033 { 5034 dSP; dMARK; dORIGMARK; 5035 HV * const hv = MUTABLE_HV(POPs); 5036 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET); 5037 const bool localizing = PL_op->op_private & OPpLVAL_INTRO; 5038 bool can_preserve = FALSE; 5039 5040 if (localizing) { 5041 MAGIC *mg; 5042 HV *stash; 5043 5044 if (SvCANEXISTDELETE(hv)) 5045 can_preserve = TRUE; 5046 } 5047 5048 while (++MARK <= SP) { 5049 SV * const keysv = *MARK; 5050 SV **svp; 5051 HE *he; 5052 bool preeminent = TRUE; 5053 5054 if (localizing && can_preserve) { 5055 /* If we can determine whether the element exist, 5056 * try to preserve the existenceness of a tied hash 5057 * element by using EXISTS and DELETE if possible. 5058 * Fallback to FETCH and STORE otherwise. */ 5059 preeminent = hv_exists_ent(hv, keysv, 0); 5060 } 5061 5062 he = hv_fetch_ent(hv, keysv, lval, 0); 5063 svp = he ? &HeVAL(he) : NULL; 5064 5065 if (lval) { 5066 if (!svp || !*svp || *svp == &PL_sv_undef) { 5067 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv)); 5068 } 5069 if (localizing) { 5070 if (HvNAME_get(hv) && isGV_or_RVCV(*svp)) 5071 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL)); 5072 else if (preeminent) 5073 save_helem_flags(hv, keysv, svp, 5074 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC); 5075 else 5076 SAVEHDELETE(hv, keysv); 5077 } 5078 } 5079 *MARK = svp && *svp ? *svp : &PL_sv_undef; 5080 } 5081 if (GIMME_V != G_ARRAY) { 5082 MARK = ORIGMARK; 5083 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef; 5084 SP = MARK; 5085 } 5086 RETURN; 5087 } 5088 5089 PP(pp_kvhslice) 5090 { 5091 dSP; dMARK; 5092 HV * const hv = MUTABLE_HV(POPs); 5093 I32 lval = (PL_op->op_flags & OPf_MOD); 5094 SSize_t items = SP - MARK; 5095 5096 if (PL_op->op_private & OPpMAYBE_LVSUB) { 5097 const I32 flags = is_lvalue_sub(); 5098 if (flags) { 5099 if (!(flags & OPpENTERSUB_INARGS)) 5100 /* diag_listed_as: Can't modify %s in %s */ 5101 Perl_croak(aTHX_ "Can't modify key/value hash slice in %s assignment", 5102 GIMME_V == G_ARRAY ? "list" : "scalar"); 5103 lval = flags; 5104 } 5105 } 5106 5107 MEXTEND(SP,items); 5108 while (items > 1) { 5109 *(MARK+items*2-1) = *(MARK+items); 5110 items--; 5111 } 5112 items = SP-MARK; 5113 SP += items; 5114 5115 while (++MARK <= SP) { 5116 SV * const keysv = *MARK; 5117 SV **svp; 5118 HE *he; 5119 5120 he = hv_fetch_ent(hv, keysv, lval, 0); 5121 svp = he ? &HeVAL(he) : NULL; 5122 5123 if (lval) { 5124 if (!svp || !*svp || *svp == &PL_sv_undef) { 5125 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv)); 5126 } 5127 *MARK = sv_mortalcopy(*MARK); 5128 } 5129 *++MARK = svp && *svp ? *svp : &PL_sv_undef; 5130 } 5131 if (GIMME_V != G_ARRAY) { 5132 MARK = SP - items*2; 5133 *++MARK = items > 0 ? *SP : &PL_sv_undef; 5134 SP = MARK; 5135 } 5136 RETURN; 5137 } 5138 5139 /* List operators. */ 5140 5141 PP(pp_list) 5142 { 5143 I32 markidx = POPMARK; 5144 if (GIMME_V != G_ARRAY) { 5145 /* don't initialize mark here, EXTEND() may move the stack */ 5146 SV **mark; 5147 dSP; 5148 EXTEND(SP, 1); /* in case no arguments, as in @empty */ 5149 mark = PL_stack_base + markidx; 5150 if (++MARK <= SP) 5151 *MARK = *SP; /* unwanted list, return last item */ 5152 else 5153 *MARK = &PL_sv_undef; 5154 SP = MARK; 5155 PUTBACK; 5156 } 5157 return NORMAL; 5158 } 5159 5160 PP(pp_lslice) 5161 { 5162 dSP; 5163 SV ** const lastrelem = PL_stack_sp; 5164 SV ** const lastlelem = PL_stack_base + POPMARK; 5165 SV ** const firstlelem = PL_stack_base + POPMARK + 1; 5166 SV ** const firstrelem = lastlelem + 1; 5167 const U8 mod = PL_op->op_flags & OPf_MOD; 5168 5169 const I32 max = lastrelem - lastlelem; 5170 SV **lelem; 5171 5172 if (GIMME_V != G_ARRAY) { 5173 if (lastlelem < firstlelem) { 5174 EXTEND(SP, 1); 5175 *firstlelem = &PL_sv_undef; 5176 } 5177 else { 5178 I32 ix = SvIV(*lastlelem); 5179 if (ix < 0) 5180 ix += max; 5181 if (ix < 0 || ix >= max) 5182 *firstlelem = &PL_sv_undef; 5183 else 5184 *firstlelem = firstrelem[ix]; 5185 } 5186 SP = firstlelem; 5187 RETURN; 5188 } 5189 5190 if (max == 0) { 5191 SP = firstlelem - 1; 5192 RETURN; 5193 } 5194 5195 for (lelem = firstlelem; lelem <= lastlelem; lelem++) { 5196 I32 ix = SvIV(*lelem); 5197 if (ix < 0) 5198 ix += max; 5199 if (ix < 0 || ix >= max) 5200 *lelem = &PL_sv_undef; 5201 else { 5202 if (!(*lelem = firstrelem[ix])) 5203 *lelem = &PL_sv_undef; 5204 else if (mod && SvPADTMP(*lelem)) { 5205 *lelem = firstrelem[ix] = sv_mortalcopy(*lelem); 5206 } 5207 } 5208 } 5209 SP = lastlelem; 5210 RETURN; 5211 } 5212 5213 PP(pp_anonlist) 5214 { 5215 dSP; dMARK; 5216 const I32 items = SP - MARK; 5217 SV * const av = MUTABLE_SV(av_make(items, MARK+1)); 5218 SP = MARK; 5219 mXPUSHs((PL_op->op_flags & OPf_SPECIAL) 5220 ? newRV_noinc(av) : av); 5221 RETURN; 5222 } 5223 5224 PP(pp_anonhash) 5225 { 5226 dSP; dMARK; dORIGMARK; 5227 HV* const hv = newHV(); 5228 SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL 5229 ? newRV_noinc(MUTABLE_SV(hv)) 5230 : MUTABLE_SV(hv) ); 5231 5232 while (MARK < SP) { 5233 SV * const key = 5234 (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK); 5235 SV *val; 5236 if (MARK < SP) 5237 { 5238 MARK++; 5239 SvGETMAGIC(*MARK); 5240 val = newSV(0); 5241 sv_setsv_nomg(val, *MARK); 5242 } 5243 else 5244 { 5245 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash"); 5246 val = newSV(0); 5247 } 5248 (void)hv_store_ent(hv,key,val,0); 5249 } 5250 SP = ORIGMARK; 5251 XPUSHs(retval); 5252 RETURN; 5253 } 5254 5255 PP(pp_splice) 5256 { 5257 dSP; dMARK; dORIGMARK; 5258 int num_args = (SP - MARK); 5259 AV *ary = MUTABLE_AV(*++MARK); 5260 SV **src; 5261 SV **dst; 5262 SSize_t i; 5263 SSize_t offset; 5264 SSize_t length; 5265 SSize_t newlen; 5266 SSize_t after; 5267 SSize_t diff; 5268 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied); 5269 5270 if (mg) { 5271 return Perl_tied_method(aTHX_ SV_CONST(SPLICE), mark - 1, MUTABLE_SV(ary), mg, 5272 GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK, 5273 sp - mark); 5274 } 5275 5276 if (SvREADONLY(ary)) 5277 Perl_croak_no_modify(); 5278 5279 SP++; 5280 5281 if (++MARK < SP) { 5282 offset = i = SvIV(*MARK); 5283 if (offset < 0) 5284 offset += AvFILLp(ary) + 1; 5285 if (offset < 0) 5286 DIE(aTHX_ PL_no_aelem, i); 5287 if (++MARK < SP) { 5288 length = SvIVx(*MARK++); 5289 if (length < 0) { 5290 length += AvFILLp(ary) - offset + 1; 5291 if (length < 0) 5292 length = 0; 5293 } 5294 } 5295 else 5296 length = AvMAX(ary) + 1; /* close enough to infinity */ 5297 } 5298 else { 5299 offset = 0; 5300 length = AvMAX(ary) + 1; 5301 } 5302 if (offset > AvFILLp(ary) + 1) { 5303 if (num_args > 2) 5304 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" ); 5305 offset = AvFILLp(ary) + 1; 5306 } 5307 after = AvFILLp(ary) + 1 - (offset + length); 5308 if (after < 0) { /* not that much array */ 5309 length += after; /* offset+length now in array */ 5310 after = 0; 5311 if (!AvALLOC(ary)) 5312 av_extend(ary, 0); 5313 } 5314 5315 /* At this point, MARK .. SP-1 is our new LIST */ 5316 5317 newlen = SP - MARK; 5318 diff = newlen - length; 5319 if (newlen && !AvREAL(ary) && AvREIFY(ary)) 5320 av_reify(ary); 5321 5322 /* make new elements SVs now: avoid problems if they're from the array */ 5323 for (dst = MARK, i = newlen; i; i--) { 5324 SV * const h = *dst; 5325 *dst++ = newSVsv(h); 5326 } 5327 5328 if (diff < 0) { /* shrinking the area */ 5329 SV **tmparyval = NULL; 5330 if (newlen) { 5331 Newx(tmparyval, newlen, SV*); /* so remember insertion */ 5332 Copy(MARK, tmparyval, newlen, SV*); 5333 } 5334 5335 MARK = ORIGMARK + 1; 5336 if (GIMME_V == G_ARRAY) { /* copy return vals to stack */ 5337 const bool real = cBOOL(AvREAL(ary)); 5338 MEXTEND(MARK, length); 5339 if (real) 5340 EXTEND_MORTAL(length); 5341 for (i = 0, dst = MARK; i < length; i++) { 5342 if ((*dst = AvARRAY(ary)[i+offset])) { 5343 if (real) 5344 sv_2mortal(*dst); /* free them eventually */ 5345 } 5346 else 5347 *dst = &PL_sv_undef; 5348 dst++; 5349 } 5350 MARK += length - 1; 5351 } 5352 else { 5353 *MARK = AvARRAY(ary)[offset+length-1]; 5354 if (AvREAL(ary)) { 5355 sv_2mortal(*MARK); 5356 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--) 5357 SvREFCNT_dec(*dst++); /* free them now */ 5358 } 5359 if (!*MARK) 5360 *MARK = &PL_sv_undef; 5361 } 5362 AvFILLp(ary) += diff; 5363 5364 /* pull up or down? */ 5365 5366 if (offset < after) { /* easier to pull up */ 5367 if (offset) { /* esp. if nothing to pull */ 5368 src = &AvARRAY(ary)[offset-1]; 5369 dst = src - diff; /* diff is negative */ 5370 for (i = offset; i > 0; i--) /* can't trust Copy */ 5371 *dst-- = *src--; 5372 } 5373 dst = AvARRAY(ary); 5374 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */ 5375 AvMAX(ary) += diff; 5376 } 5377 else { 5378 if (after) { /* anything to pull down? */ 5379 src = AvARRAY(ary) + offset + length; 5380 dst = src + diff; /* diff is negative */ 5381 Move(src, dst, after, SV*); 5382 } 5383 dst = &AvARRAY(ary)[AvFILLp(ary)+1]; 5384 /* avoid later double free */ 5385 } 5386 i = -diff; 5387 while (i) 5388 dst[--i] = NULL; 5389 5390 if (newlen) { 5391 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* ); 5392 Safefree(tmparyval); 5393 } 5394 } 5395 else { /* no, expanding (or same) */ 5396 SV** tmparyval = NULL; 5397 if (length) { 5398 Newx(tmparyval, length, SV*); /* so remember deletion */ 5399 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*); 5400 } 5401 5402 if (diff > 0) { /* expanding */ 5403 /* push up or down? */ 5404 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) { 5405 if (offset) { 5406 src = AvARRAY(ary); 5407 dst = src - diff; 5408 Move(src, dst, offset, SV*); 5409 } 5410 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */ 5411 AvMAX(ary) += diff; 5412 AvFILLp(ary) += diff; 5413 } 5414 else { 5415 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */ 5416 av_extend(ary, AvFILLp(ary) + diff); 5417 AvFILLp(ary) += diff; 5418 5419 if (after) { 5420 dst = AvARRAY(ary) + AvFILLp(ary); 5421 src = dst - diff; 5422 for (i = after; i; i--) { 5423 *dst-- = *src--; 5424 } 5425 } 5426 } 5427 } 5428 5429 if (newlen) { 5430 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* ); 5431 } 5432 5433 MARK = ORIGMARK + 1; 5434 if (GIMME_V == G_ARRAY) { /* copy return vals to stack */ 5435 if (length) { 5436 const bool real = cBOOL(AvREAL(ary)); 5437 if (real) 5438 EXTEND_MORTAL(length); 5439 for (i = 0, dst = MARK; i < length; i++) { 5440 if ((*dst = tmparyval[i])) { 5441 if (real) 5442 sv_2mortal(*dst); /* free them eventually */ 5443 } 5444 else *dst = &PL_sv_undef; 5445 dst++; 5446 } 5447 } 5448 MARK += length - 1; 5449 } 5450 else if (length--) { 5451 *MARK = tmparyval[length]; 5452 if (AvREAL(ary)) { 5453 sv_2mortal(*MARK); 5454 while (length-- > 0) 5455 SvREFCNT_dec(tmparyval[length]); 5456 } 5457 if (!*MARK) 5458 *MARK = &PL_sv_undef; 5459 } 5460 else 5461 *MARK = &PL_sv_undef; 5462 Safefree(tmparyval); 5463 } 5464 5465 if (SvMAGICAL(ary)) 5466 mg_set(MUTABLE_SV(ary)); 5467 5468 SP = MARK; 5469 RETURN; 5470 } 5471 5472 PP(pp_push) 5473 { 5474 dSP; dMARK; dORIGMARK; dTARGET; 5475 AV * const ary = MUTABLE_AV(*++MARK); 5476 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied); 5477 5478 if (mg) { 5479 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg); 5480 PUSHMARK(MARK); 5481 PUTBACK; 5482 ENTER_with_name("call_PUSH"); 5483 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED); 5484 LEAVE_with_name("call_PUSH"); 5485 /* SPAGAIN; not needed: SP is assigned to immediately below */ 5486 } 5487 else { 5488 /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we 5489 * only need to save locally, not on the save stack */ 5490 U16 old_delaymagic = PL_delaymagic; 5491 5492 if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify(); 5493 PL_delaymagic = DM_DELAY; 5494 for (++MARK; MARK <= SP; MARK++) { 5495 SV *sv; 5496 if (*MARK) SvGETMAGIC(*MARK); 5497 sv = newSV(0); 5498 if (*MARK) 5499 sv_setsv_nomg(sv, *MARK); 5500 av_store(ary, AvFILLp(ary)+1, sv); 5501 } 5502 if (PL_delaymagic & DM_ARRAY_ISA) 5503 mg_set(MUTABLE_SV(ary)); 5504 PL_delaymagic = old_delaymagic; 5505 } 5506 SP = ORIGMARK; 5507 if (OP_GIMME(PL_op, 0) != G_VOID) { 5508 PUSHi( AvFILL(ary) + 1 ); 5509 } 5510 RETURN; 5511 } 5512 5513 /* also used for: pp_pop()*/ 5514 PP(pp_shift) 5515 { 5516 dSP; 5517 AV * const av = PL_op->op_flags & OPf_SPECIAL 5518 ? MUTABLE_AV(GvAVn(PL_defgv)) : MUTABLE_AV(POPs); 5519 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av); 5520 EXTEND(SP, 1); 5521 assert (sv); 5522 if (AvREAL(av)) 5523 (void)sv_2mortal(sv); 5524 PUSHs(sv); 5525 RETURN; 5526 } 5527 5528 PP(pp_unshift) 5529 { 5530 dSP; dMARK; dORIGMARK; dTARGET; 5531 AV *ary = MUTABLE_AV(*++MARK); 5532 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied); 5533 5534 if (mg) { 5535 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg); 5536 PUSHMARK(MARK); 5537 PUTBACK; 5538 ENTER_with_name("call_UNSHIFT"); 5539 call_sv(SV_CONST(UNSHIFT),G_SCALAR|G_DISCARD|G_METHOD_NAMED); 5540 LEAVE_with_name("call_UNSHIFT"); 5541 /* SPAGAIN; not needed: SP is assigned to immediately below */ 5542 } 5543 else { 5544 /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we 5545 * only need to save locally, not on the save stack */ 5546 U16 old_delaymagic = PL_delaymagic; 5547 SSize_t i = 0; 5548 5549 av_unshift(ary, SP - MARK); 5550 PL_delaymagic = DM_DELAY; 5551 while (MARK < SP) { 5552 SV * const sv = newSVsv(*++MARK); 5553 (void)av_store(ary, i++, sv); 5554 } 5555 if (PL_delaymagic & DM_ARRAY_ISA) 5556 mg_set(MUTABLE_SV(ary)); 5557 PL_delaymagic = old_delaymagic; 5558 } 5559 SP = ORIGMARK; 5560 if (OP_GIMME(PL_op, 0) != G_VOID) { 5561 PUSHi( AvFILL(ary) + 1 ); 5562 } 5563 RETURN; 5564 } 5565 5566 PP(pp_reverse) 5567 { 5568 dSP; dMARK; 5569 5570 if (GIMME_V == G_ARRAY) { 5571 if (PL_op->op_private & OPpREVERSE_INPLACE) { 5572 AV *av; 5573 5574 /* See pp_sort() */ 5575 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV); 5576 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */ 5577 av = MUTABLE_AV((*SP)); 5578 /* In-place reversing only happens in void context for the array 5579 * assignment. We don't need to push anything on the stack. */ 5580 SP = MARK; 5581 5582 if (SvMAGICAL(av)) { 5583 SSize_t i, j; 5584 SV *tmp = sv_newmortal(); 5585 /* For SvCANEXISTDELETE */ 5586 HV *stash; 5587 const MAGIC *mg; 5588 bool can_preserve = SvCANEXISTDELETE(av); 5589 5590 for (i = 0, j = av_tindex(av); i < j; ++i, --j) { 5591 SV *begin, *end; 5592 5593 if (can_preserve) { 5594 if (!av_exists(av, i)) { 5595 if (av_exists(av, j)) { 5596 SV *sv = av_delete(av, j, 0); 5597 begin = *av_fetch(av, i, TRUE); 5598 sv_setsv_mg(begin, sv); 5599 } 5600 continue; 5601 } 5602 else if (!av_exists(av, j)) { 5603 SV *sv = av_delete(av, i, 0); 5604 end = *av_fetch(av, j, TRUE); 5605 sv_setsv_mg(end, sv); 5606 continue; 5607 } 5608 } 5609 5610 begin = *av_fetch(av, i, TRUE); 5611 end = *av_fetch(av, j, TRUE); 5612 sv_setsv(tmp, begin); 5613 sv_setsv_mg(begin, end); 5614 sv_setsv_mg(end, tmp); 5615 } 5616 } 5617 else { 5618 SV **begin = AvARRAY(av); 5619 5620 if (begin) { 5621 SV **end = begin + AvFILLp(av); 5622 5623 while (begin < end) { 5624 SV * const tmp = *begin; 5625 *begin++ = *end; 5626 *end-- = tmp; 5627 } 5628 } 5629 } 5630 } 5631 else { 5632 SV **oldsp = SP; 5633 MARK++; 5634 while (MARK < SP) { 5635 SV * const tmp = *MARK; 5636 *MARK++ = *SP; 5637 *SP-- = tmp; 5638 } 5639 /* safe as long as stack cannot get extended in the above */ 5640 SP = oldsp; 5641 } 5642 } 5643 else { 5644 char *up; 5645 dTARGET; 5646 STRLEN len; 5647 5648 SvUTF8_off(TARG); /* decontaminate */ 5649 if (SP - MARK > 1) { 5650 do_join(TARG, &PL_sv_no, MARK, SP); 5651 SP = MARK + 1; 5652 SETs(TARG); 5653 } else if (SP > MARK) { 5654 sv_setsv(TARG, *SP); 5655 SETs(TARG); 5656 } else { 5657 sv_setsv(TARG, DEFSV); 5658 XPUSHs(TARG); 5659 } 5660 5661 up = SvPV_force(TARG, len); 5662 if (len > 1) { 5663 char *down; 5664 if (DO_UTF8(TARG)) { /* first reverse each character */ 5665 U8* s = (U8*)SvPVX(TARG); 5666 const U8* send = (U8*)(s + len); 5667 while (s < send) { 5668 if (UTF8_IS_INVARIANT(*s)) { 5669 s++; 5670 continue; 5671 } 5672 else { 5673 if (!utf8_to_uvchr_buf(s, send, 0)) 5674 break; 5675 up = (char*)s; 5676 s += UTF8SKIP(s); 5677 down = (char*)(s - 1); 5678 /* reverse this character */ 5679 while (down > up) { 5680 const char tmp = *up; 5681 *up++ = *down; 5682 *down-- = tmp; 5683 } 5684 } 5685 } 5686 up = SvPVX(TARG); 5687 } 5688 down = SvPVX(TARG) + len - 1; 5689 while (down > up) { 5690 const char tmp = *up; 5691 *up++ = *down; 5692 *down-- = tmp; 5693 } 5694 (void)SvPOK_only_UTF8(TARG); 5695 } 5696 } 5697 RETURN; 5698 } 5699 5700 PP(pp_split) 5701 { 5702 dSP; dTARG; 5703 AV *ary = ( (PL_op->op_private & OPpSPLIT_ASSIGN) /* @a = split */ 5704 && (PL_op->op_flags & OPf_STACKED)) /* @{expr} = split */ 5705 ? (AV *)POPs : NULL; 5706 IV limit = POPi; /* note, negative is forever */ 5707 SV * const sv = POPs; 5708 STRLEN len; 5709 const char *s = SvPV_const(sv, len); 5710 const bool do_utf8 = DO_UTF8(sv); 5711 const bool in_uni_8_bit = IN_UNI_8_BIT; 5712 const char *strend = s + len; 5713 PMOP *pm = cPMOPx(PL_op); 5714 REGEXP *rx; 5715 SV *dstr; 5716 const char *m; 5717 SSize_t iters = 0; 5718 const STRLEN slen = do_utf8 5719 ? utf8_length((U8*)s, (U8*)strend) 5720 : (STRLEN)(strend - s); 5721 SSize_t maxiters = slen + 10; 5722 I32 trailing_empty = 0; 5723 const char *orig; 5724 const IV origlimit = limit; 5725 I32 realarray = 0; 5726 I32 base; 5727 const U8 gimme = GIMME_V; 5728 bool gimme_scalar; 5729 I32 oldsave = PL_savestack_ix; 5730 U32 make_mortal = SVs_TEMP; 5731 bool multiline = 0; 5732 MAGIC *mg = NULL; 5733 5734 rx = PM_GETRE(pm); 5735 5736 TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET && 5737 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE))); 5738 5739 /* handle @ary = split(...) optimisation */ 5740 if (PL_op->op_private & OPpSPLIT_ASSIGN) { 5741 if (!(PL_op->op_flags & OPf_STACKED)) { 5742 if (PL_op->op_private & OPpSPLIT_LEX) { 5743 if (PL_op->op_private & OPpLVAL_INTRO) 5744 SAVECLEARSV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)); 5745 ary = (AV *)PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff); 5746 } 5747 else { 5748 GV *gv = 5749 #ifdef USE_ITHREADS 5750 MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)); 5751 #else 5752 pm->op_pmreplrootu.op_pmtargetgv; 5753 #endif 5754 if (PL_op->op_private & OPpLVAL_INTRO) 5755 ary = save_ary(gv); 5756 else 5757 ary = GvAVn(gv); 5758 } 5759 /* skip anything pushed by OPpLVAL_INTRO above */ 5760 oldsave = PL_savestack_ix; 5761 } 5762 5763 realarray = 1; 5764 PUTBACK; 5765 av_extend(ary,0); 5766 (void)sv_2mortal(SvREFCNT_inc_simple_NN(sv)); 5767 av_clear(ary); 5768 SPAGAIN; 5769 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) { 5770 PUSHMARK(SP); 5771 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg)); 5772 } 5773 else { 5774 if (!AvREAL(ary)) { 5775 I32 i; 5776 AvREAL_on(ary); 5777 AvREIFY_off(ary); 5778 for (i = AvFILLp(ary); i >= 0; i--) 5779 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */ 5780 } 5781 /* temporarily switch stacks */ 5782 SAVESWITCHSTACK(PL_curstack, ary); 5783 make_mortal = 0; 5784 } 5785 } 5786 5787 base = SP - PL_stack_base; 5788 orig = s; 5789 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) { 5790 if (do_utf8) { 5791 while (s < strend && isSPACE_utf8_safe(s, strend)) 5792 s += UTF8SKIP(s); 5793 } 5794 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) { 5795 while (s < strend && isSPACE_LC(*s)) 5796 s++; 5797 } 5798 else if (in_uni_8_bit) { 5799 while (s < strend && isSPACE_L1(*s)) 5800 s++; 5801 } 5802 else { 5803 while (s < strend && isSPACE(*s)) 5804 s++; 5805 } 5806 } 5807 if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) { 5808 multiline = 1; 5809 } 5810 5811 gimme_scalar = gimme == G_SCALAR && !ary; 5812 5813 if (!limit) 5814 limit = maxiters + 2; 5815 if (RX_EXTFLAGS(rx) & RXf_WHITE) { 5816 while (--limit) { 5817 m = s; 5818 /* this one uses 'm' and is a negative test */ 5819 if (do_utf8) { 5820 while (m < strend && ! isSPACE_utf8_safe(m, strend) ) { 5821 const int t = UTF8SKIP(m); 5822 /* isSPACE_utf8_safe returns FALSE for malform utf8 */ 5823 if (strend - m < t) 5824 m = strend; 5825 else 5826 m += t; 5827 } 5828 } 5829 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) 5830 { 5831 while (m < strend && !isSPACE_LC(*m)) 5832 ++m; 5833 } 5834 else if (in_uni_8_bit) { 5835 while (m < strend && !isSPACE_L1(*m)) 5836 ++m; 5837 } else { 5838 while (m < strend && !isSPACE(*m)) 5839 ++m; 5840 } 5841 if (m >= strend) 5842 break; 5843 5844 if (gimme_scalar) { 5845 iters++; 5846 if (m-s == 0) 5847 trailing_empty++; 5848 else 5849 trailing_empty = 0; 5850 } else { 5851 dstr = newSVpvn_flags(s, m-s, 5852 (do_utf8 ? SVf_UTF8 : 0) | make_mortal); 5853 XPUSHs(dstr); 5854 } 5855 5856 /* skip the whitespace found last */ 5857 if (do_utf8) 5858 s = m + UTF8SKIP(m); 5859 else 5860 s = m + 1; 5861 5862 /* this one uses 's' and is a positive test */ 5863 if (do_utf8) { 5864 while (s < strend && isSPACE_utf8_safe(s, strend) ) 5865 s += UTF8SKIP(s); 5866 } 5867 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) 5868 { 5869 while (s < strend && isSPACE_LC(*s)) 5870 ++s; 5871 } 5872 else if (in_uni_8_bit) { 5873 while (s < strend && isSPACE_L1(*s)) 5874 ++s; 5875 } else { 5876 while (s < strend && isSPACE(*s)) 5877 ++s; 5878 } 5879 } 5880 } 5881 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) { 5882 while (--limit) { 5883 for (m = s; m < strend && *m != '\n'; m++) 5884 ; 5885 m++; 5886 if (m >= strend) 5887 break; 5888 5889 if (gimme_scalar) { 5890 iters++; 5891 if (m-s == 0) 5892 trailing_empty++; 5893 else 5894 trailing_empty = 0; 5895 } else { 5896 dstr = newSVpvn_flags(s, m-s, 5897 (do_utf8 ? SVf_UTF8 : 0) | make_mortal); 5898 XPUSHs(dstr); 5899 } 5900 s = m; 5901 } 5902 } 5903 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) { 5904 /* 5905 Pre-extend the stack, either the number of bytes or 5906 characters in the string or a limited amount, triggered by: 5907 5908 my ($x, $y) = split //, $str; 5909 or 5910 split //, $str, $i; 5911 */ 5912 if (!gimme_scalar) { 5913 const IV items = limit - 1; 5914 /* setting it to -1 will trigger a panic in EXTEND() */ 5915 const SSize_t sslen = slen > SSize_t_MAX ? -1 : (SSize_t)slen; 5916 if (items >=0 && items < sslen) 5917 EXTEND(SP, items); 5918 else 5919 EXTEND(SP, sslen); 5920 } 5921 5922 if (do_utf8) { 5923 while (--limit) { 5924 /* keep track of how many bytes we skip over */ 5925 m = s; 5926 s += UTF8SKIP(s); 5927 if (gimme_scalar) { 5928 iters++; 5929 if (s-m == 0) 5930 trailing_empty++; 5931 else 5932 trailing_empty = 0; 5933 } else { 5934 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal); 5935 5936 PUSHs(dstr); 5937 } 5938 5939 if (s >= strend) 5940 break; 5941 } 5942 } else { 5943 while (--limit) { 5944 if (gimme_scalar) { 5945 iters++; 5946 } else { 5947 dstr = newSVpvn(s, 1); 5948 5949 5950 if (make_mortal) 5951 sv_2mortal(dstr); 5952 5953 PUSHs(dstr); 5954 } 5955 5956 s++; 5957 5958 if (s >= strend) 5959 break; 5960 } 5961 } 5962 } 5963 else if (do_utf8 == (RX_UTF8(rx) != 0) && 5964 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx) 5965 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL) 5966 && !(RX_EXTFLAGS(rx) & RXf_IS_ANCHORED)) { 5967 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL); 5968 SV * const csv = CALLREG_INTUIT_STRING(rx); 5969 5970 len = RX_MINLENRET(rx); 5971 if (len == 1 && !RX_UTF8(rx) && !tail) { 5972 const char c = *SvPV_nolen_const(csv); 5973 while (--limit) { 5974 for (m = s; m < strend && *m != c; m++) 5975 ; 5976 if (m >= strend) 5977 break; 5978 if (gimme_scalar) { 5979 iters++; 5980 if (m-s == 0) 5981 trailing_empty++; 5982 else 5983 trailing_empty = 0; 5984 } else { 5985 dstr = newSVpvn_flags(s, m-s, 5986 (do_utf8 ? SVf_UTF8 : 0) | make_mortal); 5987 XPUSHs(dstr); 5988 } 5989 /* The rx->minlen is in characters but we want to step 5990 * s ahead by bytes. */ 5991 if (do_utf8) 5992 s = (char*)utf8_hop((U8*)m, len); 5993 else 5994 s = m + len; /* Fake \n at the end */ 5995 } 5996 } 5997 else { 5998 while (s < strend && --limit && 5999 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend, 6000 csv, multiline ? FBMrf_MULTILINE : 0)) ) 6001 { 6002 if (gimme_scalar) { 6003 iters++; 6004 if (m-s == 0) 6005 trailing_empty++; 6006 else 6007 trailing_empty = 0; 6008 } else { 6009 dstr = newSVpvn_flags(s, m-s, 6010 (do_utf8 ? SVf_UTF8 : 0) | make_mortal); 6011 XPUSHs(dstr); 6012 } 6013 /* The rx->minlen is in characters but we want to step 6014 * s ahead by bytes. */ 6015 if (do_utf8) 6016 s = (char*)utf8_hop((U8*)m, len); 6017 else 6018 s = m + len; /* Fake \n at the end */ 6019 } 6020 } 6021 } 6022 else { 6023 maxiters += slen * RX_NPARENS(rx); 6024 while (s < strend && --limit) 6025 { 6026 I32 rex_return; 6027 PUTBACK; 6028 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1, 6029 sv, NULL, 0); 6030 SPAGAIN; 6031 if (rex_return == 0) 6032 break; 6033 TAINT_IF(RX_MATCH_TAINTED(rx)); 6034 /* we never pass the REXEC_COPY_STR flag, so it should 6035 * never get copied */ 6036 assert(!RX_MATCH_COPIED(rx)); 6037 m = RX_OFFS(rx)[0].start + orig; 6038 6039 if (gimme_scalar) { 6040 iters++; 6041 if (m-s == 0) 6042 trailing_empty++; 6043 else 6044 trailing_empty = 0; 6045 } else { 6046 dstr = newSVpvn_flags(s, m-s, 6047 (do_utf8 ? SVf_UTF8 : 0) | make_mortal); 6048 XPUSHs(dstr); 6049 } 6050 if (RX_NPARENS(rx)) { 6051 I32 i; 6052 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) { 6053 s = RX_OFFS(rx)[i].start + orig; 6054 m = RX_OFFS(rx)[i].end + orig; 6055 6056 /* japhy (07/27/01) -- the (m && s) test doesn't catch 6057 parens that didn't match -- they should be set to 6058 undef, not the empty string */ 6059 if (gimme_scalar) { 6060 iters++; 6061 if (m-s == 0) 6062 trailing_empty++; 6063 else 6064 trailing_empty = 0; 6065 } else { 6066 if (m >= orig && s >= orig) { 6067 dstr = newSVpvn_flags(s, m-s, 6068 (do_utf8 ? SVf_UTF8 : 0) 6069 | make_mortal); 6070 } 6071 else 6072 dstr = &PL_sv_undef; /* undef, not "" */ 6073 XPUSHs(dstr); 6074 } 6075 6076 } 6077 } 6078 s = RX_OFFS(rx)[0].end + orig; 6079 } 6080 } 6081 6082 if (!gimme_scalar) { 6083 iters = (SP - PL_stack_base) - base; 6084 } 6085 if (iters > maxiters) 6086 DIE(aTHX_ "Split loop"); 6087 6088 /* keep field after final delim? */ 6089 if (s < strend || (iters && origlimit)) { 6090 if (!gimme_scalar) { 6091 const STRLEN l = strend - s; 6092 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal); 6093 XPUSHs(dstr); 6094 } 6095 iters++; 6096 } 6097 else if (!origlimit) { 6098 if (gimme_scalar) { 6099 iters -= trailing_empty; 6100 } else { 6101 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) { 6102 if (TOPs && !make_mortal) 6103 sv_2mortal(TOPs); 6104 *SP-- = NULL; 6105 iters--; 6106 } 6107 } 6108 } 6109 6110 PUTBACK; 6111 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */ 6112 SPAGAIN; 6113 if (realarray) { 6114 if (!mg) { 6115 if (SvSMAGICAL(ary)) { 6116 PUTBACK; 6117 mg_set(MUTABLE_SV(ary)); 6118 SPAGAIN; 6119 } 6120 if (gimme == G_ARRAY) { 6121 EXTEND(SP, iters); 6122 Copy(AvARRAY(ary), SP + 1, iters, SV*); 6123 SP += iters; 6124 RETURN; 6125 } 6126 } 6127 else { 6128 PUTBACK; 6129 ENTER_with_name("call_PUSH"); 6130 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED); 6131 LEAVE_with_name("call_PUSH"); 6132 SPAGAIN; 6133 if (gimme == G_ARRAY) { 6134 SSize_t i; 6135 /* EXTEND should not be needed - we just popped them */ 6136 EXTEND(SP, iters); 6137 for (i=0; i < iters; i++) { 6138 SV **svp = av_fetch(ary, i, FALSE); 6139 PUSHs((svp) ? *svp : &PL_sv_undef); 6140 } 6141 RETURN; 6142 } 6143 } 6144 } 6145 else { 6146 if (gimme == G_ARRAY) 6147 RETURN; 6148 } 6149 6150 GETTARGET; 6151 XPUSHi(iters); 6152 RETURN; 6153 } 6154 6155 PP(pp_once) 6156 { 6157 dSP; 6158 SV *const sv = PAD_SVl(PL_op->op_targ); 6159 6160 if (SvPADSTALE(sv)) { 6161 /* First time. */ 6162 SvPADSTALE_off(sv); 6163 RETURNOP(cLOGOP->op_other); 6164 } 6165 RETURNOP(cLOGOP->op_next); 6166 } 6167 6168 PP(pp_lock) 6169 { 6170 dSP; 6171 dTOPss; 6172 SV *retsv = sv; 6173 SvLOCK(sv); 6174 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV 6175 || SvTYPE(retsv) == SVt_PVCV) { 6176 retsv = refto(retsv); 6177 } 6178 SETs(retsv); 6179 RETURN; 6180 } 6181 6182 6183 /* used for: pp_padany(), pp_custom(); plus any system ops 6184 * that aren't implemented on a particular platform */ 6185 6186 PP(unimplemented_op) 6187 { 6188 const Optype op_type = PL_op->op_type; 6189 /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope 6190 with out of range op numbers - it only "special" cases op_custom. 6191 Secondly, as the three ops we "panic" on are padmy, mapstart and custom, 6192 if we get here for a custom op then that means that the custom op didn't 6193 have an implementation. Given that OP_NAME() looks up the custom op 6194 by its pp_addr, likely it will return NULL, unless someone (unhelpfully) 6195 registers &PL_unimplemented_op as the address of their custom op. 6196 NULL doesn't generate a useful error message. "custom" does. */ 6197 const char *const name = op_type >= OP_max 6198 ? "[out of range]" : PL_op_name[PL_op->op_type]; 6199 if(OP_IS_SOCKET(op_type)) 6200 DIE(aTHX_ PL_no_sock_func, name); 6201 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name, op_type); 6202 } 6203 6204 static void 6205 S_maybe_unwind_defav(pTHX) 6206 { 6207 if (CX_CUR()->cx_type & CXp_HASARGS) { 6208 PERL_CONTEXT *cx = CX_CUR(); 6209 6210 assert(CxHASARGS(cx)); 6211 cx_popsub_args(cx); 6212 cx->cx_type &= ~CXp_HASARGS; 6213 } 6214 } 6215 6216 /* For sorting out arguments passed to a &CORE:: subroutine */ 6217 PP(pp_coreargs) 6218 { 6219 dSP; 6220 int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0; 6221 int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0; 6222 AV * const at_ = GvAV(PL_defgv); 6223 SV **svp = at_ ? AvARRAY(at_) : NULL; 6224 I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0; 6225 I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0; 6226 bool seen_question = 0; 6227 const char *err = NULL; 6228 const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK; 6229 6230 /* Count how many args there are first, to get some idea how far to 6231 extend the stack. */ 6232 while (oa) { 6233 if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; } 6234 maxargs++; 6235 if (oa & OA_OPTIONAL) seen_question = 1; 6236 if (!seen_question) minargs++; 6237 oa >>= 4; 6238 } 6239 6240 if(numargs < minargs) err = "Not enough"; 6241 else if(numargs > maxargs) err = "Too many"; 6242 if (err) 6243 /* diag_listed_as: Too many arguments for %s */ 6244 Perl_croak(aTHX_ 6245 "%s arguments for %s", err, 6246 opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv) 6247 ); 6248 6249 /* Reset the stack pointer. Without this, we end up returning our own 6250 arguments in list context, in addition to the values we are supposed 6251 to return. nextstate usually does this on sub entry, but we need 6252 to run the next op with the caller's hints, so we cannot have a 6253 nextstate. */ 6254 SP = PL_stack_base + CX_CUR()->blk_oldsp; 6255 6256 if(!maxargs) RETURN; 6257 6258 /* We do this here, rather than with a separate pushmark op, as it has 6259 to come in between two things this function does (stack reset and 6260 arg pushing). This seems the easiest way to do it. */ 6261 if (pushmark) { 6262 PUTBACK; 6263 (void)Perl_pp_pushmark(aTHX); 6264 } 6265 6266 EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs); 6267 PUTBACK; /* The code below can die in various places. */ 6268 6269 oa = PL_opargs[opnum] >> OASHIFT; 6270 for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) { 6271 whicharg++; 6272 switch (oa & 7) { 6273 case OA_SCALAR: 6274 try_defsv: 6275 if (!numargs && defgv && whicharg == minargs + 1) { 6276 PUSHs(DEFSV); 6277 } 6278 else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL); 6279 break; 6280 case OA_LIST: 6281 while (numargs--) { 6282 PUSHs(svp && *svp ? *svp : &PL_sv_undef); 6283 svp++; 6284 } 6285 RETURN; 6286 case OA_AVREF: 6287 if (!numargs) { 6288 GV *gv; 6289 if (CvUNIQUE(find_runcv_where(FIND_RUNCV_level_eq,1,NULL))) 6290 gv = PL_argvgv; 6291 else { 6292 S_maybe_unwind_defav(aTHX); 6293 gv = PL_defgv; 6294 } 6295 PUSHs((SV *)GvAVn(gv)); 6296 break; 6297 } 6298 if (!svp || !*svp || !SvROK(*svp) 6299 || SvTYPE(SvRV(*svp)) != SVt_PVAV) 6300 DIE(aTHX_ 6301 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/ 6302 "Type of arg %d to &CORE::%s must be array reference", 6303 whicharg, PL_op_desc[opnum] 6304 ); 6305 PUSHs(SvRV(*svp)); 6306 break; 6307 case OA_HVREF: 6308 if (!svp || !*svp || !SvROK(*svp) 6309 || ( SvTYPE(SvRV(*svp)) != SVt_PVHV 6310 && ( opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN 6311 || SvTYPE(SvRV(*svp)) != SVt_PVAV ))) 6312 DIE(aTHX_ 6313 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/ 6314 "Type of arg %d to &CORE::%s must be hash%s reference", 6315 whicharg, PL_op_desc[opnum], 6316 opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN 6317 ? "" 6318 : " or array" 6319 ); 6320 PUSHs(SvRV(*svp)); 6321 break; 6322 case OA_FILEREF: 6323 if (!numargs) PUSHs(NULL); 6324 else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp))) 6325 /* no magic here, as the prototype will have added an extra 6326 refgen and we just want what was there before that */ 6327 PUSHs(SvRV(*svp)); 6328 else { 6329 const bool constr = PL_op->op_private & whicharg; 6330 PUSHs(S_rv2gv(aTHX_ 6331 svp && *svp ? *svp : &PL_sv_undef, 6332 constr, cBOOL(CopHINTS_get(PL_curcop) & HINT_STRICT_REFS), 6333 !constr 6334 )); 6335 } 6336 break; 6337 case OA_SCALARREF: 6338 if (!numargs) goto try_defsv; 6339 else { 6340 const bool wantscalar = 6341 PL_op->op_private & OPpCOREARGS_SCALARMOD; 6342 if (!svp || !*svp || !SvROK(*svp) 6343 /* We have to permit globrefs even for the \$ proto, as 6344 *foo is indistinguishable from ${\*foo}, and the proto- 6345 type permits the latter. */ 6346 || SvTYPE(SvRV(*svp)) > ( 6347 wantscalar ? SVt_PVLV 6348 : opnum == OP_LOCK || opnum == OP_UNDEF 6349 ? SVt_PVCV 6350 : SVt_PVHV 6351 ) 6352 ) 6353 DIE(aTHX_ 6354 "Type of arg %d to &CORE::%s must be %s", 6355 whicharg, PL_op_name[opnum], 6356 wantscalar 6357 ? "scalar reference" 6358 : opnum == OP_LOCK || opnum == OP_UNDEF 6359 ? "reference to one of [$@%&*]" 6360 : "reference to one of [$@%*]" 6361 ); 6362 PUSHs(SvRV(*svp)); 6363 if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv) { 6364 /* Undo @_ localisation, so that sub exit does not undo 6365 part of our undeffing. */ 6366 S_maybe_unwind_defav(aTHX); 6367 } 6368 } 6369 break; 6370 default: 6371 DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7)); 6372 } 6373 oa = oa >> 4; 6374 } 6375 6376 RETURN; 6377 } 6378 6379 /* Implement CORE::keys(),values(),each(). 6380 * 6381 * We won't know until run-time whether the arg is an array or hash, 6382 * so this op calls 6383 * 6384 * pp_keys/pp_values/pp_each 6385 * or 6386 * pp_akeys/pp_avalues/pp_aeach 6387 * 6388 * as appropriate (or whatever pp function actually implements the OP_FOO 6389 * functionality for each FOO). 6390 */ 6391 6392 PP(pp_avhvswitch) 6393 { 6394 dVAR; dSP; 6395 return PL_ppaddr[ 6396 (SvTYPE(TOPs) == SVt_PVAV ? OP_AEACH : OP_EACH) 6397 + (PL_op->op_private & OPpAVHVSWITCH_MASK) 6398 ](aTHX); 6399 } 6400 6401 PP(pp_runcv) 6402 { 6403 dSP; 6404 CV *cv; 6405 if (PL_op->op_private & OPpOFFBYONE) { 6406 cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL); 6407 } 6408 else cv = find_runcv(NULL); 6409 XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv))); 6410 RETURN; 6411 } 6412 6413 static void 6414 S_localise_aelem_lval(pTHX_ AV * const av, SV * const keysv, 6415 const bool can_preserve) 6416 { 6417 const SSize_t ix = SvIV(keysv); 6418 if (can_preserve ? av_exists(av, ix) : TRUE) { 6419 SV ** const svp = av_fetch(av, ix, 1); 6420 if (!svp || !*svp) 6421 Perl_croak(aTHX_ PL_no_aelem, ix); 6422 save_aelem(av, ix, svp); 6423 } 6424 else 6425 SAVEADELETE(av, ix); 6426 } 6427 6428 static void 6429 S_localise_helem_lval(pTHX_ HV * const hv, SV * const keysv, 6430 const bool can_preserve) 6431 { 6432 if (can_preserve ? hv_exists_ent(hv, keysv, 0) : TRUE) { 6433 HE * const he = hv_fetch_ent(hv, keysv, 1, 0); 6434 SV ** const svp = he ? &HeVAL(he) : NULL; 6435 if (!svp || !*svp) 6436 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(keysv)); 6437 save_helem_flags(hv, keysv, svp, 0); 6438 } 6439 else 6440 SAVEHDELETE(hv, keysv); 6441 } 6442 6443 static void 6444 S_localise_gv_slot(pTHX_ GV *gv, U8 type) 6445 { 6446 if (type == OPpLVREF_SV) { 6447 save_pushptrptr(gv, SvREFCNT_inc_simple(GvSV(gv)), SAVEt_GVSV); 6448 GvSV(gv) = 0; 6449 } 6450 else if (type == OPpLVREF_AV) 6451 /* XXX Inefficient, as it creates a new AV, which we are 6452 about to clobber. */ 6453 save_ary(gv); 6454 else { 6455 assert(type == OPpLVREF_HV); 6456 /* XXX Likewise inefficient. */ 6457 save_hash(gv); 6458 } 6459 } 6460 6461 6462 PP(pp_refassign) 6463 { 6464 dSP; 6465 SV * const key = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL; 6466 SV * const left = PL_op->op_flags & OPf_STACKED ? POPs : NULL; 6467 dTOPss; 6468 const char *bad = NULL; 6469 const U8 type = PL_op->op_private & OPpLVREF_TYPE; 6470 if (!SvROK(sv)) DIE(aTHX_ "Assigned value is not a reference"); 6471 switch (type) { 6472 case OPpLVREF_SV: 6473 if (SvTYPE(SvRV(sv)) > SVt_PVLV) 6474 bad = " SCALAR"; 6475 break; 6476 case OPpLVREF_AV: 6477 if (SvTYPE(SvRV(sv)) != SVt_PVAV) 6478 bad = "n ARRAY"; 6479 break; 6480 case OPpLVREF_HV: 6481 if (SvTYPE(SvRV(sv)) != SVt_PVHV) 6482 bad = " HASH"; 6483 break; 6484 case OPpLVREF_CV: 6485 if (SvTYPE(SvRV(sv)) != SVt_PVCV) 6486 bad = " CODE"; 6487 } 6488 if (bad) 6489 /* diag_listed_as: Assigned value is not %s reference */ 6490 DIE(aTHX_ "Assigned value is not a%s reference", bad); 6491 { 6492 MAGIC *mg; 6493 HV *stash; 6494 switch (left ? SvTYPE(left) : 0) { 6495 case 0: 6496 { 6497 SV * const old = PAD_SV(ARGTARG); 6498 PAD_SETSV(ARGTARG, SvREFCNT_inc_NN(SvRV(sv))); 6499 SvREFCNT_dec(old); 6500 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) 6501 == OPpLVAL_INTRO) 6502 SAVECLEARSV(PAD_SVl(ARGTARG)); 6503 break; 6504 } 6505 case SVt_PVGV: 6506 if (PL_op->op_private & OPpLVAL_INTRO) { 6507 S_localise_gv_slot(aTHX_ (GV *)left, type); 6508 } 6509 gv_setref(left, sv); 6510 SvSETMAGIC(left); 6511 break; 6512 case SVt_PVAV: 6513 assert(key); 6514 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) { 6515 S_localise_aelem_lval(aTHX_ (AV *)left, key, 6516 SvCANEXISTDELETE(left)); 6517 } 6518 av_store((AV *)left, SvIV(key), SvREFCNT_inc_simple_NN(SvRV(sv))); 6519 break; 6520 case SVt_PVHV: 6521 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) { 6522 assert(key); 6523 S_localise_helem_lval(aTHX_ (HV *)left, key, 6524 SvCANEXISTDELETE(left)); 6525 } 6526 (void)hv_store_ent((HV *)left, key, SvREFCNT_inc_simple_NN(SvRV(sv)), 0); 6527 } 6528 if (PL_op->op_flags & OPf_MOD) 6529 SETs(sv_2mortal(newSVsv(sv))); 6530 /* XXX else can weak references go stale before they are read, e.g., 6531 in leavesub? */ 6532 RETURN; 6533 } 6534 } 6535 6536 PP(pp_lvref) 6537 { 6538 dSP; 6539 SV * const ret = sv_2mortal(newSV_type(SVt_PVMG)); 6540 SV * const elem = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL; 6541 SV * const arg = PL_op->op_flags & OPf_STACKED ? POPs : NULL; 6542 MAGIC * const mg = sv_magicext(ret, arg, PERL_MAGIC_lvref, 6543 &PL_vtbl_lvref, (char *)elem, 6544 elem ? HEf_SVKEY : (I32)ARGTARG); 6545 mg->mg_private = PL_op->op_private; 6546 if (PL_op->op_private & OPpLVREF_ITER) 6547 mg->mg_flags |= MGf_PERSIST; 6548 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) { 6549 if (elem) { 6550 MAGIC *mg; 6551 HV *stash; 6552 assert(arg); 6553 { 6554 const bool can_preserve = SvCANEXISTDELETE(arg); 6555 if (SvTYPE(arg) == SVt_PVAV) 6556 S_localise_aelem_lval(aTHX_ (AV *)arg, elem, can_preserve); 6557 else 6558 S_localise_helem_lval(aTHX_ (HV *)arg, elem, can_preserve); 6559 } 6560 } 6561 else if (arg) { 6562 S_localise_gv_slot(aTHX_ (GV *)arg, 6563 PL_op->op_private & OPpLVREF_TYPE); 6564 } 6565 else if (!(PL_op->op_private & OPpPAD_STATE)) 6566 SAVECLEARSV(PAD_SVl(ARGTARG)); 6567 } 6568 XPUSHs(ret); 6569 RETURN; 6570 } 6571 6572 PP(pp_lvrefslice) 6573 { 6574 dSP; dMARK; 6575 AV * const av = (AV *)POPs; 6576 const bool localizing = PL_op->op_private & OPpLVAL_INTRO; 6577 bool can_preserve = FALSE; 6578 6579 if (UNLIKELY(localizing)) { 6580 MAGIC *mg; 6581 HV *stash; 6582 SV **svp; 6583 6584 can_preserve = SvCANEXISTDELETE(av); 6585 6586 if (SvTYPE(av) == SVt_PVAV) { 6587 SSize_t max = -1; 6588 6589 for (svp = MARK + 1; svp <= SP; svp++) { 6590 const SSize_t elem = SvIV(*svp); 6591 if (elem > max) 6592 max = elem; 6593 } 6594 if (max > AvMAX(av)) 6595 av_extend(av, max); 6596 } 6597 } 6598 6599 while (++MARK <= SP) { 6600 SV * const elemsv = *MARK; 6601 if (SvTYPE(av) == SVt_PVAV) 6602 S_localise_aelem_lval(aTHX_ av, elemsv, can_preserve); 6603 else 6604 S_localise_helem_lval(aTHX_ (HV *)av, elemsv, can_preserve); 6605 *MARK = sv_2mortal(newSV_type(SVt_PVMG)); 6606 sv_magic(*MARK,(SV *)av,PERL_MAGIC_lvref,(char *)elemsv,HEf_SVKEY); 6607 } 6608 RETURN; 6609 } 6610 6611 PP(pp_lvavref) 6612 { 6613 if (PL_op->op_flags & OPf_STACKED) 6614 Perl_pp_rv2av(aTHX); 6615 else 6616 Perl_pp_padav(aTHX); 6617 { 6618 dSP; 6619 dTOPss; 6620 SETs(0); /* special alias marker that aassign recognises */ 6621 XPUSHs(sv); 6622 RETURN; 6623 } 6624 } 6625 6626 PP(pp_anonconst) 6627 { 6628 dSP; 6629 dTOPss; 6630 SETs(sv_2mortal((SV *)newCONSTSUB(SvTYPE(CopSTASH(PL_curcop))==SVt_PVHV 6631 ? CopSTASH(PL_curcop) 6632 : NULL, 6633 NULL, SvREFCNT_inc_simple_NN(sv)))); 6634 RETURN; 6635 } 6636 6637 6638 /* process one subroutine argument - typically when the sub has a signature: 6639 * introduce PL_curpad[op_targ] and assign to it the value 6640 * for $: (OPf_STACKED ? *sp : $_[N]) 6641 * for @/%: @_[N..$#_] 6642 * 6643 * It's equivalent to 6644 * my $foo = $_[N]; 6645 * or 6646 * my $foo = (value-on-stack) 6647 * or 6648 * my @foo = @_[N..$#_] 6649 * etc 6650 */ 6651 6652 PP(pp_argelem) 6653 { 6654 dTARG; 6655 SV *val; 6656 SV ** padentry; 6657 OP *o = PL_op; 6658 AV *defav = GvAV(PL_defgv); /* @_ */ 6659 IV ix = PTR2IV(cUNOP_AUXo->op_aux); 6660 IV argc; 6661 6662 /* do 'my $var, @var or %var' action */ 6663 padentry = &(PAD_SVl(o->op_targ)); 6664 save_clearsv(padentry); 6665 targ = *padentry; 6666 6667 if ((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_SV) { 6668 if (o->op_flags & OPf_STACKED) { 6669 dSP; 6670 val = POPs; 6671 PUTBACK; 6672 } 6673 else { 6674 SV **svp; 6675 /* should already have been checked */ 6676 assert(ix >= 0); 6677 #if IVSIZE > PTRSIZE 6678 assert(ix <= SSize_t_MAX); 6679 #endif 6680 6681 svp = av_fetch(defav, ix, FALSE); 6682 val = svp ? *svp : &PL_sv_undef; 6683 } 6684 6685 /* $var = $val */ 6686 6687 /* cargo-culted from pp_sassign */ 6688 assert(TAINTING_get || !TAINT_get); 6689 if (UNLIKELY(TAINT_get) && !SvTAINTED(val)) 6690 TAINT_NOT; 6691 6692 SvSetMagicSV(targ, val); 6693 return o->op_next; 6694 } 6695 6696 /* must be AV or HV */ 6697 6698 assert(!(o->op_flags & OPf_STACKED)); 6699 argc = ((IV)AvFILL(defav) + 1) - ix; 6700 6701 /* This is a copy of the relevant parts of pp_aassign(). 6702 */ 6703 if ((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_AV) { 6704 IV i; 6705 6706 if (AvFILL((AV*)targ) > -1) { 6707 /* target should usually be empty. If we get get 6708 * here, someone's been doing some weird closure tricks. 6709 * Make a copy of all args before clearing the array, 6710 * to avoid the equivalent of @a = ($a[0]) prematurely freeing 6711 * elements. See similar code in pp_aassign. 6712 */ 6713 for (i = 0; i < argc; i++) { 6714 SV **svp = av_fetch(defav, ix + i, FALSE); 6715 SV *newsv = newSV(0); 6716 sv_setsv_flags(newsv, 6717 svp ? *svp : &PL_sv_undef, 6718 (SV_DO_COW_SVSETSV|SV_NOSTEAL)); 6719 if (!av_store(defav, ix + i, newsv)) 6720 SvREFCNT_dec_NN(newsv); 6721 } 6722 av_clear((AV*)targ); 6723 } 6724 6725 if (argc <= 0) 6726 return o->op_next; 6727 6728 av_extend((AV*)targ, argc); 6729 6730 i = 0; 6731 while (argc--) { 6732 SV *tmpsv; 6733 SV **svp = av_fetch(defav, ix + i, FALSE); 6734 SV *val = svp ? *svp : &PL_sv_undef; 6735 tmpsv = newSV(0); 6736 sv_setsv(tmpsv, val); 6737 av_store((AV*)targ, i++, tmpsv); 6738 TAINT_NOT; 6739 } 6740 6741 } 6742 else { 6743 IV i; 6744 6745 assert((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_HV); 6746 6747 if (SvRMAGICAL(targ) || HvUSEDKEYS((HV*)targ)) { 6748 /* see "target should usually be empty" comment above */ 6749 for (i = 0; i < argc; i++) { 6750 SV **svp = av_fetch(defav, ix + i, FALSE); 6751 SV *newsv = newSV(0); 6752 sv_setsv_flags(newsv, 6753 svp ? *svp : &PL_sv_undef, 6754 (SV_DO_COW_SVSETSV|SV_NOSTEAL)); 6755 if (!av_store(defav, ix + i, newsv)) 6756 SvREFCNT_dec_NN(newsv); 6757 } 6758 hv_clear((HV*)targ); 6759 } 6760 6761 if (argc <= 0) 6762 return o->op_next; 6763 assert(argc % 2 == 0); 6764 6765 i = 0; 6766 while (argc) { 6767 SV *tmpsv; 6768 SV **svp; 6769 SV *key; 6770 SV *val; 6771 6772 svp = av_fetch(defav, ix + i++, FALSE); 6773 key = svp ? *svp : &PL_sv_undef; 6774 svp = av_fetch(defav, ix + i++, FALSE); 6775 val = svp ? *svp : &PL_sv_undef; 6776 6777 argc -= 2; 6778 if (UNLIKELY(SvGMAGICAL(key))) 6779 key = sv_mortalcopy(key); 6780 tmpsv = newSV(0); 6781 sv_setsv(tmpsv, val); 6782 hv_store_ent((HV*)targ, key, tmpsv, 0); 6783 TAINT_NOT; 6784 } 6785 } 6786 6787 return o->op_next; 6788 } 6789 6790 /* Handle a default value for one subroutine argument (typically as part 6791 * of a subroutine signature). 6792 * It's equivalent to 6793 * @_ > op_targ ? $_[op_targ] : result_of(op_other) 6794 * 6795 * Intended to be used where op_next is an OP_ARGELEM 6796 * 6797 * We abuse the op_targ field slightly: it's an index into @_ rather than 6798 * into PL_curpad. 6799 */ 6800 6801 PP(pp_argdefelem) 6802 { 6803 OP * const o = PL_op; 6804 AV *defav = GvAV(PL_defgv); /* @_ */ 6805 IV ix = (IV)o->op_targ; 6806 6807 assert(ix >= 0); 6808 #if IVSIZE > PTRSIZE 6809 assert(ix <= SSize_t_MAX); 6810 #endif 6811 6812 if (AvFILL(defav) >= ix) { 6813 dSP; 6814 SV **svp = av_fetch(defav, ix, FALSE); 6815 SV *val = svp ? *svp : &PL_sv_undef; 6816 XPUSHs(val); 6817 RETURN; 6818 } 6819 return cLOGOPo->op_other; 6820 } 6821 6822 6823 static SV * 6824 S_find_runcv_name(void) 6825 { 6826 dTHX; 6827 CV *cv; 6828 GV *gv; 6829 SV *sv; 6830 6831 cv = find_runcv(0); 6832 if (!cv) 6833 return &PL_sv_no; 6834 6835 gv = CvGV(cv); 6836 if (!gv) 6837 return &PL_sv_no; 6838 6839 sv = sv_2mortal(newSV(0)); 6840 gv_fullname4(sv, gv, NULL, TRUE); 6841 return sv; 6842 } 6843 6844 /* Check a a subs arguments - i.e. that it has the correct number of args 6845 * (and anything else we might think of in future). Typically used with 6846 * signatured subs. 6847 */ 6848 6849 PP(pp_argcheck) 6850 { 6851 OP * const o = PL_op; 6852 UNOP_AUX_item *aux = cUNOP_AUXo->op_aux; 6853 IV params = aux[0].iv; 6854 IV opt_params = aux[1].iv; 6855 char slurpy = (char)(aux[2].iv); 6856 AV *defav = GvAV(PL_defgv); /* @_ */ 6857 IV argc; 6858 bool too_few; 6859 6860 assert(!SvMAGICAL(defav)); 6861 argc = (AvFILLp(defav) + 1); 6862 too_few = (argc < (params - opt_params)); 6863 6864 if (UNLIKELY(too_few || (!slurpy && argc > params))) 6865 /* diag_listed_as: Too few arguments for subroutine '%s' */ 6866 /* diag_listed_as: Too many arguments for subroutine '%s' */ 6867 Perl_croak_caller("Too %s arguments for subroutine '%" SVf "'", 6868 too_few ? "few" : "many", S_find_runcv_name()); 6869 6870 if (UNLIKELY(slurpy == '%' && argc > params && (argc - params) % 2)) 6871 /* diag_listed_as: Odd name/value argument for subroutine '%s' */ 6872 Perl_croak_caller("Odd name/value argument for subroutine '%" SVf "'", 6873 S_find_runcv_name()); 6874 6875 return NORMAL; 6876 } 6877 6878 /* 6879 * ex: set ts=8 sts=4 sw=4 et: 6880 */ 6881