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