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