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