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