pp.c

   1 /*    pp.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
   4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  * 'It's a big house this, and very peculiar.  Always a bit more
  13  *  to discover, and no knowing what you'll find round a corner.
  14  *  And Elves, sir!'                            --Samwise Gamgee
  15  *
  16  *     [p.225 of _The Lord of the Rings_, II/i: "Many Meetings"]
  17  */
  18
  19 /* This file contains general pp ("push/pop") functions that execute the
  20  * opcodes that make up a perl program. A typical pp function expects to
  21  * find its arguments on the stack, and usually pushes its results onto
  22  * the stack, hence the 'pp' terminology. Each OP structure contains
  23  * a pointer to the relevant pp_foo() function.
  24  */
  25
  26 #include "EXTERN.h"
  27 #define PERL_IN_PP_C
  28 #include "perl.h"
  29 #include "keywords.h"
  30
  31 #include "reentr.h"
  32 #include "regcharclass.h"
  33
  34 /* XXX I can't imagine anyone who doesn't have this actually _needs_
  35    it, since pid_t is an integral type.
  36    --AD  2/20/1998
  37 */
  38 #ifdef NEED_GETPID_PROTO
  39 extern Pid_t getpid (void);
  40 #endif
  41
  42 static const STRLEN small_mu_len = sizeof(GREEK_SMALL_LETTER_MU_UTF8) - 1;
  43 static const STRLEN capital_iota_len = sizeof(GREEK_CAPITAL_LETTER_IOTA_UTF8) - 1;
  44
  45 /* variations on pp_null */
  46
  47 PP(pp_stub)
  48 {
  49     dSP;
  50     if (GIMME_V == G_SCALAR)
  51         XPUSHs(&PL_sv_undef);
  52     RETURN;
  53 }
  54
  55 /* Pushy stuff. */
  56
  57
  58
  59 PP(pp_padcv)
  60 {
  61     dSP; dTARGET;
  62     assert(SvTYPE(TARG) == SVt_PVCV);
  63     XPUSHs(TARG);
  64     RETURN;
  65 }
  66
  67 PP(pp_introcv)
  68 {
  69     dTARGET;
  70     SvPADSTALE_off(TARG);
  71     return NORMAL;
  72 }
  73
  74 PP(pp_clonecv)
  75 {
  76     dTARGET;
  77     CV * const protocv = PadnamePROTOCV(
  78         PadlistNAMESARRAY(CvPADLIST(find_runcv(NULL)))[ARGTARG]
  79     );
  80     assert(SvTYPE(TARG) == SVt_PVCV);
  81     assert(protocv);
  82     if (CvISXSUB(protocv)) { /* constant */
  83         /* XXX Should we clone it here? */
  84         /* If this changes to use SAVECLEARSV, we can move the SAVECLEARSV
  85            to introcv and remove the SvPADSTALE_off. */
  86         SAVEPADSVANDMORTALIZE(ARGTARG);
  87         PAD_SVl(ARGTARG) = SvREFCNT_inc_simple_NN(protocv);
  88     }
  89     else {
  90         if (CvROOT(protocv)) {
  91             assert(CvCLONE(protocv));
  92             assert(!CvCLONED(protocv));
  93         }
  94         cv_clone_into(protocv,(CV *)TARG);
  95         SAVECLEARSV(PAD_SVl(ARGTARG));
  96     }
  97     return NORMAL;
  98 }
  99
 100 /* Translations. */
 101
 102 /* In some cases this function inspects PL_op.  If this function is called
 103    for new op types, more bool parameters may need to be added in place of
 104    the checks.
 105
 106    When noinit is true, the absence of a gv will cause a retval of undef.
 107    This is unrelated to the cv-to-gv assignment case.
 108 */
 109
 110 static SV *
 111 S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict,
 112               const bool noinit)
 113 {
 114     if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv);
 115     if (SvROK(sv)) {
 116         if (SvAMAGIC(sv)) {
 117             sv = amagic_deref_call(sv, to_gv_amg);
 118         }
 119       wasref:
 120         sv = SvRV(sv);
 121         if (SvTYPE(sv) == SVt_PVIO) {
 122             GV * const gv = MUTABLE_GV(sv_newmortal());
 123             gv_init(gv, 0, "__ANONIO__", 10, 0);
 124             GvIOp(gv) = MUTABLE_IO(sv);
 125             SvREFCNT_inc_void_NN(sv);
 126             sv = MUTABLE_SV(gv);
 127         }
 128         else if (!isGV_with_GP(sv)) {
 129             Perl_die(aTHX_ "Not a GLOB reference");
 130         }
 131     }
 132     else {
 133         if (!isGV_with_GP(sv)) {
 134             if (!SvOK(sv)) {
 135                 /* If this is a 'my' scalar and flag is set then vivify
 136                  * NI-S 1999/05/07
 137                  */
 138                 if (vivify_sv && sv != &PL_sv_undef) {
 139                     GV *gv;
 140                     if (SvREADONLY(sv))
 141                         Perl_croak_no_modify();
 142                     if (cUNOP->op_targ) {
 143                         SV * const namesv = PAD_SV(cUNOP->op_targ);
 144                         HV *stash = CopSTASH(PL_curcop);
 145                         if (SvTYPE(stash) != SVt_PVHV) stash = NULL;
 146                         gv = MUTABLE_GV(newSV(0));
 147                         gv_init_sv(gv, stash, namesv, 0);
 148                     }
 149                     else {
 150                         const char * const name = CopSTASHPV(PL_curcop);
 151                         gv = newGVgen_flags(name,
 152                                 HvNAMEUTF8(CopSTASH(PL_curcop)) ? SVf_UTF8 : 0 );
 153                         SvREFCNT_inc_simple_void_NN(gv);
 154                     }
 155                     prepare_SV_for_RV(sv);
 156                     SvRV_set(sv, MUTABLE_SV(gv));
 157                     SvROK_on(sv);
 158                     SvSETMAGIC(sv);
 159                     goto wasref;
 160                 }
 161                 if (PL_op->op_flags & OPf_REF || strict) {
 162                     Perl_die(aTHX_ PL_no_usym, "a symbol");
 163                 }
 164                 if (ckWARN(WARN_UNINITIALIZED))
 165                     report_uninit(sv);
 166                 return &PL_sv_undef;
 167             }
 168             if (noinit)
 169             {
 170                 if (!(sv = MUTABLE_SV(gv_fetchsv_nomg(
 171                            sv, GV_ADDMG, SVt_PVGV
 172                    ))))
 173                     return &PL_sv_undef;
 174             }
 175             else {
 176                 if (strict) {
 177                     Perl_die(aTHX_
 178                              PL_no_symref_sv,
 179                              sv,
 180                              (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""),
 181                              "a symbol"
 182                              );
 183                 }
 184                 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
 185                     == OPpDONT_INIT_GV) {
 186                     /* We are the target of a coderef assignment.  Return
 187                        the scalar unchanged, and let pp_sasssign deal with
 188                        things.  */
 189                     return sv;
 190                 }
 191                 sv = MUTABLE_SV(gv_fetchsv_nomg(sv, GV_ADD, SVt_PVGV));
 192             }
 193             /* FAKE globs in the symbol table cause weird bugs (#77810) */
 194             SvFAKE_off(sv);
 195         }
 196     }
 197     if (SvFAKE(sv) && !(PL_op->op_private & OPpALLOW_FAKE)) {
 198         SV *newsv = sv_newmortal();
 199         sv_setsv_flags(newsv, sv, 0);
 200         SvFAKE_off(newsv);
 201         sv = newsv;
 202     }
 203     return sv;
 204 }
 205
 206 PP(pp_rv2gv)
 207 {
 208     dSP; dTOPss;
 209
 210     sv = S_rv2gv(aTHX_
 211           sv, PL_op->op_private & OPpDEREF,
 212           PL_op->op_private & HINT_STRICT_REFS,
 213           ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD))
 214              || PL_op->op_type == OP_READLINE
 215          );
 216     if (PL_op->op_private & OPpLVAL_INTRO)
 217         save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
 218     SETs(sv);
 219     RETURN;
 220 }
 221
 222 /* Helper function for pp_rv2sv and pp_rv2av  */
 223 GV *
 224 Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
 225                 const svtype type, SV ***spp)
 226 {
 227     GV *gv;
 228
 229     PERL_ARGS_ASSERT_SOFTREF2XV;
 230
 231     if (PL_op->op_private & HINT_STRICT_REFS) {
 232         if (SvOK(sv))
 233             Perl_die(aTHX_ PL_no_symref_sv, sv,
 234                      (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
 235         else
 236             Perl_die(aTHX_ PL_no_usym, what);
 237     }
 238     if (!SvOK(sv)) {
 239         if (
 240           PL_op->op_flags & OPf_REF
 241         )
 242             Perl_die(aTHX_ PL_no_usym, what);
 243         if (ckWARN(WARN_UNINITIALIZED))
 244             report_uninit(sv);
 245         if (type != SVt_PV && GIMME_V == G_ARRAY) {
 246             (*spp)--;
 247             return NULL;
 248         }
 249         **spp = &PL_sv_undef;
 250         return NULL;
 251     }
 252     if ((PL_op->op_flags & OPf_SPECIAL) &&
 253         !(PL_op->op_flags & OPf_MOD))
 254         {
 255             if (!(gv = gv_fetchsv_nomg(sv, GV_ADDMG, type)))
 256                 {
 257                     **spp = &PL_sv_undef;
 258                     return NULL;
 259                 }
 260         }
 261     else {
 262         gv = gv_fetchsv_nomg(sv, GV_ADD, type);
 263     }
 264     return gv;
 265 }
 266
 267 PP(pp_rv2sv)
 268 {
 269     dSP; dTOPss;
 270     GV *gv = NULL;
 271
 272     SvGETMAGIC(sv);
 273     if (SvROK(sv)) {
 274         if (SvAMAGIC(sv)) {
 275             sv = amagic_deref_call(sv, to_sv_amg);
 276         }
 277
 278         sv = SvRV(sv);
 279         if (SvTYPE(sv) >= SVt_PVAV)
 280             DIE(aTHX_ "Not a SCALAR reference");
 281     }
 282     else {
 283         gv = MUTABLE_GV(sv);
 284
 285         if (!isGV_with_GP(gv)) {
 286             gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
 287             if (!gv)
 288                 RETURN;
 289         }
 290         sv = GvSVn(gv);
 291     }
 292     if (PL_op->op_flags & OPf_MOD) {
 293         if (PL_op->op_private & OPpLVAL_INTRO) {
 294             if (cUNOP->op_first->op_type == OP_NULL)
 295                 sv = save_scalar(MUTABLE_GV(TOPs));
 296             else if (gv)
 297                 sv = save_scalar(gv);
 298             else
 299                 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
 300         }
 301         else if (PL_op->op_private & OPpDEREF)
 302             sv = vivify_ref(sv, PL_op->op_private & OPpDEREF);
 303     }
 304     SPAGAIN; /* in case chasing soft refs reallocated the stack */
 305     SETs(sv);
 306     RETURN;
 307 }
 308
 309 PP(pp_av2arylen)
 310 {
 311     dSP;
 312     AV * const av = MUTABLE_AV(TOPs);
 313     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
 314     if (lvalue) {
 315         SV ** const svp = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
 316         if (!*svp) {
 317             *svp = newSV_type(SVt_PVMG);
 318             sv_magic(*svp, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
 319         }
 320         SETs(*svp);
 321     } else {
 322         SETs(sv_2mortal(newSViv(AvFILL(MUTABLE_AV(av)))));
 323     }
 324     RETURN;
 325 }
 326
 327 PP(pp_pos)
 328 {
 329     dSP; dTOPss;
 330
 331     if (PL_op->op_flags & OPf_MOD || LVRET) {
 332         SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));/* Not TARG RT#67838 */
 333         sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
 334         LvTYPE(ret) = '.';
 335         LvTARG(ret) = SvREFCNT_inc_simple(sv);
 336         SETs(ret);    /* no SvSETMAGIC */
 337     }
 338     else {
 339             const MAGIC * const mg = mg_find_mglob(sv);
 340             if (mg && mg->mg_len != -1) {
 341                 STRLEN i = mg->mg_len;
 342                 if (PL_op->op_private & OPpTRUEBOOL)
 343                     SETs(i ? &PL_sv_yes : &PL_sv_zero);
 344                 else {
 345                     dTARGET;
 346                     if (mg->mg_flags & MGf_BYTES && DO_UTF8(sv))
 347                         i = sv_pos_b2u_flags(sv, i, SV_GMAGIC|SV_CONST_RETURN);
 348                     SETu(i);
 349                 }
 350                 return NORMAL;
 351             }
 352             SETs(&PL_sv_undef);
 353     }
 354     return NORMAL;
 355 }
 356
 357 PP(pp_rv2cv)
 358 {
 359     dSP;
 360     GV *gv;
 361     HV *stash_unused;
 362     const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
 363         ? GV_ADDMG
 364         : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT))
 365                                                     == OPpMAY_RETURN_CONSTANT)
 366             ? GV_ADD|GV_NOEXPAND
 367             : GV_ADD;
 368     /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
 369     /* (But not in defined().) */
 370
 371     CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
 372     if (cv) NOOP;
 373     else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
 374         cv = SvTYPE(SvRV(gv)) == SVt_PVCV
 375             ? MUTABLE_CV(SvRV(gv))
 376             : MUTABLE_CV(gv);
 377     }
 378     else
 379         cv = MUTABLE_CV(&PL_sv_undef);
 380     SETs(MUTABLE_SV(cv));
 381     return NORMAL;
 382 }
 383
 384 PP(pp_prototype)
 385 {
 386     dSP;
 387     CV *cv;
 388     HV *stash;
 389     GV *gv;
 390     SV *ret = &PL_sv_undef;
 391
 392     if (SvGMAGICAL(TOPs)) SETs(sv_mortalcopy(TOPs));
 393     if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
 394         const char * s = SvPVX_const(TOPs);
 395         if (strnEQ(s, "CORE::", 6)) {
 396             const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
 397             if (!code)
 398                 DIE(aTHX_ "Can't find an opnumber for \"%" UTF8f "\"",
 399                    UTF8fARG(SvFLAGS(TOPs) & SVf_UTF8, SvCUR(TOPs)-6, s+6));
 400             {
 401                 SV * const sv = core_prototype(NULL, s + 6, code, NULL);
 402                 if (sv) ret = sv;
 403             }
 404             goto set;
 405         }
 406     }
 407     cv = sv_2cv(TOPs, &stash, &gv, 0);
 408     if (cv && SvPOK(cv))
 409         ret = newSVpvn_flags(
 410             CvPROTO(cv), CvPROTOLEN(cv), SVs_TEMP | SvUTF8(cv)
 411         );
 412   set:
 413     SETs(ret);
 414     RETURN;
 415 }
 416
 417 PP(pp_anoncode)
 418 {
 419     dSP;
 420     CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
 421     if (CvCLONE(cv))
 422         cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
 423     EXTEND(SP,1);
 424     PUSHs(MUTABLE_SV(cv));
 425     RETURN;
 426 }
 427
 428 PP(pp_srefgen)
 429 {
 430     dSP;
 431     *SP = refto(*SP);
 432     return NORMAL;
 433 }
 434
 435 PP(pp_refgen)
 436 {
 437     dSP; dMARK;
 438     if (GIMME_V != G_ARRAY) {
 439         if (++MARK <= SP)
 440             *MARK = *SP;
 441         else
 442         {
 443             MEXTEND(SP, 1);
 444             *MARK = &PL_sv_undef;
 445         }
 446         *MARK = refto(*MARK);
 447         SP = MARK;
 448         RETURN;
 449     }
 450     EXTEND_MORTAL(SP - MARK);
 451     while (++MARK <= SP)
 452         *MARK = refto(*MARK);
 453     RETURN;
 454 }
 455
 456 STATIC SV*
 457 S_refto(pTHX_ SV *sv)
 458 {
 459     SV* rv;
 460
 461     PERL_ARGS_ASSERT_REFTO;
 462
 463     if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
 464         if (LvTARGLEN(sv))
 465             vivify_defelem(sv);
 466         if (!(sv = LvTARG(sv)))
 467             sv = &PL_sv_undef;
 468         else
 469             SvREFCNT_inc_void_NN(sv);
 470     }
 471     else if (SvTYPE(sv) == SVt_PVAV) {
 472         if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
 473             av_reify(MUTABLE_AV(sv));
 474         SvTEMP_off(sv);
 475         SvREFCNT_inc_void_NN(sv);
 476     }
 477     else if (SvPADTMP(sv)) {
 478         sv = newSVsv(sv);
 479     }
 480     else {
 481         SvTEMP_off(sv);
 482         SvREFCNT_inc_void_NN(sv);
 483     }
 484     rv = sv_newmortal();
 485     sv_upgrade(rv, SVt_IV);
 486     SvRV_set(rv, sv);
 487     SvROK_on(rv);
 488     return rv;
 489 }
 490
 491 PP(pp_ref)
 492 {
 493     dSP;
 494     SV * const sv = TOPs;
 495
 496     SvGETMAGIC(sv);
 497     if (!SvROK(sv)) {
 498         SETs(&PL_sv_no);
 499         return NORMAL;
 500     }
 501
 502     /* op is in boolean context? */
 503     if (   (PL_op->op_private & OPpTRUEBOOL)
 504         || (   (PL_op->op_private & OPpMAYBE_TRUEBOOL)
 505             && block_gimme() == G_VOID))
 506     {
 507         /* refs are always true - unless it's to an object blessed into a
 508          * class with a false name, i.e. "0". So we have to check for
 509          * that remote possibility. The following is is basically an
 510          * unrolled SvTRUE(sv_reftype(rv)) */
 511         SV * const rv = SvRV(sv);
 512         if (SvOBJECT(rv)) {
 513             HV *stash = SvSTASH(rv);
 514             HEK *hek = HvNAME_HEK(stash);
 515             if (hek) {
 516                 I32 len = HEK_LEN(hek);
 517                 /* bail out and do it the hard way? */
 518                 if (UNLIKELY(
 519                        len == HEf_SVKEY
 520                     || (len == 1 && HEK_KEY(hek)[0] == '0')
 521                 ))
 522                     goto do_sv_ref;
 523             }
 524         }
 525         SETs(&PL_sv_yes);
 526         return NORMAL;
 527     }
 528
 529   do_sv_ref:
 530     {
 531         dTARGET;
 532         SETs(TARG);
 533         sv_ref(TARG, SvRV(sv), TRUE);
 534         SvSETMAGIC(TARG);
 535         return NORMAL;
 536     }
 537
 538 }
 539
 540
 541 PP(pp_bless)
 542 {
 543     dSP;
 544     HV *stash;
 545
 546     if (MAXARG == 1)
 547     {
 548       curstash:
 549         stash = CopSTASH(PL_curcop);
 550         if (SvTYPE(stash) != SVt_PVHV)
 551             Perl_croak(aTHX_ "Attempt to bless into a freed package");
 552     }
 553     else {
 554         SV * const ssv = POPs;
 555         STRLEN len;
 556         const char *ptr;
 557
 558         if (!ssv) goto curstash;
 559         SvGETMAGIC(ssv);
 560         if (SvROK(ssv)) {
 561           if (!SvAMAGIC(ssv)) {
 562            frog:
 563             Perl_croak(aTHX_ "Attempt to bless into a reference");
 564           }
 565           /* SvAMAGIC is on here, but it only means potentially overloaded,
 566              so after stringification: */
 567           ptr = SvPV_nomg_const(ssv,len);
 568           /* We need to check the flag again: */
 569           if (!SvAMAGIC(ssv)) goto frog;
 570         }
 571         else ptr = SvPV_nomg_const(ssv,len);
 572         if (len == 0)
 573             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
 574                            "Explicit blessing to '' (assuming package main)");
 575         stash = gv_stashpvn(ptr, len, GV_ADD|SvUTF8(ssv));
 576     }
 577
 578     (void)sv_bless(TOPs, stash);
 579     RETURN;
 580 }
 581
 582 PP(pp_gelem)
 583 {
 584     dSP;
 585
 586     SV *sv = POPs;
 587     STRLEN len;
 588     const char * const elem = SvPV_const(sv, len);
 589     GV * const gv = MUTABLE_GV(TOPs);
 590     SV * tmpRef = NULL;
 591
 592     sv = NULL;
 593     if (elem) {
 594         /* elem will always be NUL terminated.  */
 595         switch (*elem) {
 596         case 'A':
 597             if (memEQs(elem, len, "ARRAY"))
 598             {
 599                 tmpRef = MUTABLE_SV(GvAV(gv));
 600                 if (tmpRef && !AvREAL((const AV *)tmpRef)
 601                  && AvREIFY((const AV *)tmpRef))
 602                     av_reify(MUTABLE_AV(tmpRef));
 603             }
 604             break;
 605         case 'C':
 606             if (memEQs(elem, len, "CODE"))
 607                 tmpRef = MUTABLE_SV(GvCVu(gv));
 608             break;
 609         case 'F':
 610             if (memEQs(elem, len, "FILEHANDLE")) {
 611                 tmpRef = MUTABLE_SV(GvIOp(gv));
 612             }
 613             else
 614                 if (memEQs(elem, len, "FORMAT"))
 615                     tmpRef = MUTABLE_SV(GvFORM(gv));
 616             break;
 617         case 'G':
 618             if (memEQs(elem, len, "GLOB"))
 619                 tmpRef = MUTABLE_SV(gv);
 620             break;
 621         case 'H':
 622             if (memEQs(elem, len, "HASH"))
 623                 tmpRef = MUTABLE_SV(GvHV(gv));
 624             break;
 625         case 'I':
 626             if (memEQs(elem, len, "IO"))
 627                 tmpRef = MUTABLE_SV(GvIOp(gv));
 628             break;
 629         case 'N':
 630             if (memEQs(elem, len, "NAME"))
 631                 sv = newSVhek(GvNAME_HEK(gv));
 632             break;
 633         case 'P':
 634             if (memEQs(elem, len, "PACKAGE")) {
 635                 const HV * const stash = GvSTASH(gv);
 636                 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
 637                 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
 638             }
 639             break;
 640         case 'S':
 641             if (memEQs(elem, len, "SCALAR"))
 642                 tmpRef = GvSVn(gv);
 643             break;
 644         }
 645     }
 646     if (tmpRef)
 647         sv = newRV(tmpRef);
 648     if (sv)
 649         sv_2mortal(sv);
 650     else
 651         sv = &PL_sv_undef;
 652     SETs(sv);
 653     RETURN;
 654 }
 655
 656 /* Pattern matching */
 657
 658 PP(pp_study)
 659 {
 660     dSP; dTOPss;
 661     STRLEN len;
 662
 663     (void)SvPV(sv, len);
 664     if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) {
 665         /* Historically, study was skipped in these cases. */
 666         SETs(&PL_sv_no);
 667         return NORMAL;
 668     }
 669
 670     /* Make study a no-op. It's no longer useful and its existence
 671        complicates matters elsewhere. */
 672     SETs(&PL_sv_yes);
 673     return NORMAL;
 674 }
 675
 676
 677 /* also used for: pp_transr() */
 678
 679 PP(pp_trans)
 680 {
 681     dSP;
 682     SV *sv;
 683
 684     if (PL_op->op_flags & OPf_STACKED)
 685         sv = POPs;
 686     else {
 687         EXTEND(SP,1);
 688         if (ARGTARG)
 689             sv = PAD_SV(ARGTARG);
 690         else {
 691             sv = DEFSV;
 692         }
 693     }
 694     if(PL_op->op_type == OP_TRANSR) {
 695         STRLEN len;
 696         const char * const pv = SvPV(sv,len);
 697         SV * const newsv = newSVpvn_flags(pv, len, SVs_TEMP|SvUTF8(sv));
 698         do_trans(newsv);
 699         PUSHs(newsv);
 700     }
 701     else {
 702         I32 i = do_trans(sv);
 703         mPUSHi(i);
 704     }
 705     RETURN;
 706 }
 707
 708 /* Lvalue operators. */
 709
 710 static size_t
 711 S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
 712 {
 713     STRLEN len;
 714     char *s;
 715     size_t count = 0;
 716
 717     PERL_ARGS_ASSERT_DO_CHOMP;
 718
 719     if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
 720         return 0;
 721     if (SvTYPE(sv) == SVt_PVAV) {
 722         I32 i;
 723         AV *const av = MUTABLE_AV(sv);
 724         const I32 max = AvFILL(av);
 725
 726         for (i = 0; i <= max; i++) {
 727             sv = MUTABLE_SV(av_fetch(av, i, FALSE));
 728             if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
 729                 count += do_chomp(retval, sv, chomping);
 730         }
 731         return count;
 732     }
 733     else if (SvTYPE(sv) == SVt_PVHV) {
 734         HV* const hv = MUTABLE_HV(sv);
 735         HE* entry;
 736         (void)hv_iterinit(hv);
 737         while ((entry = hv_iternext(hv)))
 738             count += do_chomp(retval, hv_iterval(hv,entry), chomping);
 739         return count;
 740     }
 741     else if (SvREADONLY(sv)) {
 742             Perl_croak_no_modify();
 743     }
 744
 745     s = SvPV(sv, len);
 746     if (chomping) {
 747         if (s && len) {
 748             char *temp_buffer = NULL;
 749             SV *svrecode = NULL;
 750             s += --len;
 751             if (RsPARA(PL_rs)) {
 752                 if (*s != '\n')
 753                     goto nope_free_nothing;
 754                 ++count;
 755                 while (len && s[-1] == '\n') {
 756                     --len;
 757                     --s;
 758                     ++count;
 759                 }
 760             }
 761             else {
 762                 STRLEN rslen, rs_charlen;
 763                 const char *rsptr = SvPV_const(PL_rs, rslen);
 764
 765                 rs_charlen = SvUTF8(PL_rs)
 766                     ? sv_len_utf8(PL_rs)
 767                     : rslen;
 768
 769                 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
 770                     /* Assumption is that rs is shorter than the scalar.  */
 771                     if (SvUTF8(PL_rs)) {
 772                         /* RS is utf8, scalar is 8 bit.  */
 773                         bool is_utf8 = TRUE;
 774                         temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
 775                                                              &rslen, &is_utf8);
 776                         if (is_utf8) {
 777                             /* Cannot downgrade, therefore cannot possibly match.
 778                                At this point, temp_buffer is not alloced, and
 779                                is the buffer inside PL_rs, so dont free it.
 780                              */
 781                             assert (temp_buffer == rsptr);
 782                             goto nope_free_sv;
 783                         }
 784                         rsptr = temp_buffer;
 785                     }
 786                     else {
 787                         /* RS is 8 bit, scalar is utf8.  */
 788                         temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
 789                         rsptr = temp_buffer;
 790                     }
 791                 }
 792                 if (rslen == 1) {
 793                     if (*s != *rsptr)
 794                         goto nope_free_all;
 795                     ++count;
 796                 }
 797                 else {
 798                     if (len < rslen - 1)
 799                         goto nope_free_all;
 800                     len -= rslen - 1;
 801                     s -= rslen - 1;
 802                     if (memNE(s, rsptr, rslen))
 803                         goto nope_free_all;
 804                     count += rs_charlen;
 805                 }
 806             }
 807             SvPV_force_nomg_nolen(sv);
 808             SvCUR_set(sv, len);
 809             *SvEND(sv) = '\0';
 810             SvNIOK_off(sv);
 811             SvSETMAGIC(sv);
 812
 813             nope_free_all:
 814             Safefree(temp_buffer);
 815             nope_free_sv:
 816             SvREFCNT_dec(svrecode);
 817             nope_free_nothing: ;
 818         }
 819     } else {
 820         if (len && (!SvPOK(sv) || SvIsCOW(sv)))
 821             s = SvPV_force_nomg(sv, len);
 822         if (DO_UTF8(sv)) {
 823             if (s && len) {
 824                 char * const send = s + len;
 825                 char * const start = s;
 826                 s = send - 1;
 827                 while (s > start && UTF8_IS_CONTINUATION(*s))
 828                     s--;
 829                 if (is_utf8_string((U8*)s, send - s)) {
 830                     sv_setpvn(retval, s, send - s);
 831                     *s = '\0';
 832                     SvCUR_set(sv, s - start);
 833                     SvNIOK_off(sv);
 834                     SvUTF8_on(retval);
 835                 }
 836             }
 837             else
 838                 SvPVCLEAR(retval);
 839         }
 840         else if (s && len) {
 841             s += --len;
 842             sv_setpvn(retval, s, 1);
 843             *s = '\0';
 844             SvCUR_set(sv, len);
 845             SvUTF8_off(sv);
 846             SvNIOK_off(sv);
 847         }
 848         else
 849             SvPVCLEAR(retval);
 850         SvSETMAGIC(sv);
 851     }
 852     return count;
 853 }
 854
 855
 856 /* also used for: pp_schomp() */
 857
 858 PP(pp_schop)
 859 {
 860     dSP; dTARGET;
 861     const bool chomping = PL_op->op_type == OP_SCHOMP;
 862
 863     const size_t count = do_chomp(TARG, TOPs, chomping);
 864     if (chomping)
 865         sv_setiv(TARG, count);
 866     SETTARG;
 867     return NORMAL;
 868 }
 869
 870
 871 /* also used for: pp_chomp() */
 872
 873 PP(pp_chop)
 874 {
 875     dSP; dMARK; dTARGET; dORIGMARK;
 876     const bool chomping = PL_op->op_type == OP_CHOMP;
 877     size_t count = 0;
 878
 879     while (MARK < SP)
 880         count += do_chomp(TARG, *++MARK, chomping);
 881     if (chomping)
 882         sv_setiv(TARG, count);
 883     SP = ORIGMARK;
 884     XPUSHTARG;
 885     RETURN;
 886 }
 887
 888 PP(pp_undef)
 889 {
 890     dSP;
 891     SV *sv;
 892
 893     if (!PL_op->op_private) {
 894         EXTEND(SP, 1);
 895         RETPUSHUNDEF;
 896     }
 897
 898     sv = TOPs;
 899     if (!sv)
 900     {
 901         SETs(&PL_sv_undef);
 902         return NORMAL;
 903     }
 904
 905     if (SvTHINKFIRST(sv))
 906         sv_force_normal_flags(sv, SV_COW_DROP_PV|SV_IMMEDIATE_UNREF);
 907
 908     switch (SvTYPE(sv)) {
 909     case SVt_NULL:
 910         break;
 911     case SVt_PVAV:
 912         av_undef(MUTABLE_AV(sv));
 913         break;
 914     case SVt_PVHV:
 915         hv_undef(MUTABLE_HV(sv));
 916         break;
 917     case SVt_PVCV:
 918         if (cv_const_sv((const CV *)sv))
 919             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
 920                           "Constant subroutine %" SVf " undefined",
 921                            SVfARG(CvANON((const CV *)sv)
 922                              ? newSVpvs_flags("(anonymous)", SVs_TEMP)
 923                              : sv_2mortal(newSVhek(
 924                                 CvNAMED(sv)
 925                                  ? CvNAME_HEK((CV *)sv)
 926                                  : GvENAME_HEK(CvGV((const CV *)sv))
 927                                ))
 928                            ));
 929         /* FALLTHROUGH */
 930     case SVt_PVFM:
 931             /* let user-undef'd sub keep its identity */
 932         cv_undef_flags(MUTABLE_CV(sv), CV_UNDEF_KEEP_NAME);
 933         break;
 934     case SVt_PVGV:
 935         assert(isGV_with_GP(sv));
 936         assert(!SvFAKE(sv));
 937         {
 938             GP *gp;
 939             HV *stash;
 940
 941             /* undef *Pkg::meth_name ... */
 942             bool method_changed
 943              =   GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
 944               && HvENAME_get(stash);
 945             /* undef *Foo:: */
 946             if((stash = GvHV((const GV *)sv))) {
 947                 if(HvENAME_get(stash))
 948                     SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
 949                 else stash = NULL;
 950             }
 951
 952             SvREFCNT_inc_simple_void_NN(sv_2mortal(sv));
 953             gp_free(MUTABLE_GV(sv));
 954             Newxz(gp, 1, GP);
 955             GvGP_set(sv, gp_ref(gp));
 956 #ifndef PERL_DONT_CREATE_GVSV
 957             GvSV(sv) = newSV(0);
 958 #endif
 959             GvLINE(sv) = CopLINE(PL_curcop);
 960             GvEGV(sv) = MUTABLE_GV(sv);
 961             GvMULTI_on(sv);
 962
 963             if(stash)
 964                 mro_package_moved(NULL, stash, (const GV *)sv, 0);
 965             stash = NULL;
 966             /* undef *Foo::ISA */
 967             if( strEQ(GvNAME((const GV *)sv), "ISA")
 968              && (stash = GvSTASH((const GV *)sv))
 969              && (method_changed || HvENAME(stash)) )
 970                 mro_isa_changed_in(stash);
 971             else if(method_changed)
 972                 mro_method_changed_in(
 973                  GvSTASH((const GV *)sv)
 974                 );
 975
 976             break;
 977         }
 978     default:
 979         if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
 980             SvPV_free(sv);
 981             SvPV_set(sv, NULL);
 982             SvLEN_set(sv, 0);
 983         }
 984         SvOK_off(sv);
 985         SvSETMAGIC(sv);
 986     }
 987
 988     SETs(&PL_sv_undef);
 989     return NORMAL;
 990 }
 991
 992
 993 /* common "slow" code for pp_postinc and pp_postdec */
 994
 995 static OP *
 996 S_postincdec_common(pTHX_ SV *sv, SV *targ)
 997 {
 998     dSP;
 999     const bool inc =
1000         PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC;
1001
1002     if (SvROK(sv))
1003         TARG = sv_newmortal();
1004     sv_setsv(TARG, sv);
1005     if (inc)
1006         sv_inc_nomg(sv);
1007     else
1008         sv_dec_nomg(sv);
1009     SvSETMAGIC(sv);
1010     /* special case for undef: see thread at 2003-03/msg00536.html in archive */
1011     if (inc && !SvOK(TARG))
1012         sv_setiv(TARG, 0);
1013     SETTARG;
1014     return NORMAL;
1015 }
1016
1017
1018 /* also used for: pp_i_postinc() */
1019
1020 PP(pp_postinc)
1021 {
1022     dSP; dTARGET;
1023     SV *sv = TOPs;
1024
1025     /* special-case sv being a simple integer */
1026     if (LIKELY(((sv->sv_flags &
1027                         (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1028                          SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1029                 == SVf_IOK))
1030         && SvIVX(sv) != IV_MAX)
1031     {
1032         IV iv = SvIVX(sv);
1033         SvIV_set(sv,  iv + 1);
1034         TARGi(iv, 0); /* arg not GMG, so can't be tainted */
1035         SETs(TARG);
1036         return NORMAL;
1037     }
1038
1039     return S_postincdec_common(aTHX_ sv, TARG);
1040 }
1041
1042
1043 /* also used for: pp_i_postdec() */
1044
1045 PP(pp_postdec)
1046 {
1047     dSP; dTARGET;
1048     SV *sv = TOPs;
1049
1050     /* special-case sv being a simple integer */
1051     if (LIKELY(((sv->sv_flags &
1052                         (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1053                          SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1054                 == SVf_IOK))
1055         && SvIVX(sv) != IV_MIN)
1056     {
1057         IV iv = SvIVX(sv);
1058         SvIV_set(sv,  iv - 1);
1059         TARGi(iv, 0); /* arg not GMG, so can't be tainted */
1060         SETs(TARG);
1061         return NORMAL;
1062     }
1063
1064     return S_postincdec_common(aTHX_ sv, TARG);
1065 }
1066
1067
1068 /* Ordinary operators. */
1069
1070 PP(pp_pow)
1071 {
1072     dSP; dATARGET; SV *svl, *svr;
1073 #ifdef PERL_PRESERVE_IVUV
1074     bool is_int = 0;
1075 #endif
1076     tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
1077     svr = TOPs;
1078     svl = TOPm1s;
1079 #ifdef PERL_PRESERVE_IVUV
1080     /* For integer to integer power, we do the calculation by hand wherever
1081        we're sure it is safe; otherwise we call pow() and try to convert to
1082        integer afterwards. */
1083     if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1084                 UV power;
1085                 bool baseuok;
1086                 UV baseuv;
1087
1088                 if (SvUOK(svr)) {
1089                     power = SvUVX(svr);
1090                 } else {
1091                     const IV iv = SvIVX(svr);
1092                     if (iv >= 0) {
1093                         power = iv;
1094                     } else {
1095                         goto float_it; /* Can't do negative powers this way.  */
1096                     }
1097                 }
1098
1099                 baseuok = SvUOK(svl);
1100                 if (baseuok) {
1101                     baseuv = SvUVX(svl);
1102                 } else {
1103                     const IV iv = SvIVX(svl);
1104                     if (iv >= 0) {
1105                         baseuv = iv;
1106                         baseuok = TRUE; /* effectively it's a UV now */
1107                     } else {
1108                         baseuv = -iv; /* abs, baseuok == false records sign */
1109                     }
1110                 }
1111                 /* now we have integer ** positive integer. */
1112                 is_int = 1;
1113
1114                 /* foo & (foo - 1) is zero only for a power of 2.  */
1115                 if (!(baseuv & (baseuv - 1))) {
1116                     /* We are raising power-of-2 to a positive integer.
1117                        The logic here will work for any base (even non-integer
1118                        bases) but it can be less accurate than
1119                        pow (base,power) or exp (power * log (base)) when the
1120                        intermediate values start to spill out of the mantissa.
1121                        With powers of 2 we know this can't happen.
1122                        And powers of 2 are the favourite thing for perl
1123                        programmers to notice ** not doing what they mean. */
1124                     NV result = 1.0;
1125                     NV base = baseuok ? baseuv : -(NV)baseuv;
1126
1127                     if (power & 1) {
1128                         result *= base;
1129                     }
1130                     while (power >>= 1) {
1131                         base *= base;
1132                         if (power & 1) {
1133                             result *= base;
1134                         }
1135                     }
1136                     SP--;
1137                     SETn( result );
1138                     SvIV_please_nomg(svr);
1139                     RETURN;
1140                 } else {
1141                     unsigned int highbit = 8 * sizeof(UV);
1142                     unsigned int diff = 8 * sizeof(UV);
1143                     while (diff >>= 1) {
1144                         highbit -= diff;
1145                         if (baseuv >> highbit) {
1146                             highbit += diff;
1147                         }
1148                     }
1149                     /* we now have baseuv < 2 ** highbit */
1150                     if (power * highbit <= 8 * sizeof(UV)) {
1151                         /* result will definitely fit in UV, so use UV math
1152                            on same algorithm as above */
1153                         UV result = 1;
1154                         UV base = baseuv;
1155                         const bool odd_power = cBOOL(power & 1);
1156                         if (odd_power) {
1157                             result *= base;
1158                         }
1159                         while (power >>= 1) {
1160                             base *= base;
1161                             if (power & 1) {
1162                                 result *= base;
1163                             }
1164                         }
1165                         SP--;
1166                         if (baseuok || !odd_power)
1167                             /* answer is positive */
1168                             SETu( result );
1169                         else if (result <= (UV)IV_MAX)
1170                             /* answer negative, fits in IV */
1171                             SETi( -(IV)result );
1172                         else if (result == (UV)IV_MIN)
1173                             /* 2's complement assumption: special case IV_MIN */
1174                             SETi( IV_MIN );
1175                         else
1176                             /* answer negative, doesn't fit */
1177                             SETn( -(NV)result );
1178                         RETURN;
1179                     }
1180                 }
1181     }
1182   float_it:
1183 #endif
1184     {
1185         NV right = SvNV_nomg(svr);
1186         NV left  = SvNV_nomg(svl);
1187         (void)POPs;
1188
1189 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1190     /*
1191     We are building perl with long double support and are on an AIX OS
1192     afflicted with a powl() function that wrongly returns NaNQ for any
1193     negative base.  This was reported to IBM as PMR #23047-379 on
1194     03/06/2006.  The problem exists in at least the following versions
1195     of AIX and the libm fileset, and no doubt others as well:
1196
1197         AIX 4.3.3-ML10      bos.adt.libm 4.3.3.50
1198         AIX 5.1.0-ML04      bos.adt.libm 5.1.0.29
1199         AIX 5.2.0           bos.adt.libm 5.2.0.85
1200
1201     So, until IBM fixes powl(), we provide the following workaround to
1202     handle the problem ourselves.  Our logic is as follows: for
1203     negative bases (left), we use fmod(right, 2) to check if the
1204     exponent is an odd or even integer:
1205
1206         - if odd,  powl(left, right) == -powl(-left, right)
1207         - if even, powl(left, right) ==  powl(-left, right)
1208
1209     If the exponent is not an integer, the result is rightly NaNQ, so
1210     we just return that (as NV_NAN).
1211     */
1212
1213         if (left < 0.0) {
1214             NV mod2 = Perl_fmod( right, 2.0 );
1215             if (mod2 == 1.0 || mod2 == -1.0) {  /* odd integer */
1216                 SETn( -Perl_pow( -left, right) );
1217             } else if (mod2 == 0.0) {           /* even integer */
1218                 SETn( Perl_pow( -left, right) );
1219             } else {                            /* fractional power */
1220                 SETn( NV_NAN );
1221             }
1222         } else {
1223             SETn( Perl_pow( left, right) );
1224         }
1225 #else
1226         SETn( Perl_pow( left, right) );
1227 #endif  /* HAS_AIX_POWL_NEG_BASE_BUG */
1228
1229 #ifdef PERL_PRESERVE_IVUV
1230         if (is_int)
1231             SvIV_please_nomg(svr);
1232 #endif
1233         RETURN;
1234     }
1235 }
1236
1237 PP(pp_multiply)
1238 {
1239     dSP; dATARGET; SV *svl, *svr;
1240     tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1241     svr = TOPs;
1242     svl = TOPm1s;
1243
1244 #ifdef PERL_PRESERVE_IVUV
1245
1246     /* special-case some simple common cases */
1247     if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1248         IV il, ir;
1249         U32 flags = (svl->sv_flags & svr->sv_flags);
1250         if (flags & SVf_IOK) {
1251             /* both args are simple IVs */
1252             UV topl, topr;
1253             il = SvIVX(svl);
1254             ir = SvIVX(svr);
1255           do_iv:
1256             topl = ((UV)il) >> (UVSIZE * 4 - 1);
1257             topr = ((UV)ir) >> (UVSIZE * 4 - 1);
1258
1259             /* if both are in a range that can't under/overflow, do a
1260              * simple integer multiply: if the top halves(*) of both numbers
1261              * are 00...00  or 11...11, then it's safe.
1262              * (*) for 32-bits, the "top half" is the top 17 bits,
1263              *     for 64-bits, its 33 bits */
1264             if (!(
1265                       ((topl+1) | (topr+1))
1266                     & ( (((UV)1) << (UVSIZE * 4 + 1)) - 2) /* 11..110 */
1267             )) {
1268                 SP--;
1269                 TARGi(il * ir, 0); /* args not GMG, so can't be tainted */
1270                 SETs(TARG);
1271                 RETURN;
1272             }
1273             goto generic;
1274         }
1275         else if (flags & SVf_NOK) {
1276             /* both args are NVs */
1277             NV nl = SvNVX(svl);
1278             NV nr = SvNVX(svr);
1279             NV result;
1280
1281             if (
1282 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1283                 !Perl_isnan(nl) && nl == (NV)(il = (IV)nl)
1284                 && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr)
1285 #else
1286                 nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr)
1287 #endif
1288                 )
1289                 /* nothing was lost by converting to IVs */
1290                 goto do_iv;
1291             SP--;
1292             result = nl * nr;
1293 #  if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16
1294             if (Perl_isinf(result)) {
1295                 Zero((U8*)&result + 8, 8, U8);
1296             }
1297 #  endif
1298             TARGn(result, 0); /* args not GMG, so can't be tainted */
1299             SETs(TARG);
1300             RETURN;
1301         }
1302     }
1303
1304   generic:
1305
1306     if (SvIV_please_nomg(svr)) {
1307         /* Unless the left argument is integer in range we are going to have to
1308            use NV maths. Hence only attempt to coerce the right argument if
1309            we know the left is integer.  */
1310         /* Left operand is defined, so is it IV? */
1311         if (SvIV_please_nomg(svl)) {
1312             bool auvok = SvUOK(svl);
1313             bool buvok = SvUOK(svr);
1314             const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1315             const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1316             UV alow;
1317             UV ahigh;
1318             UV blow;
1319             UV bhigh;
1320
1321             if (auvok) {
1322                 alow = SvUVX(svl);
1323             } else {
1324                 const IV aiv = SvIVX(svl);
1325                 if (aiv >= 0) {
1326                     alow = aiv;
1327                     auvok = TRUE; /* effectively it's a UV now */
1328                 } else {
1329                     /* abs, auvok == false records sign */
1330                     alow = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
1331                 }
1332             }
1333             if (buvok) {
1334                 blow = SvUVX(svr);
1335             } else {
1336                 const IV biv = SvIVX(svr);
1337                 if (biv >= 0) {
1338                     blow = biv;
1339                     buvok = TRUE; /* effectively it's a UV now */
1340                 } else {
1341                     /* abs, buvok == false records sign */
1342                     blow = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
1343                 }
1344             }
1345
1346             /* If this does sign extension on unsigned it's time for plan B  */
1347             ahigh = alow >> (4 * sizeof (UV));
1348             alow &= botmask;
1349             bhigh = blow >> (4 * sizeof (UV));
1350             blow &= botmask;
1351             if (ahigh && bhigh) {
1352                 NOOP;
1353                 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1354                    which is overflow. Drop to NVs below.  */
1355             } else if (!ahigh && !bhigh) {
1356                 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1357                    so the unsigned multiply cannot overflow.  */
1358                 const UV product = alow * blow;
1359                 if (auvok == buvok) {
1360                     /* -ve * -ve or +ve * +ve gives a +ve result.  */
1361                     SP--;
1362                     SETu( product );
1363                     RETURN;
1364                 } else if (product <= (UV)IV_MIN) {
1365                     /* 2s complement assumption that (UV)-IV_MIN is correct.  */
1366                     /* -ve result, which could overflow an IV  */
1367                     SP--;
1368                     /* can't negate IV_MIN, but there are aren't two
1369                      * integers such that !ahigh && !bhigh, where the
1370                      * product equals 0x800....000 */
1371                     assert(product != (UV)IV_MIN);
1372                     SETi( -(IV)product );
1373                     RETURN;
1374                 } /* else drop to NVs below. */
1375             } else {
1376                 /* One operand is large, 1 small */
1377                 UV product_middle;
1378                 if (bhigh) {
1379                     /* swap the operands */
1380                     ahigh = bhigh;
1381                     bhigh = blow; /* bhigh now the temp var for the swap */
1382                     blow = alow;
1383                     alow = bhigh;
1384                 }
1385                 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1386                    multiplies can't overflow. shift can, add can, -ve can.  */
1387                 product_middle = ahigh * blow;
1388                 if (!(product_middle & topmask)) {
1389                     /* OK, (ahigh * blow) won't lose bits when we shift it.  */
1390                     UV product_low;
1391                     product_middle <<= (4 * sizeof (UV));
1392                     product_low = alow * blow;
1393
1394                     /* as for pp_add, UV + something mustn't get smaller.
1395                        IIRC ANSI mandates this wrapping *behaviour* for
1396                        unsigned whatever the actual representation*/
1397                     product_low += product_middle;
1398                     if (product_low >= product_middle) {
1399                         /* didn't overflow */
1400                         if (auvok == buvok) {
1401                             /* -ve * -ve or +ve * +ve gives a +ve result.  */
1402                             SP--;
1403                             SETu( product_low );
1404                             RETURN;
1405                         } else if (product_low <= (UV)IV_MIN) {
1406                             /* 2s complement assumption again  */
1407                             /* -ve result, which could overflow an IV  */
1408                             SP--;
1409                             SETi(product_low == (UV)IV_MIN
1410                                     ? IV_MIN : -(IV)product_low);
1411                             RETURN;
1412                         } /* else drop to NVs below. */
1413                     }
1414                 } /* product_middle too large */
1415             } /* ahigh && bhigh */
1416         } /* SvIOK(svl) */
1417     } /* SvIOK(svr) */
1418 #endif
1419     {
1420       NV right = SvNV_nomg(svr);
1421       NV left  = SvNV_nomg(svl);
1422       NV result = left * right;
1423
1424       (void)POPs;
1425 #if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16
1426       if (Perl_isinf(result)) {
1427           Zero((U8*)&result + 8, 8, U8);
1428       }
1429 #endif
1430       SETn(result);
1431       RETURN;
1432     }
1433 }
1434
1435 PP(pp_divide)
1436 {
1437     dSP; dATARGET; SV *svl, *svr;
1438     tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1439     svr = TOPs;
1440     svl = TOPm1s;
1441     /* Only try to do UV divide first
1442        if ((SLOPPYDIVIDE is true) or
1443            (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1444             to preserve))
1445        The assumption is that it is better to use floating point divide
1446        whenever possible, only doing integer divide first if we can't be sure.
1447        If NV_PRESERVES_UV is true then we know at compile time that no UV
1448        can be too large to preserve, so don't need to compile the code to
1449        test the size of UVs.  */
1450
1451 #ifdef SLOPPYDIVIDE
1452 #  define PERL_TRY_UV_DIVIDE
1453     /* ensure that 20./5. == 4. */
1454 #else
1455 #  ifdef PERL_PRESERVE_IVUV
1456 #    ifndef NV_PRESERVES_UV
1457 #      define PERL_TRY_UV_DIVIDE
1458 #    endif
1459 #  endif
1460 #endif
1461
1462 #ifdef PERL_TRY_UV_DIVIDE
1463     if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1464             bool left_non_neg = SvUOK(svl);
1465             bool right_non_neg = SvUOK(svr);
1466             UV left;
1467             UV right;
1468
1469             if (right_non_neg) {
1470                 right = SvUVX(svr);
1471             }
1472             else {
1473                 const IV biv = SvIVX(svr);
1474                 if (biv >= 0) {
1475                     right = biv;
1476                     right_non_neg = TRUE; /* effectively it's a UV now */
1477                 }
1478                 else {
1479                     right = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
1480                 }
1481             }
1482             /* historically undef()/0 gives a "Use of uninitialized value"
1483                warning before dieing, hence this test goes here.
1484                If it were immediately before the second SvIV_please, then
1485                DIE() would be invoked before left was even inspected, so
1486                no inspection would give no warning.  */
1487             if (right == 0)
1488                 DIE(aTHX_ "Illegal division by zero");
1489
1490             if (left_non_neg) {
1491                 left = SvUVX(svl);
1492             }
1493             else {
1494                 const IV aiv = SvIVX(svl);
1495                 if (aiv >= 0) {
1496                     left = aiv;
1497                     left_non_neg = TRUE; /* effectively it's a UV now */
1498                 }
1499                 else {
1500                     left = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
1501                 }
1502             }
1503
1504             if (left >= right
1505 #ifdef SLOPPYDIVIDE
1506                 /* For sloppy divide we always attempt integer division.  */
1507 #else
1508                 /* Otherwise we only attempt it if either or both operands
1509                    would not be preserved by an NV.  If both fit in NVs
1510                    we fall through to the NV divide code below.  However,
1511                    as left >= right to ensure integer result here, we know that
1512                    we can skip the test on the right operand - right big
1513                    enough not to be preserved can't get here unless left is
1514                    also too big.  */
1515
1516                 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1517 #endif
1518                 ) {
1519                 /* Integer division can't overflow, but it can be imprecise.  */
1520                 const UV result = left / right;
1521                 if (result * right == left) {
1522                     SP--; /* result is valid */
1523                     if (left_non_neg == right_non_neg) {
1524                         /* signs identical, result is positive.  */
1525                         SETu( result );
1526                         RETURN;
1527                     }
1528                     /* 2s complement assumption */
1529                     if (result <= (UV)IV_MIN)
1530                         SETi(result == (UV)IV_MIN ? IV_MIN : -(IV)result);
1531                     else {
1532                         /* It's exact but too negative for IV. */
1533                         SETn( -(NV)result );
1534                     }
1535                     RETURN;
1536                 } /* tried integer divide but it was not an integer result */
1537             } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1538     } /* one operand wasn't SvIOK */
1539 #endif /* PERL_TRY_UV_DIVIDE */
1540     {
1541         NV right = SvNV_nomg(svr);
1542         NV left  = SvNV_nomg(svl);
1543         (void)POPs;(void)POPs;
1544 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1545         if (! Perl_isnan(right) && right == 0.0)
1546 #else
1547         if (right == 0.0)
1548 #endif
1549             DIE(aTHX_ "Illegal division by zero");
1550         PUSHn( left / right );
1551         RETURN;
1552     }
1553 }
1554
1555 PP(pp_modulo)
1556 {
1557     dSP; dATARGET;
1558     tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
1559     {
1560         UV left  = 0;
1561         UV right = 0;
1562         bool left_neg = FALSE;
1563         bool right_neg = FALSE;
1564         bool use_double = FALSE;
1565         bool dright_valid = FALSE;
1566         NV dright = 0.0;
1567         NV dleft  = 0.0;
1568         SV * const svr = TOPs;
1569         SV * const svl = TOPm1s;
1570         if (SvIV_please_nomg(svr)) {
1571             right_neg = !SvUOK(svr);
1572             if (!right_neg) {
1573                 right = SvUVX(svr);
1574             } else {
1575                 const IV biv = SvIVX(svr);
1576                 if (biv >= 0) {
1577                     right = biv;
1578                     right_neg = FALSE; /* effectively it's a UV now */
1579                 } else {
1580                     right = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
1581                 }
1582             }
1583         }
1584         else {
1585             dright = SvNV_nomg(svr);
1586             right_neg = dright < 0;
1587             if (right_neg)
1588                 dright = -dright;
1589             if (dright < UV_MAX_P1) {
1590                 right = U_V(dright);
1591                 dright_valid = TRUE; /* In case we need to use double below.  */
1592             } else {
1593                 use_double = TRUE;
1594             }
1595         }
1596
1597         /* At this point use_double is only true if right is out of range for
1598            a UV.  In range NV has been rounded down to nearest UV and
1599            use_double false.  */
1600         if (!use_double && SvIV_please_nomg(svl)) {
1601                 left_neg = !SvUOK(svl);
1602                 if (!left_neg) {
1603                     left = SvUVX(svl);
1604                 } else {
1605                     const IV aiv = SvIVX(svl);
1606                     if (aiv >= 0) {
1607                         left = aiv;
1608                         left_neg = FALSE; /* effectively it's a UV now */
1609                     } else {
1610                         left = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
1611                     }
1612                 }
1613         }
1614         else {
1615             dleft = SvNV_nomg(svl);
1616             left_neg = dleft < 0;
1617             if (left_neg)
1618                 dleft = -dleft;
1619
1620             /* This should be exactly the 5.6 behaviour - if left and right are
1621                both in range for UV then use U_V() rather than floor.  */
1622             if (!use_double) {
1623                 if (dleft < UV_MAX_P1) {
1624                     /* right was in range, so is dleft, so use UVs not double.
1625                      */
1626                     left = U_V(dleft);
1627                 }
1628                 /* left is out of range for UV, right was in range, so promote
1629                    right (back) to double.  */
1630                 else {
1631                     /* The +0.5 is used in 5.6 even though it is not strictly
1632                        consistent with the implicit +0 floor in the U_V()
1633                        inside the #if 1. */
1634                     dleft = Perl_floor(dleft + 0.5);
1635                     use_double = TRUE;
1636                     if (dright_valid)
1637                         dright = Perl_floor(dright + 0.5);
1638                     else
1639                         dright = right;
1640                 }
1641             }
1642         }
1643         sp -= 2;
1644         if (use_double) {
1645             NV dans;
1646
1647             if (!dright)
1648                 DIE(aTHX_ "Illegal modulus zero");
1649
1650             dans = Perl_fmod(dleft, dright);
1651             if ((left_neg != right_neg) && dans)
1652                 dans = dright - dans;
1653             if (right_neg)
1654                 dans = -dans;
1655             sv_setnv(TARG, dans);
1656         }
1657         else {
1658             UV ans;
1659
1660             if (!right)
1661                 DIE(aTHX_ "Illegal modulus zero");
1662
1663             ans = left % right;
1664             if ((left_neg != right_neg) && ans)
1665                 ans = right - ans;
1666             if (right_neg) {
1667                 /* XXX may warn: unary minus operator applied to unsigned type */
1668                 /* could change -foo to be (~foo)+1 instead     */
1669                 if (ans <= ~((UV)IV_MAX)+1)
1670                     sv_setiv(TARG, ~ans+1);
1671                 else
1672                     sv_setnv(TARG, -(NV)ans);
1673             }
1674             else
1675                 sv_setuv(TARG, ans);
1676         }
1677         PUSHTARG;
1678         RETURN;
1679     }
1680 }
1681
1682 PP(pp_repeat)
1683 {
1684     dSP; dATARGET;
1685     IV count;
1686     SV *sv;
1687     bool infnan = FALSE;
1688
1689     if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1690         /* TODO: think of some way of doing list-repeat overloading ??? */
1691         sv = POPs;
1692         SvGETMAGIC(sv);
1693     }
1694     else {
1695         if (UNLIKELY(PL_op->op_private & OPpREPEAT_DOLIST)) {
1696             /* The parser saw this as a list repeat, and there
1697                are probably several items on the stack. But we're
1698                in scalar/void context, and there's no pp_list to save us
1699                now. So drop the rest of the items -- robin@kitsite.com
1700              */
1701             dMARK;
1702             if (MARK + 1 < SP) {
1703                 MARK[1] = TOPm1s;
1704                 MARK[2] = TOPs;
1705             }
1706             else {
1707                 dTOPss;
1708                 ASSUME(MARK + 1 == SP);
1709                 XPUSHs(sv);
1710                 MARK[1] = &PL_sv_undef;
1711             }
1712             SP = MARK + 2;
1713         }
1714         tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1715         sv = POPs;
1716     }
1717
1718     if (SvIOKp(sv)) {
1719          if (SvUOK(sv)) {
1720               const UV uv = SvUV_nomg(sv);
1721               if (uv > IV_MAX)
1722                    count = IV_MAX; /* The best we can do? */
1723               else
1724                    count = uv;
1725          } else {
1726               count = SvIV_nomg(sv);
1727          }
1728     }
1729     else if (SvNOKp(sv)) {
1730         const NV nv = SvNV_nomg(sv);
1731         infnan = Perl_isinfnan(nv);
1732         if (UNLIKELY(infnan)) {
1733             count = 0;
1734         } else {
1735             if (nv < 0.0)
1736                 count = -1;   /* An arbitrary negative integer */
1737             else
1738                 count = (IV)nv;
1739         }
1740     }
1741     else
1742         count = SvIV_nomg(sv);
1743
1744     if (infnan) {
1745         Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1746                        "Non-finite repeat count does nothing");
1747     } else if (count < 0) {
1748         count = 0;
1749         Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1750                        "Negative repeat count does nothing");
1751     }
1752
1753     if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1754         dMARK;
1755         const SSize_t items = SP - MARK;
1756         const U8 mod = PL_op->op_flags & OPf_MOD;
1757
1758         if (count > 1) {
1759             SSize_t max;
1760
1761             if (  items > SSize_t_MAX / count   /* max would overflow */
1762                                                 /* repeatcpy would overflow */
1763                || items > I32_MAX / (I32)sizeof(SV *)
1764             )
1765                Perl_croak(aTHX_ "%s","Out of memory during list extend");
1766             max = items * count;
1767             MEXTEND(MARK, max);
1768
1769             while (SP > MARK) {
1770                 if (*SP) {
1771                    if (mod && SvPADTMP(*SP)) {
1772                        *SP = sv_mortalcopy(*SP);
1773                    }
1774                    SvTEMP_off((*SP));
1775                 }
1776                 SP--;
1777             }
1778             MARK++;
1779             repeatcpy((char*)(MARK + items), (char*)MARK,
1780                 items * sizeof(const SV *), count - 1);
1781             SP += max;
1782         }
1783         else if (count <= 0)
1784             SP = MARK;
1785     }
1786     else {      /* Note: mark already snarfed by pp_list */
1787         SV * const tmpstr = POPs;
1788         STRLEN len;
1789         bool isutf;
1790
1791         if (TARG != tmpstr)
1792             sv_setsv_nomg(TARG, tmpstr);
1793         SvPV_force_nomg(TARG, len);
1794         isutf = DO_UTF8(TARG);
1795         if (count != 1) {
1796             if (count < 1)
1797                 SvCUR_set(TARG, 0);
1798             else {
1799                 STRLEN max;
1800
1801                 if (   len > (MEM_SIZE_MAX-1) / (UV)count /* max would overflow */
1802                     || len > (U32)I32_MAX  /* repeatcpy would overflow */
1803                 )
1804                      Perl_croak(aTHX_ "%s",
1805                                         "Out of memory during string extend");
1806                 max = (UV)count * len + 1;
1807                 SvGROW(TARG, max);
1808
1809                 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1810                 SvCUR_set(TARG, SvCUR(TARG) * count);
1811             }
1812             *SvEND(TARG) = '\0';
1813         }
1814         if (isutf)
1815             (void)SvPOK_only_UTF8(TARG);
1816         else
1817             (void)SvPOK_only(TARG);
1818
1819         PUSHTARG;
1820     }
1821     RETURN;
1822 }
1823
1824 PP(pp_subtract)
1825 {
1826     dSP; dATARGET; bool useleft; SV *svl, *svr;
1827     tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1828     svr = TOPs;
1829     svl = TOPm1s;
1830
1831 #ifdef PERL_PRESERVE_IVUV
1832
1833     /* special-case some simple common cases */
1834     if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1835         IV il, ir;
1836         U32 flags = (svl->sv_flags & svr->sv_flags);
1837         if (flags & SVf_IOK) {
1838             /* both args are simple IVs */
1839             UV topl, topr;
1840             il = SvIVX(svl);
1841             ir = SvIVX(svr);
1842           do_iv:
1843             topl = ((UV)il) >> (UVSIZE * 8 - 2);
1844             topr = ((UV)ir) >> (UVSIZE * 8 - 2);
1845
1846             /* if both are in a range that can't under/overflow, do a
1847              * simple integer subtract: if the top of both numbers
1848              * are 00  or 11, then it's safe */
1849             if (!( ((topl+1) | (topr+1)) & 2)) {
1850                 SP--;
1851                 TARGi(il - ir, 0); /* args not GMG, so can't be tainted */
1852                 SETs(TARG);
1853                 RETURN;
1854             }
1855             goto generic;
1856         }
1857         else if (flags & SVf_NOK) {
1858             /* both args are NVs */
1859             NV nl = SvNVX(svl);
1860             NV nr = SvNVX(svr);
1861
1862             if (
1863 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1864                 !Perl_isnan(nl) && nl == (NV)(il = (IV)nl)
1865                 && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr)
1866 #else
1867                 nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr)
1868 #endif
1869                 )
1870                 /* nothing was lost by converting to IVs */
1871                 goto do_iv;
1872             SP--;
1873             TARGn(nl - nr, 0); /* args not GMG, so can't be tainted */
1874             SETs(TARG);
1875             RETURN;
1876         }
1877     }
1878
1879   generic:
1880
1881     useleft = USE_LEFT(svl);
1882     /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1883        "bad things" happen if you rely on signed integers wrapping.  */
1884     if (SvIV_please_nomg(svr)) {
1885         /* Unless the left argument is integer in range we are going to have to
1886            use NV maths. Hence only attempt to coerce the right argument if
1887            we know the left is integer.  */
1888         UV auv = 0;
1889         bool auvok = FALSE;
1890         bool a_valid = 0;
1891
1892         if (!useleft) {
1893             auv = 0;
1894             a_valid = auvok = 1;
1895             /* left operand is undef, treat as zero.  */
1896         } else {
1897             /* Left operand is defined, so is it IV? */
1898             if (SvIV_please_nomg(svl)) {
1899                 if ((auvok = SvUOK(svl)))
1900                     auv = SvUVX(svl);
1901                 else {
1902                     const IV aiv = SvIVX(svl);
1903                     if (aiv >= 0) {
1904                         auv = aiv;
1905                         auvok = 1;      /* Now acting as a sign flag.  */
1906                     } else { /* 2s complement assumption for IV_MIN */
1907                         auv = (aiv == IV_MIN) ? (UV)aiv : (UV)-aiv;
1908                     }
1909                 }
1910                 a_valid = 1;
1911             }
1912         }
1913         if (a_valid) {
1914             bool result_good = 0;
1915             UV result;
1916             UV buv;
1917             bool buvok = SvUOK(svr);
1918
1919             if (buvok)
1920                 buv = SvUVX(svr);
1921             else {
1922                 const IV biv = SvIVX(svr);
1923                 if (biv >= 0) {
1924                     buv = biv;
1925                     buvok = 1;
1926                 } else
1927                     buv = (biv == IV_MIN) ? (UV)biv : (UV)-biv;
1928             }
1929             /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1930                else "IV" now, independent of how it came in.
1931                if a, b represents positive, A, B negative, a maps to -A etc
1932                a - b =>  (a - b)
1933                A - b => -(a + b)
1934                a - B =>  (a + b)
1935                A - B => -(a - b)
1936                all UV maths. negate result if A negative.
1937                subtract if signs same, add if signs differ. */
1938
1939             if (auvok ^ buvok) {
1940                 /* Signs differ.  */
1941                 result = auv + buv;
1942                 if (result >= auv)
1943                     result_good = 1;
1944             } else {
1945                 /* Signs same */
1946                 if (auv >= buv) {
1947                     result = auv - buv;
1948                     /* Must get smaller */
1949                     if (result <= auv)
1950                         result_good = 1;
1951                 } else {
1952                     result = buv - auv;
1953                     if (result <= buv) {
1954                         /* result really should be -(auv-buv). as its negation
1955                            of true value, need to swap our result flag  */
1956                         auvok = !auvok;
1957                         result_good = 1;
1958                     }
1959                 }
1960             }
1961             if (result_good) {
1962                 SP--;
1963                 if (auvok)
1964                     SETu( result );
1965                 else {
1966                     /* Negate result */
1967                     if (result <= (UV)IV_MIN)
1968                         SETi(result == (UV)IV_MIN
1969                                 ? IV_MIN : -(IV)result);
1970                     else {
1971                         /* result valid, but out of range for IV.  */
1972                         SETn( -(NV)result );
1973                     }
1974                 }
1975                 RETURN;
1976             } /* Overflow, drop through to NVs.  */
1977         }
1978     }
1979 #else
1980     useleft = USE_LEFT(svl);
1981 #endif
1982     {
1983         NV value = SvNV_nomg(svr);
1984         (void)POPs;
1985
1986         if (!useleft) {
1987             /* left operand is undef, treat as zero - value */
1988             SETn(-value);
1989             RETURN;
1990         }
1991         SETn( SvNV_nomg(svl) - value );
1992         RETURN;
1993     }
1994 }
1995
1996 #define IV_BITS (IVSIZE * 8)
1997
1998 static UV S_uv_shift(UV uv, int shift, bool left)
1999 {
2000    if (shift < 0) {
2001        shift = -shift;
2002        left = !left;
2003    }
2004    if (shift >= IV_BITS) {
2005        return 0;
2006    }
2007    return left ? uv << shift : uv >> shift;
2008 }
2009
2010 static IV S_iv_shift(IV iv, int shift, bool left)
2011 {
2012    if (shift < 0) {
2013        shift = -shift;
2014        left = !left;
2015    }
2016    if (shift >= IV_BITS) {
2017        return iv < 0 && !left ? -1 : 0;
2018    }
2019    return left ? iv << shift : iv >> shift;
2020 }
2021
2022 #define UV_LEFT_SHIFT(uv, shift) S_uv_shift(uv, shift, TRUE)
2023 #define UV_RIGHT_SHIFT(uv, shift) S_uv_shift(uv, shift, FALSE)
2024 #define IV_LEFT_SHIFT(iv, shift) S_iv_shift(iv, shift, TRUE)
2025 #define IV_RIGHT_SHIFT(iv, shift) S_iv_shift(iv, shift, FALSE)
2026
2027 PP(pp_left_shift)
2028 {
2029     dSP; dATARGET; SV *svl, *svr;
2030     tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
2031     svr = POPs;
2032     svl = TOPs;
2033     {
2034       const IV shift = SvIV_nomg(svr);
2035       if (PL_op->op_private & HINT_INTEGER) {
2036           SETi(IV_LEFT_SHIFT(SvIV_nomg(svl), shift));
2037       }
2038       else {
2039           SETu(UV_LEFT_SHIFT(SvUV_nomg(svl), shift));
2040       }
2041       RETURN;
2042     }
2043 }
2044
2045 PP(pp_right_shift)
2046 {
2047     dSP; dATARGET; SV *svl, *svr;
2048     tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
2049     svr = POPs;
2050     svl = TOPs;
2051     {
2052       const IV shift = SvIV_nomg(svr);
2053       if (PL_op->op_private & HINT_INTEGER) {
2054           SETi(IV_RIGHT_SHIFT(SvIV_nomg(svl), shift));
2055       }
2056       else {
2057           SETu(UV_RIGHT_SHIFT(SvUV_nomg(svl), shift));
2058       }
2059       RETURN;
2060     }
2061 }
2062
2063 PP(pp_lt)
2064 {
2065     dSP;
2066     SV *left, *right;
2067
2068     tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
2069     right = POPs;
2070     left  = TOPs;
2071     SETs(boolSV(
2072         (SvIOK_notUV(left) && SvIOK_notUV(right))
2073         ? (SvIVX(left) < SvIVX(right))
2074         : (do_ncmp(left, right) == -1)
2075     ));
2076     RETURN;
2077 }
2078
2079 PP(pp_gt)
2080 {
2081     dSP;
2082     SV *left, *right;
2083
2084     tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
2085     right = POPs;
2086     left  = TOPs;
2087     SETs(boolSV(
2088         (SvIOK_notUV(left) && SvIOK_notUV(right))
2089         ? (SvIVX(left) > SvIVX(right))
2090         : (do_ncmp(left, right) == 1)
2091     ));
2092     RETURN;
2093 }
2094
2095 PP(pp_le)
2096 {
2097     dSP;
2098     SV *left, *right;
2099
2100     tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
2101     right = POPs;
2102     left  = TOPs;
2103     SETs(boolSV(
2104         (SvIOK_notUV(left) && SvIOK_notUV(right))
2105         ? (SvIVX(left) <= SvIVX(right))
2106         : (do_ncmp(left, right) <= 0)
2107     ));
2108     RETURN;
2109 }
2110
2111 PP(pp_ge)
2112 {
2113     dSP;
2114     SV *left, *right;
2115
2116     tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
2117     right = POPs;
2118     left  = TOPs;
2119     SETs(boolSV(
2120         (SvIOK_notUV(left) && SvIOK_notUV(right))
2121         ? (SvIVX(left) >= SvIVX(right))
2122         : ( (do_ncmp(left, right) & 2) == 0)
2123     ));
2124     RETURN;
2125 }
2126
2127 PP(pp_ne)
2128 {
2129     dSP;
2130     SV *left, *right;
2131
2132     tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
2133     right = POPs;
2134     left  = TOPs;
2135     SETs(boolSV(
2136         (SvIOK_notUV(left) && SvIOK_notUV(right))
2137         ? (SvIVX(left) != SvIVX(right))
2138         : (do_ncmp(left, right) != 0)
2139     ));
2140     RETURN;
2141 }
2142
2143 /* compare left and right SVs. Returns:
2144  * -1: <
2145  *  0: ==
2146  *  1: >
2147  *  2: left or right was a NaN
2148  */
2149 I32
2150 Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
2151 {
2152     PERL_ARGS_ASSERT_DO_NCMP;
2153 #ifdef PERL_PRESERVE_IVUV
2154     /* Fortunately it seems NaN isn't IOK */
2155     if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
2156             if (!SvUOK(left)) {
2157                 const IV leftiv = SvIVX(left);
2158                 if (!SvUOK(right)) {
2159                     /* ## IV <=> IV ## */
2160                     const IV rightiv = SvIVX(right);
2161                     return (leftiv > rightiv) - (leftiv < rightiv);
2162                 }
2163                 /* ## IV <=> UV ## */
2164                 if (leftiv < 0)
2165                     /* As (b) is a UV, it's >=0, so it must be < */
2166                     return -1;
2167                 {
2168                     const UV rightuv = SvUVX(right);
2169                     return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
2170                 }
2171             }
2172
2173             if (SvUOK(right)) {
2174                 /* ## UV <=> UV ## */
2175                 const UV leftuv = SvUVX(left);
2176                 const UV rightuv = SvUVX(right);
2177                 return (leftuv > rightuv) - (leftuv < rightuv);
2178             }
2179             /* ## UV <=> IV ## */
2180             {
2181                 const IV rightiv = SvIVX(right);
2182                 if (rightiv < 0)
2183                     /* As (a) is a UV, it's >=0, so it cannot be < */
2184                     return 1;
2185                 {
2186                     const UV leftuv = SvUVX(left);
2187                     return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
2188                 }
2189             }
2190             NOT_REACHED; /* NOTREACHED */
2191     }
2192 #endif
2193     {
2194       NV const rnv = SvNV_nomg(right);
2195       NV const lnv = SvNV_nomg(left);
2196
2197 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2198       if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2199           return 2;
2200        }
2201       return (lnv > rnv) - (lnv < rnv);
2202 #else
2203       if (lnv < rnv)
2204         return -1;
2205       if (lnv > rnv)
2206         return 1;
2207       if (lnv == rnv)
2208         return 0;
2209       return 2;
2210 #endif
2211     }
2212 }
2213
2214
2215 PP(pp_ncmp)
2216 {
2217     dSP;
2218     SV *left, *right;
2219     I32 value;
2220     tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
2221     right = POPs;
2222     left  = TOPs;
2223     value = do_ncmp(left, right);
2224     if (value == 2) {
2225         SETs(&PL_sv_undef);
2226     }
2227     else {
2228         dTARGET;
2229         SETi(value);
2230     }
2231     RETURN;
2232 }
2233
2234
2235 /* also used for: pp_sge() pp_sgt() pp_slt() */
2236
2237 PP(pp_sle)
2238 {
2239     dSP;
2240
2241     int amg_type = sle_amg;
2242     int multiplier = 1;
2243     int rhs = 1;
2244
2245     switch (PL_op->op_type) {
2246     case OP_SLT:
2247         amg_type = slt_amg;
2248         /* cmp < 0 */
2249         rhs = 0;
2250         break;
2251     case OP_SGT:
2252         amg_type = sgt_amg;
2253         /* cmp > 0 */
2254         multiplier = -1;
2255         rhs = 0;
2256         break;
2257     case OP_SGE:
2258         amg_type = sge_amg;
2259         /* cmp >= 0 */
2260         multiplier = -1;
2261         break;
2262     }
2263
2264     tryAMAGICbin_MG(amg_type, AMGf_set);
2265     {
2266       dPOPTOPssrl;
2267       const int cmp =
2268 #ifdef USE_LOCALE_COLLATE
2269                       (IN_LC_RUNTIME(LC_COLLATE))
2270                       ? sv_cmp_locale_flags(left, right, 0)
2271                       :
2272 #endif
2273                         sv_cmp_flags(left, right, 0);
2274       SETs(boolSV(cmp * multiplier < rhs));
2275       RETURN;
2276     }
2277 }
2278
2279 PP(pp_seq)
2280 {
2281     dSP;
2282     tryAMAGICbin_MG(seq_amg, AMGf_set);
2283     {
2284       dPOPTOPssrl;
2285       SETs(boolSV(sv_eq_flags(left, right, 0)));
2286       RETURN;
2287     }
2288 }
2289
2290 PP(pp_sne)
2291 {
2292     dSP;
2293     tryAMAGICbin_MG(sne_amg, AMGf_set);
2294     {
2295       dPOPTOPssrl;
2296       SETs(boolSV(!sv_eq_flags(left, right, 0)));
2297       RETURN;
2298     }
2299 }
2300
2301 PP(pp_scmp)
2302 {
2303     dSP; dTARGET;
2304     tryAMAGICbin_MG(scmp_amg, 0);
2305     {
2306       dPOPTOPssrl;
2307       const int cmp =
2308 #ifdef USE_LOCALE_COLLATE
2309                       (IN_LC_RUNTIME(LC_COLLATE))
2310                       ? sv_cmp_locale_flags(left, right, 0)
2311                       :
2312 #endif
2313                         sv_cmp_flags(left, right, 0);
2314       SETi( cmp );
2315       RETURN;
2316     }
2317 }
2318
2319 PP(pp_bit_and)
2320 {
2321     dSP; dATARGET;
2322     tryAMAGICbin_MG(band_amg, AMGf_assign);
2323     {
2324       dPOPTOPssrl;
2325       if (SvNIOKp(left) || SvNIOKp(right)) {
2326         const bool left_ro_nonnum  = !SvNIOKp(left) && SvREADONLY(left);
2327         const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2328         if (PL_op->op_private & HINT_INTEGER) {
2329           const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2330           SETi(i);
2331         }
2332         else {
2333           const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2334           SETu(u);
2335         }
2336         if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2337         if (right_ro_nonnum) SvNIOK_off(right);
2338       }
2339       else {
2340         do_vop(PL_op->op_type, TARG, left, right);
2341         SETTARG;
2342       }
2343       RETURN;
2344     }
2345 }
2346
2347 PP(pp_nbit_and)
2348 {
2349     dSP;
2350     tryAMAGICbin_MG(band_amg, AMGf_assign|AMGf_numarg);
2351     {
2352         dATARGET; dPOPTOPssrl;
2353         if (PL_op->op_private & HINT_INTEGER) {
2354           const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2355           SETi(i);
2356         }
2357         else {
2358           const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2359           SETu(u);
2360         }
2361     }
2362     RETURN;
2363 }
2364
2365 PP(pp_sbit_and)
2366 {
2367     dSP;
2368     tryAMAGICbin_MG(sband_amg, AMGf_assign);
2369     {
2370         dATARGET; dPOPTOPssrl;
2371         do_vop(OP_BIT_AND, TARG, left, right);
2372         RETSETTARG;
2373     }
2374 }
2375
2376 /* also used for: pp_bit_xor() */
2377
2378 PP(pp_bit_or)
2379 {
2380     dSP; dATARGET;
2381     const int op_type = PL_op->op_type;
2382
2383     tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2384     {
2385       dPOPTOPssrl;
2386       if (SvNIOKp(left) || SvNIOKp(right)) {
2387         const bool left_ro_nonnum  = !SvNIOKp(left) && SvREADONLY(left);
2388         const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2389         if (PL_op->op_private & HINT_INTEGER) {
2390           const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2391           const IV r = SvIV_nomg(right);
2392           const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2393           SETi(result);
2394         }
2395         else {
2396           const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2397           const UV r = SvUV_nomg(right);
2398           const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2399           SETu(result);
2400         }
2401         if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2402         if (right_ro_nonnum) SvNIOK_off(right);
2403       }
2404       else {
2405         do_vop(op_type, TARG, left, right);
2406         SETTARG;
2407       }
2408       RETURN;
2409     }
2410 }
2411
2412 /* also used for: pp_nbit_xor() */
2413
2414 PP(pp_nbit_or)
2415 {
2416     dSP;
2417     const int op_type = PL_op->op_type;
2418
2419     tryAMAGICbin_MG((op_type == OP_NBIT_OR ? bor_amg : bxor_amg),
2420                     AMGf_assign|AMGf_numarg);
2421     {
2422         dATARGET; dPOPTOPssrl;
2423         if (PL_op->op_private & HINT_INTEGER) {
2424           const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2425           const IV r = SvIV_nomg(right);
2426           const IV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2427           SETi(result);
2428         }
2429         else {
2430           const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2431           const UV r = SvUV_nomg(right);
2432           const UV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2433           SETu(result);
2434         }
2435     }
2436     RETURN;
2437 }
2438
2439 /* also used for: pp_sbit_xor() */
2440
2441 PP(pp_sbit_or)
2442 {
2443     dSP;
2444     const int op_type = PL_op->op_type;
2445
2446     tryAMAGICbin_MG((op_type == OP_SBIT_OR ? sbor_amg : sbxor_amg),
2447                     AMGf_assign);
2448     {
2449         dATARGET; dPOPTOPssrl;
2450         do_vop(op_type == OP_SBIT_OR ? OP_BIT_OR : OP_BIT_XOR, TARG, left,
2451                right);
2452         RETSETTARG;
2453     }
2454 }
2455
2456 PERL_STATIC_INLINE bool
2457 S_negate_string(pTHX)
2458 {
2459     dTARGET; dSP;
2460     STRLEN len;
2461     const char *s;
2462     SV * const sv = TOPs;
2463     if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2464         return FALSE;
2465     s = SvPV_nomg_const(sv, len);
2466     if (isIDFIRST(*s)) {
2467         sv_setpvs(TARG, "-");
2468         sv_catsv(TARG, sv);
2469     }
2470     else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2471         sv_setsv_nomg(TARG, sv);
2472         *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2473     }
2474     else return FALSE;
2475     SETTARG;
2476     return TRUE;
2477 }
2478
2479 PP(pp_negate)
2480 {
2481     dSP; dTARGET;
2482     tryAMAGICun_MG(neg_amg, AMGf_numeric);
2483     if (S_negate_string(aTHX)) return NORMAL;
2484     {
2485         SV * const sv = TOPs;
2486
2487         if (SvIOK(sv)) {
2488             /* It's publicly an integer */
2489         oops_its_an_int:
2490             if (SvIsUV(sv)) {
2491                 if (SvIVX(sv) == IV_MIN) {
2492                     /* 2s complement assumption. */
2493                     SETi(SvIVX(sv));    /* special case: -((UV)IV_MAX+1) ==
2494                                            IV_MIN */
2495                     return NORMAL;
2496                 }
2497                 else if (SvUVX(sv) <= IV_MAX) {
2498                     SETi(-SvIVX(sv));
2499                     return NORMAL;
2500                 }
2501             }
2502             else if (SvIVX(sv) != IV_MIN) {
2503                 SETi(-SvIVX(sv));
2504                 return NORMAL;
2505             }
2506 #ifdef PERL_PRESERVE_IVUV
2507             else {
2508                 SETu((UV)IV_MIN);
2509                 return NORMAL;
2510             }
2511 #endif
2512         }
2513         if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
2514             SETn(-SvNV_nomg(sv));
2515         else if (SvPOKp(sv) && SvIV_please_nomg(sv))
2516                   goto oops_its_an_int;
2517         else
2518             SETn(-SvNV_nomg(sv));
2519     }
2520     return NORMAL;
2521 }
2522
2523 PP(pp_not)
2524 {
2525     dSP;
2526     SV *sv;
2527
2528     tryAMAGICun_MG(not_amg, AMGf_set);
2529     sv = *PL_stack_sp;
2530     *PL_stack_sp = boolSV(!SvTRUE_nomg_NN(sv));
2531     return NORMAL;
2532 }
2533
2534 static void
2535 S_scomplement(pTHX_ SV *targ, SV *sv)
2536 {
2537         U8 *tmps;
2538         I32 anum;
2539         STRLEN len;
2540
2541         sv_copypv_nomg(TARG, sv);
2542         tmps = (U8*)SvPV_nomg(TARG, len);
2543
2544         if (SvUTF8(TARG)) {
2545             if (len && ! utf8_to_bytes(tmps, &len)) {
2546                 Perl_croak(aTHX_ fatal_above_ff_msg, PL_op_desc[PL_op->op_type]);
2547             }
2548             SvCUR(TARG) = len;
2549             SvUTF8_off(TARG);
2550         }
2551
2552         anum = len;
2553
2554 #ifdef LIBERAL
2555         {
2556             long *tmpl;
2557             for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2558                 *tmps = ~*tmps;
2559             tmpl = (long*)tmps;
2560             for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2561                 *tmpl = ~*tmpl;
2562             tmps = (U8*)tmpl;
2563         }
2564 #endif
2565         for ( ; anum > 0; anum--, tmps++)
2566             *tmps = ~*tmps;
2567 }
2568
2569 PP(pp_complement)
2570 {
2571     dSP; dTARGET;
2572     tryAMAGICun_MG(compl_amg, AMGf_numeric);
2573     {
2574       dTOPss;
2575       if (SvNIOKp(sv)) {
2576         if (PL_op->op_private & HINT_INTEGER) {
2577           const IV i = ~SvIV_nomg(sv);
2578           SETi(i);
2579         }
2580         else {
2581           const UV u = ~SvUV_nomg(sv);
2582           SETu(u);
2583         }
2584       }
2585       else {
2586         S_scomplement(aTHX_ TARG, sv);
2587         SETTARG;
2588       }
2589       return NORMAL;
2590     }
2591 }
2592
2593 PP(pp_ncomplement)
2594 {
2595     dSP;
2596     tryAMAGICun_MG(compl_amg, AMGf_numeric|AMGf_numarg);
2597     {
2598         dTARGET; dTOPss;
2599         if (PL_op->op_private & HINT_INTEGER) {
2600           const IV i = ~SvIV_nomg(sv);
2601           SETi(i);
2602         }
2603         else {
2604           const UV u = ~SvUV_nomg(sv);
2605           SETu(u);
2606         }
2607     }
2608     return NORMAL;
2609 }
2610
2611 PP(pp_scomplement)
2612 {
2613     dSP;
2614     tryAMAGICun_MG(scompl_amg, AMGf_numeric);
2615     {
2616         dTARGET; dTOPss;
2617         S_scomplement(aTHX_ TARG, sv);
2618         SETTARG;
2619         return NORMAL;
2620     }
2621 }
2622
2623 /* integer versions of some of the above */
2624
2625 PP(pp_i_multiply)
2626 {
2627     dSP; dATARGET;
2628     tryAMAGICbin_MG(mult_amg, AMGf_assign);
2629     {
2630       dPOPTOPiirl_nomg;
2631       SETi( left * right );
2632       RETURN;
2633     }
2634 }
2635
2636 PP(pp_i_divide)
2637 {
2638     IV num;
2639     dSP; dATARGET;
2640     tryAMAGICbin_MG(div_amg, AMGf_assign);
2641     {
2642       dPOPTOPssrl;
2643       IV value = SvIV_nomg(right);
2644       if (value == 0)
2645           DIE(aTHX_ "Illegal division by zero");
2646       num = SvIV_nomg(left);
2647
2648       /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2649       if (value == -1)
2650           value = - num;
2651       else
2652           value = num / value;
2653       SETi(value);
2654       RETURN;
2655     }
2656 }
2657
2658 PP(pp_i_modulo)
2659 {
2660      /* This is the vanilla old i_modulo. */
2661      dSP; dATARGET;
2662      tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2663      {
2664           dPOPTOPiirl_nomg;
2665           if (!right)
2666                DIE(aTHX_ "Illegal modulus zero");
2667           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2668           if (right == -1)
2669               SETi( 0 );
2670           else
2671               SETi( left % right );
2672           RETURN;
2673      }
2674 }
2675
2676 #if defined(__GLIBC__) && IVSIZE == 8 \
2677     && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
2678
2679 PP(pp_i_modulo_glibc_bugfix)
2680 {
2681      /* This is the i_modulo with the workaround for the _moddi3 bug
2682       * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2683       * See below for pp_i_modulo. */
2684      dSP; dATARGET;
2685      tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2686      {
2687           dPOPTOPiirl_nomg;
2688           if (!right)
2689                DIE(aTHX_ "Illegal modulus zero");
2690           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2691           if (right == -1)
2692               SETi( 0 );
2693           else
2694               SETi( left % PERL_ABS(right) );
2695           RETURN;
2696      }
2697 }
2698 #endif
2699
2700 PP(pp_i_add)
2701 {
2702     dSP; dATARGET;
2703     tryAMAGICbin_MG(add_amg, AMGf_assign);
2704     {
2705       dPOPTOPiirl_ul_nomg;
2706       SETi( left + right );
2707       RETURN;
2708     }
2709 }
2710
2711 PP(pp_i_subtract)
2712 {
2713     dSP; dATARGET;
2714     tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2715     {
2716       dPOPTOPiirl_ul_nomg;
2717       SETi( left - right );
2718       RETURN;
2719     }
2720 }
2721
2722 PP(pp_i_lt)
2723 {
2724     dSP;
2725     tryAMAGICbin_MG(lt_amg, AMGf_set);
2726     {
2727       dPOPTOPiirl_nomg;
2728       SETs(boolSV(left < right));
2729       RETURN;
2730     }
2731 }
2732
2733 PP(pp_i_gt)
2734 {
2735     dSP;
2736     tryAMAGICbin_MG(gt_amg, AMGf_set);
2737     {
2738       dPOPTOPiirl_nomg;
2739       SETs(boolSV(left > right));
2740       RETURN;
2741     }
2742 }
2743
2744 PP(pp_i_le)
2745 {
2746     dSP;
2747     tryAMAGICbin_MG(le_amg, AMGf_set);
2748     {
2749       dPOPTOPiirl_nomg;
2750       SETs(boolSV(left <= right));
2751       RETURN;
2752     }
2753 }
2754
2755 PP(pp_i_ge)
2756 {
2757     dSP;
2758     tryAMAGICbin_MG(ge_amg, AMGf_set);
2759     {
2760       dPOPTOPiirl_nomg;
2761       SETs(boolSV(left >= right));
2762       RETURN;
2763     }
2764 }
2765
2766 PP(pp_i_eq)
2767 {
2768     dSP;
2769     tryAMAGICbin_MG(eq_amg, AMGf_set);
2770     {
2771       dPOPTOPiirl_nomg;
2772       SETs(boolSV(left == right));
2773       RETURN;
2774     }
2775 }
2776
2777 PP(pp_i_ne)
2778 {
2779     dSP;
2780     tryAMAGICbin_MG(ne_amg, AMGf_set);
2781     {
2782       dPOPTOPiirl_nomg;
2783       SETs(boolSV(left != right));
2784       RETURN;
2785     }
2786 }
2787
2788 PP(pp_i_ncmp)
2789 {
2790     dSP; dTARGET;
2791     tryAMAGICbin_MG(ncmp_amg, 0);
2792     {
2793       dPOPTOPiirl_nomg;
2794       I32 value;
2795
2796       if (left > right)
2797         value = 1;
2798       else if (left < right)
2799         value = -1;
2800       else
2801         value = 0;
2802       SETi(value);
2803       RETURN;
2804     }
2805 }
2806
2807 PP(pp_i_negate)
2808 {
2809     dSP; dTARGET;
2810     tryAMAGICun_MG(neg_amg, 0);
2811     if (S_negate_string(aTHX)) return NORMAL;
2812     {
2813         SV * const sv = TOPs;
2814         IV const i = SvIV_nomg(sv);
2815         SETi(-i);
2816         return NORMAL;
2817     }
2818 }
2819
2820 /* High falutin' math. */
2821
2822 PP(pp_atan2)
2823 {
2824     dSP; dTARGET;
2825     tryAMAGICbin_MG(atan2_amg, 0);
2826     {
2827       dPOPTOPnnrl_nomg;
2828       SETn(Perl_atan2(left, right));
2829       RETURN;
2830     }
2831 }
2832
2833
2834 /* also used for: pp_cos() pp_exp() pp_log() pp_sqrt() */
2835
2836 PP(pp_sin)
2837 {
2838     dSP; dTARGET;
2839     int amg_type = fallback_amg;
2840     const char *neg_report = NULL;
2841     const int op_type = PL_op->op_type;
2842
2843     switch (op_type) {
2844     case OP_SIN:  amg_type = sin_amg; break;
2845     case OP_COS:  amg_type = cos_amg; break;
2846     case OP_EXP:  amg_type = exp_amg; break;
2847     case OP_LOG:  amg_type = log_amg;  neg_report = "log";  break;
2848     case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break;
2849     }
2850
2851     assert(amg_type != fallback_amg);
2852
2853     tryAMAGICun_MG(amg_type, 0);
2854     {
2855       SV * const arg = TOPs;
2856       const NV value = SvNV_nomg(arg);
2857 #ifdef NV_NAN
2858       NV result = NV_NAN;
2859 #else
2860       NV result = 0.0;
2861 #endif
2862       if (neg_report) { /* log or sqrt */
2863           if (
2864 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2865               ! Perl_isnan(value) &&
2866 #endif
2867               (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0))) {
2868               SET_NUMERIC_STANDARD();
2869               /* diag_listed_as: Can't take log of %g */
2870               DIE(aTHX_ "Can't take %s of %" NVgf, neg_report, value);
2871           }
2872       }
2873       switch (op_type) {
2874       default:
2875       case OP_SIN:  result = Perl_sin(value);  break;
2876       case OP_COS:  result = Perl_cos(value);  break;
2877       case OP_EXP:  result = Perl_exp(value);  break;
2878       case OP_LOG:  result = Perl_log(value);  break;
2879       case OP_SQRT: result = Perl_sqrt(value); break;
2880       }
2881       SETn(result);
2882       return NORMAL;
2883     }
2884 }
2885
2886 /* Support Configure command-line overrides for rand() functions.
2887    After 5.005, perhaps we should replace this by Configure support
2888    for drand48(), random(), or rand().  For 5.005, though, maintain
2889    compatibility by calling rand() but allow the user to override it.
2890    See INSTALL for details.  --Andy Dougherty  15 July 1998
2891 */
2892 /* Now it's after 5.005, and Configure supports drand48() and random(),
2893    in addition to rand().  So the overrides should not be needed any more.
2894    --Jarkko Hietaniemi  27 September 1998
2895  */
2896
2897 PP(pp_rand)
2898 {
2899     if (!PL_srand_called) {
2900         (void)seedDrand01((Rand_seed_t)seed());
2901         PL_srand_called = TRUE;
2902     }
2903     {
2904         dSP;
2905         NV value;
2906
2907         if (MAXARG < 1)
2908         {
2909             EXTEND(SP, 1);
2910             value = 1.0;
2911         }
2912         else {
2913             SV * const sv = POPs;
2914             if(!sv)
2915                 value = 1.0;
2916             else
2917                 value = SvNV(sv);
2918         }
2919     /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
2920 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2921         if (! Perl_isnan(value) && value == 0.0)
2922 #else
2923         if (value == 0.0)
2924 #endif
2925             value = 1.0;
2926         {
2927             dTARGET;
2928             PUSHs(TARG);
2929             PUTBACK;
2930             value *= Drand01();
2931             sv_setnv_mg(TARG, value);
2932         }
2933     }
2934     return NORMAL;
2935 }
2936
2937 PP(pp_srand)
2938 {
2939     dSP; dTARGET;
2940     UV anum;
2941
2942     if (MAXARG >= 1 && (TOPs || POPs)) {
2943         SV *top;
2944         char *pv;
2945         STRLEN len;
2946         int flags;
2947
2948         top = POPs;
2949         pv = SvPV(top, len);
2950         flags = grok_number(pv, len, &anum);
2951
2952         if (!(flags & IS_NUMBER_IN_UV)) {
2953             Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
2954                              "Integer overflow in srand");
2955             anum = UV_MAX;
2956         }
2957     }
2958     else {
2959         anum = seed();
2960     }
2961
2962     (void)seedDrand01((Rand_seed_t)anum);
2963     PL_srand_called = TRUE;
2964     if (anum)
2965         XPUSHu(anum);
2966     else {
2967         /* Historically srand always returned true. We can avoid breaking
2968            that like this:  */
2969         sv_setpvs(TARG, "0 but true");
2970         XPUSHTARG;
2971     }
2972     RETURN;
2973 }
2974
2975 PP(pp_int)
2976 {
2977     dSP; dTARGET;
2978     tryAMAGICun_MG(int_amg, AMGf_numeric);
2979     {
2980       SV * const sv = TOPs;
2981       const IV iv = SvIV_nomg(sv);
2982       /* XXX it's arguable that compiler casting to IV might be subtly
2983          different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2984          else preferring IV has introduced a subtle behaviour change bug. OTOH
2985          relying on floating point to be accurate is a bug.  */
2986
2987       if (!SvOK(sv)) {
2988         SETu(0);
2989       }
2990       else if (SvIOK(sv)) {
2991         if (SvIsUV(sv))
2992             SETu(SvUV_nomg(sv));
2993         else
2994             SETi(iv);
2995       }
2996       else {
2997           const NV value = SvNV_nomg(sv);
2998           if (UNLIKELY(Perl_isinfnan(value)))
2999               SETn(value);
3000           else if (value >= 0.0) {
3001               if (value < (NV)UV_MAX + 0.5) {
3002                   SETu(U_V(value));
3003               } else {
3004                   SETn(Perl_floor(value));
3005               }
3006           }
3007           else {
3008               if (value > (NV)IV_MIN - 0.5) {
3009                   SETi(I_V(value));
3010               } else {
3011                   SETn(Perl_ceil(value));
3012               }
3013           }
3014       }
3015     }
3016     return NORMAL;
3017 }
3018
3019 PP(pp_abs)
3020 {
3021     dSP; dTARGET;
3022     tryAMAGICun_MG(abs_amg, AMGf_numeric);
3023     {
3024       SV * const sv = TOPs;
3025       /* This will cache the NV value if string isn't actually integer  */
3026       const IV iv = SvIV_nomg(sv);
3027
3028       if (!SvOK(sv)) {
3029         SETu(0);
3030       }
3031       else if (SvIOK(sv)) {
3032         /* IVX is precise  */
3033         if (SvIsUV(sv)) {
3034           SETu(SvUV_nomg(sv));  /* force it to be numeric only */
3035         } else {
3036           if (iv >= 0) {
3037             SETi(iv);
3038           } else {
3039             if (iv != IV_MIN) {
3040               SETi(-iv);
3041             } else {
3042               /* 2s complement assumption. Also, not really needed as
3043                  IV_MIN and -IV_MIN should both be %100...00 and NV-able  */
3044               SETu((UV)IV_MIN);
3045             }
3046           }
3047         }
3048       } else{
3049         const NV value = SvNV_nomg(sv);
3050         if (value < 0.0)
3051           SETn(-value);
3052         else
3053           SETn(value);
3054       }
3055     }
3056     return NORMAL;
3057 }
3058
3059
3060 /* also used for: pp_hex() */
3061
3062 PP(pp_oct)
3063 {
3064     dSP; dTARGET;
3065     const char *tmps;
3066     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
3067     STRLEN len;
3068     NV result_nv;
3069     UV result_uv;
3070     SV* const sv = TOPs;
3071
3072     tmps = (SvPV_const(sv, len));
3073     if (DO_UTF8(sv)) {
3074          /* If Unicode, try to downgrade
3075           * If not possible, croak. */
3076          SV* const tsv = sv_2mortal(newSVsv(sv));
3077
3078          SvUTF8_on(tsv);
3079          sv_utf8_downgrade(tsv, FALSE);
3080          tmps = SvPV_const(tsv, len);
3081     }
3082     if (PL_op->op_type == OP_HEX)
3083         goto hex;
3084
3085     while (*tmps && len && isSPACE(*tmps))
3086         tmps++, len--;
3087     if (*tmps == '0')
3088         tmps++, len--;
3089     if (isALPHA_FOLD_EQ(*tmps, 'x')) {
3090     hex:
3091         result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3092     }
3093     else if (isALPHA_FOLD_EQ(*tmps, 'b'))
3094         result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3095     else
3096         result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3097
3098     if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3099         SETn(result_nv);
3100     }
3101     else {
3102         SETu(result_uv);
3103     }
3104     return NORMAL;
3105 }
3106
3107 /* String stuff. */
3108
3109
3110 PP(pp_length)
3111 {
3112     dSP; dTARGET;
3113     SV * const sv = TOPs;
3114
3115     U32 in_bytes = IN_BYTES;
3116     /* Simplest case shortcut:
3117      * set svflags to just the SVf_POK|SVs_GMG|SVf_UTF8 from the SV,
3118      * with the SVf_UTF8 flag inverted if under 'use bytes' (HINT_BYTES
3119      * set)
3120      */
3121     U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8);
3122
3123     STATIC_ASSERT_STMT(SVf_UTF8 == (HINT_BYTES << 26));
3124     SETs(TARG);
3125
3126     if (LIKELY(svflags == SVf_POK))
3127         goto simple_pv;
3128
3129     if (svflags & SVs_GMG)
3130         mg_get(sv);
3131
3132     if (SvOK(sv)) {
3133         STRLEN len;
3134         if (!IN_BYTES) { /* reread to avoid using an C auto/register */
3135             if ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == SVf_POK)
3136                 goto simple_pv;
3137             if ( SvPOK(sv) && (PL_op->op_private & OPpTRUEBOOL)) {
3138                 /* no need to convert from bytes to chars */
3139                 len = SvCUR(sv);
3140                 goto return_bool;
3141             }
3142             len = sv_len_utf8_nomg(sv);
3143         }
3144         else {
3145             /* unrolled SvPV_nomg_const(sv,len) */
3146             if (SvPOK_nog(sv)) {
3147               simple_pv:
3148                 len = SvCUR(sv);
3149                 if (PL_op->op_private & OPpTRUEBOOL) {
3150                   return_bool:
3151                     SETs(len ? &PL_sv_yes : &PL_sv_zero);
3152                     return NORMAL;
3153                 }
3154             }
3155             else {
3156                 (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN);
3157             }
3158         }
3159         TARGi((IV)(len), 1);
3160     }
3161     else {
3162         if (!SvPADTMP(TARG)) {
3163             /* OPpTARGET_MY: targ is var in '$lex = length()' */
3164             sv_set_undef(TARG);
3165             SvSETMAGIC(TARG);
3166         }
3167         else
3168             /* TARG is on stack at this point and is overwriten by SETs.
3169              * This branch is the odd one out, so put TARG by default on
3170              * stack earlier to let local SP go out of liveness sooner */
3171             SETs(&PL_sv_undef);
3172     }
3173     return NORMAL; /* no putback, SP didn't move in this opcode */
3174 }
3175
3176
3177 /* Returns false if substring is completely outside original string.
3178    No length is indicated by len_iv = 0 and len_is_uv = 0.  len_is_uv must
3179    always be true for an explicit 0.
3180 */
3181 bool
3182 Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv,
3183                                 bool pos1_is_uv, IV len_iv,
3184                                 bool len_is_uv, STRLEN *posp,
3185                                 STRLEN *lenp)
3186 {
3187     IV pos2_iv;
3188     int    pos2_is_uv;
3189
3190     PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
3191
3192     if (!pos1_is_uv && pos1_iv < 0 && curlen) {
3193         pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3194         pos1_iv += curlen;
3195     }
3196     if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
3197         return FALSE;
3198
3199     if (len_iv || len_is_uv) {
3200         if (!len_is_uv && len_iv < 0) {
3201             pos2_iv = curlen + len_iv;
3202             if (curlen)
3203                 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3204             else
3205                 pos2_is_uv = 0;
3206         } else {  /* len_iv >= 0 */
3207             if (!pos1_is_uv && pos1_iv < 0) {
3208                 pos2_iv = pos1_iv + len_iv;
3209                 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3210             } else {
3211                 if ((UV)len_iv > curlen-(UV)pos1_iv)
3212                     pos2_iv = curlen;
3213                 else
3214                     pos2_iv = pos1_iv+len_iv;
3215                 pos2_is_uv = 1;
3216             }
3217         }
3218     }
3219     else {
3220         pos2_iv = curlen;
3221         pos2_is_uv = 1;
3222     }
3223
3224     if (!pos2_is_uv && pos2_iv < 0) {
3225         if (!pos1_is_uv && pos1_iv < 0)
3226             return FALSE;
3227         pos2_iv = 0;
3228     }
3229     else if (!pos1_is_uv && pos1_iv < 0)
3230         pos1_iv = 0;
3231
3232     if ((UV)pos2_iv < (UV)pos1_iv)
3233         pos2_iv = pos1_iv;
3234     if ((UV)pos2_iv > curlen)
3235         pos2_iv = curlen;
3236
3237     /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3238     *posp = (STRLEN)( (UV)pos1_iv );
3239     *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3240
3241     return TRUE;
3242 }
3243
3244 PP(pp_substr)
3245 {
3246     dSP; dTARGET;
3247     SV *sv;
3248     STRLEN curlen;
3249     STRLEN utf8_curlen;
3250     SV *   pos_sv;
3251     IV     pos1_iv;
3252     int    pos1_is_uv;
3253     SV *   len_sv;
3254     IV     len_iv = 0;
3255     int    len_is_uv = 0;
3256     I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3257     const bool rvalue = (GIMME_V != G_VOID);
3258     const char *tmps;
3259     SV *repl_sv = NULL;
3260     const char *repl = NULL;
3261     STRLEN repl_len;
3262     int num_args = PL_op->op_private & 7;
3263     bool repl_need_utf8_upgrade = FALSE;
3264
3265     if (num_args > 2) {
3266         if (num_args > 3) {
3267           if(!(repl_sv = POPs)) num_args--;
3268         }
3269         if ((len_sv = POPs)) {
3270             len_iv    = SvIV(len_sv);
3271             len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
3272         }
3273         else num_args--;
3274     }
3275     pos_sv     = POPs;
3276     pos1_iv    = SvIV(pos_sv);
3277     pos1_is_uv = SvIOK_UV(pos_sv);
3278     sv = POPs;
3279     if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3280         assert(!repl_sv);
3281         repl_sv = POPs;
3282     }
3283     if (lvalue && !repl_sv) {
3284         SV * ret;
3285         ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
3286         sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3287         LvTYPE(ret) = 'x';
3288         LvTARG(ret) = SvREFCNT_inc_simple(sv);
3289         LvTARGOFF(ret) =
3290             pos1_is_uv || pos1_iv >= 0
3291                 ? (STRLEN)(UV)pos1_iv
3292                 : (LvFLAGS(ret) |= LVf_NEG_OFF, (STRLEN)(UV)-pos1_iv);
3293         LvTARGLEN(ret) =
3294             len_is_uv || len_iv > 0
3295                 ? (STRLEN)(UV)len_iv
3296                 : (LvFLAGS(ret) |= LVf_NEG_LEN, (STRLEN)(UV)-len_iv);
3297
3298         PUSHs(ret);    /* avoid SvSETMAGIC here */
3299         RETURN;
3300     }
3301     if (repl_sv) {
3302         repl = SvPV_const(repl_sv, repl_len);
3303         SvGETMAGIC(sv);
3304         if (SvROK(sv))
3305             Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3306                             "Attempt to use reference as lvalue in substr"
3307             );
3308         tmps = SvPV_force_nomg(sv, curlen);
3309         if (DO_UTF8(repl_sv) && repl_len) {
3310             if (!DO_UTF8(sv)) {
3311                 /* Upgrade the dest, and recalculate tmps in case the buffer
3312                  * got reallocated; curlen may also have been changed */
3313                 sv_utf8_upgrade_nomg(sv);
3314                 tmps = SvPV_nomg(sv, curlen);
3315             }
3316         }
3317         else if (DO_UTF8(sv))
3318             repl_need_utf8_upgrade = TRUE;
3319     }
3320     else tmps = SvPV_const(sv, curlen);
3321     if (DO_UTF8(sv)) {
3322         utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
3323         if (utf8_curlen == curlen)
3324             utf8_curlen = 0;
3325         else
3326             curlen = utf8_curlen;
3327     }
3328     else
3329         utf8_curlen = 0;
3330
3331     {
3332         STRLEN pos, len, byte_len, byte_pos;
3333
3334         if (!translate_substr_offsets(
3335                 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3336         )) goto bound_fail;
3337
3338         byte_len = len;
3339         byte_pos = utf8_curlen
3340             ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
3341
3342         tmps += byte_pos;
3343
3344         if (rvalue) {
3345             SvTAINTED_off(TARG);                        /* decontaminate */
3346             SvUTF8_off(TARG);                   /* decontaminate */
3347             sv_setpvn(TARG, tmps, byte_len);
3348 #ifdef USE_LOCALE_COLLATE
3349             sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3350 #endif
3351             if (utf8_curlen)
3352                 SvUTF8_on(TARG);
3353         }
3354
3355         if (repl) {
3356             SV* repl_sv_copy = NULL;
3357
3358             if (repl_need_utf8_upgrade) {
3359                 repl_sv_copy = newSVsv(repl_sv);
3360                 sv_utf8_upgrade(repl_sv_copy);
3361                 repl = SvPV_const(repl_sv_copy, repl_len);
3362             }
3363             if (!SvOK(sv))
3364                 SvPVCLEAR(sv);
3365             sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3366             SvREFCNT_dec(repl_sv_copy);
3367         }
3368     }
3369     if (PL_op->op_private & OPpSUBSTR_REPL_FIRST)
3370         SP++;
3371     else if (rvalue) {
3372         SvSETMAGIC(TARG);
3373         PUSHs(TARG);
3374     }
3375     RETURN;
3376
3377   bound_fail:
3378     if (repl)
3379         Perl_croak(aTHX_ "substr outside of string");
3380     Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3381     RETPUSHUNDEF;
3382 }
3383
3384 PP(pp_vec)
3385 {
3386     dSP;
3387     const IV size   = POPi;
3388     SV* offsetsv   = POPs;
3389     SV * const src = POPs;
3390     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3391     SV * ret;
3392     UV   retuv;
3393     STRLEN offset = 0;
3394     char errflags = 0;
3395
3396     /* extract a STRLEN-ranged integer value from offsetsv into offset,
3397      * or flag that its out of range */
3398     {
3399         IV iv = SvIV(offsetsv);
3400
3401         /* avoid a large UV being wrapped to a negative value */
3402         if (SvIOK_UV(offsetsv) && SvUVX(offsetsv) > (UV)IV_MAX)
3403             errflags = LVf_OUT_OF_RANGE;
3404         else if (iv < 0)
3405             errflags = (LVf_NEG_OFF|LVf_OUT_OF_RANGE);
3406 #if PTRSIZE < IVSIZE
3407         else if (iv > Size_t_MAX)
3408             errflags = LVf_OUT_OF_RANGE;
3409 #endif
3410         else
3411             offset = (STRLEN)iv;
3412     }
3413
3414     retuv = errflags ? 0 : do_vecget(src, offset, size);
3415
3416     if (lvalue) {                       /* it's an lvalue! */
3417         ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
3418         sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3419         LvTYPE(ret) = 'v';
3420         LvTARG(ret) = SvREFCNT_inc_simple(src);
3421         LvTARGOFF(ret) = offset;
3422         LvTARGLEN(ret) = size;
3423         LvFLAGS(ret)   = errflags;
3424     }
3425     else {
3426         dTARGET;
3427         SvTAINTED_off(TARG);            /* decontaminate */
3428         ret = TARG;
3429     }
3430
3431     sv_setuv(ret, retuv);
3432     if (!lvalue)
3433         SvSETMAGIC(ret);
3434     PUSHs(ret);
3435     RETURN;
3436 }
3437
3438
3439 /* also used for: pp_rindex() */
3440
3441 PP(pp_index)
3442 {
3443     dSP; dTARGET;
3444     SV *big;
3445     SV *little;
3446     SV *temp = NULL;
3447     STRLEN biglen;
3448     STRLEN llen = 0;
3449     SSize_t offset = 0;
3450     SSize_t retval;
3451     const char *big_p;
3452     const char *little_p;
3453     bool big_utf8;
3454     bool little_utf8;
3455     const bool is_index = PL_op->op_type == OP_INDEX;
3456     const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
3457
3458     if (threeargs)
3459         offset = POPi;
3460     little = POPs;
3461     big = POPs;
3462     big_p = SvPV_const(big, biglen);
3463     little_p = SvPV_const(little, llen);
3464
3465     big_utf8 = DO_UTF8(big);
3466     little_utf8 = DO_UTF8(little);
3467     if (big_utf8 ^ little_utf8) {
3468         /* One needs to be upgraded.  */
3469         if (little_utf8) {
3470             /* Well, maybe instead we might be able to downgrade the small
3471                string?  */
3472             char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3473                                                      &little_utf8);
3474             if (little_utf8) {
3475                 /* If the large string is ISO-8859-1, and it's not possible to
3476                    convert the small string to ISO-8859-1, then there is no
3477                    way that it could be found anywhere by index.  */
3478                 retval = -1;
3479                 goto push_result;
3480             }
3481
3482             /* At this point, pv is a malloc()ed string. So donate it to temp
3483                to ensure it will get free()d  */
3484             little = temp = newSV(0);
3485             sv_usepvn(temp, pv, llen);
3486             little_p = SvPVX(little);
3487         } else {
3488             temp = newSVpvn(little_p, llen);
3489
3490             sv_utf8_upgrade(temp);
3491             little = temp;
3492             little_p = SvPV_const(little, llen);
3493         }
3494     }
3495     if (SvGAMAGIC(big)) {
3496         /* Life just becomes a lot easier if I use a temporary here.
3497            Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3498            will trigger magic and overloading again, as will fbm_instr()
3499         */
3500         big = newSVpvn_flags(big_p, biglen,
3501                              SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3502         big_p = SvPVX(big);
3503     }
3504     if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3505         /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3506            warn on undef, and we've already triggered a warning with the
3507            SvPV_const some lines above. We can't remove that, as we need to
3508            call some SvPV to trigger overloading early and find out if the
3509            string is UTF-8.
3510            This is all getting too messy. The API isn't quite clean enough,
3511            because data access has side effects.
3512         */
3513         little = newSVpvn_flags(little_p, llen,
3514                                 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3515         little_p = SvPVX(little);
3516     }
3517
3518     if (!threeargs)
3519         offset = is_index ? 0 : biglen;
3520     else {
3521         if (big_utf8 && offset > 0)
3522             offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
3523         if (!is_index)
3524             offset += llen;
3525     }
3526     if (offset < 0)
3527         offset = 0;
3528     else if (offset > (SSize_t)biglen)
3529         offset = biglen;
3530     if (!(little_p = is_index
3531           ? fbm_instr((unsigned char*)big_p + offset,
3532                       (unsigned char*)big_p + biglen, little, 0)
3533           : rninstr(big_p,  big_p  + offset,
3534                     little_p, little_p + llen)))
3535         retval = -1;
3536     else {
3537         retval = little_p - big_p;
3538         if (retval > 1 && big_utf8)
3539             retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
3540     }
3541     SvREFCNT_dec(temp);
3542
3543   push_result:
3544     /* OPpTRUEBOOL indicates an '== -1' has been optimised away */
3545     if (PL_op->op_private & OPpTRUEBOOL) {
3546         PUSHs( ((retval != -1) ^ cBOOL(PL_op->op_private & OPpINDEX_BOOLNEG))
3547                     ? &PL_sv_yes : &PL_sv_no);
3548         if (PL_op->op_private & OPpTARGET_MY)
3549             /* $lex = (index() == -1) */
3550             sv_setsv(TARG, TOPs);
3551     }
3552     else
3553         PUSHi(retval);
3554     RETURN;
3555 }
3556
3557 PP(pp_sprintf)
3558 {
3559     dSP; dMARK; dORIGMARK; dTARGET;
3560     SvTAINTED_off(TARG);
3561     do_sprintf(TARG, SP-MARK, MARK+1);
3562     TAINT_IF(SvTAINTED(TARG));
3563     SP = ORIGMARK;
3564     PUSHTARG;
3565     RETURN;
3566 }
3567
3568 PP(pp_ord)
3569 {
3570     dSP; dTARGET;
3571
3572     SV *argsv = TOPs;
3573     STRLEN len;
3574     const U8 *s = (U8*)SvPV_const(argsv, len);
3575
3576     SETu(DO_UTF8(argsv)
3577            ? (len ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV) : 0)
3578            : (UV)(*s));
3579
3580     return NORMAL;
3581 }
3582
3583 PP(pp_chr)
3584 {
3585     dSP; dTARGET;
3586     char *tmps;
3587     UV value;
3588     SV *top = TOPs;
3589
3590     SvGETMAGIC(top);
3591     if (UNLIKELY(SvAMAGIC(top)))
3592         top = sv_2num(top);
3593     if (UNLIKELY(isinfnansv(top)))
3594         Perl_croak(aTHX_ "Cannot chr %" NVgf, SvNV(top));
3595     else {
3596         if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3597             && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3598                 ||
3599                 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3600                  && SvNV_nomg(top) < 0.0)))
3601         {
3602             if (ckWARN(WARN_UTF8)) {
3603                 if (SvGMAGICAL(top)) {
3604                     SV *top2 = sv_newmortal();
3605                     sv_setsv_nomg(top2, top);
3606                     top = top2;
3607                 }
3608                 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3609                             "Invalid negative number (%" SVf ") in chr", SVfARG(top));
3610             }
3611             value = UNICODE_REPLACEMENT;
3612         } else {
3613             value = SvUV_nomg(top);
3614         }
3615     }
3616
3617     SvUPGRADE(TARG,SVt_PV);
3618
3619     if (value > 255 && !IN_BYTES) {
3620         SvGROW(TARG, (STRLEN)UVCHR_SKIP(value)+1);
3621         tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3622         SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3623         *tmps = '\0';
3624         (void)SvPOK_only(TARG);
3625         SvUTF8_on(TARG);
3626         SETTARG;
3627         return NORMAL;
3628     }
3629
3630     SvGROW(TARG,2);
3631     SvCUR_set(TARG, 1);
3632     tmps = SvPVX(TARG);
3633     *tmps++ = (char)value;
3634     *tmps = '\0';
3635     (void)SvPOK_only(TARG);
3636
3637     SETTARG;
3638     return NORMAL;
3639 }
3640
3641 PP(pp_crypt)
3642 {
3643 #ifdef HAS_CRYPT
3644     dSP; dTARGET;
3645     dPOPTOPssrl;
3646     STRLEN len;
3647     const char *tmps = SvPV_const(left, len);
3648
3649     if (DO_UTF8(left)) {
3650          /* If Unicode, try to downgrade.
3651           * If not possible, croak.
3652           * Yes, we made this up.  */
3653          SV* const tsv = newSVpvn_flags(tmps, len, SVf_UTF8|SVs_TEMP);
3654
3655          sv_utf8_downgrade(tsv, FALSE);
3656          tmps = SvPV_const(tsv, len);
3657     }
3658 #   ifdef USE_ITHREADS
3659 #     ifdef HAS_CRYPT_R
3660     if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3661       /* This should be threadsafe because in ithreads there is only
3662        * one thread per interpreter.  If this would not be true,
3663        * we would need a mutex to protect this malloc. */
3664         PL_reentrant_buffer->_crypt_struct_buffer =
3665           (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3666 #if defined(__GLIBC__) || defined(__EMX__)
3667         if (PL_reentrant_buffer->_crypt_struct_buffer) {
3668             PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3669             /* work around glibc-2.2.5 bug */
3670             PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3671         }
3672 #endif
3673     }
3674 #     endif /* HAS_CRYPT_R */
3675 #   endif /* USE_ITHREADS */
3676 #   ifdef FCRYPT
3677     sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3678 #   else
3679     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3680 #   endif
3681     SvUTF8_off(TARG);
3682     SETTARG;
3683     RETURN;
3684 #else
3685     DIE(aTHX_
3686       "The crypt() function is unimplemented due to excessive paranoia.");
3687 #endif
3688 }
3689
3690 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level.  So
3691  * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3692
3693
3694 /* also used for: pp_lcfirst() */
3695
3696 PP(pp_ucfirst)
3697 {
3698     /* Actually is both lcfirst() and ucfirst().  Only the first character
3699      * changes.  This means that possibly we can change in-place, ie., just
3700      * take the source and change that one character and store it back, but not
3701      * if read-only etc, or if the length changes */
3702
3703     dSP;
3704     SV *source = TOPs;
3705     STRLEN slen; /* slen is the byte length of the whole SV. */
3706     STRLEN need;
3707     SV *dest;
3708     bool inplace;   /* ? Convert first char only, in-place */
3709     bool doing_utf8 = FALSE;               /* ? using utf8 */
3710     bool convert_source_to_utf8 = FALSE;   /* ? need to convert */
3711     const int op_type = PL_op->op_type;
3712     const U8 *s;
3713     U8 *d;
3714     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3715     STRLEN ulen;    /* ulen is the byte length of the original Unicode character
3716                      * stored as UTF-8 at s. */
3717     STRLEN tculen;  /* tculen is the byte length of the freshly titlecased (or
3718                      * lowercased) character stored in tmpbuf.  May be either
3719                      * UTF-8 or not, but in either case is the number of bytes */
3720
3721     s = (const U8*)SvPV_const(source, slen);
3722
3723     /* We may be able to get away with changing only the first character, in
3724      * place, but not if read-only, etc.  Later we may discover more reasons to
3725      * not convert in-place. */
3726     inplace = !SvREADONLY(source) && SvPADTMP(source);
3727
3728     /* First calculate what the changed first character should be.  This affects
3729      * whether we can just swap it out, leaving the rest of the string unchanged,
3730      * or even if have to convert the dest to UTF-8 when the source isn't */
3731
3732     if (! slen) {   /* If empty */
3733         need = 1; /* still need a trailing NUL */
3734         ulen = 0;
3735     }
3736     else if (DO_UTF8(source)) { /* Is the source utf8? */
3737         doing_utf8 = TRUE;
3738         ulen = UTF8SKIP(s);
3739         if (op_type == OP_UCFIRST) {
3740 #ifdef USE_LOCALE_CTYPE
3741             _toTITLE_utf8_flags(s, s +slen, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3742 #else
3743             _toTITLE_utf8_flags(s, s +slen, tmpbuf, &tculen, 0);
3744 #endif
3745         }
3746         else {
3747 #ifdef USE_LOCALE_CTYPE
3748             _toLOWER_utf8_flags(s, s + slen, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3749 #else
3750             _toLOWER_utf8_flags(s, s + slen, tmpbuf, &tculen, 0);
3751 #endif
3752         }
3753
3754         /* we can't do in-place if the length changes.  */
3755         if (ulen != tculen) inplace = FALSE;
3756         need = slen + 1 - ulen + tculen;
3757     }
3758     else { /* Non-zero length, non-UTF-8,  Need to consider locale and if
3759             * latin1 is treated as caseless.  Note that a locale takes
3760             * precedence */
3761         ulen = 1;       /* Original character is 1 byte */
3762         tculen = 1;     /* Most characters will require one byte, but this will
3763                          * need to be overridden for the tricky ones */
3764         need = slen + 1;
3765
3766         if (op_type == OP_LCFIRST) {
3767
3768             /* lower case the first letter: no trickiness for any character */
3769 #ifdef USE_LOCALE_CTYPE
3770             if (IN_LC_RUNTIME(LC_CTYPE)) {
3771                 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3772                 *tmpbuf = toLOWER_LC(*s);
3773             }
3774             else
3775 #endif
3776             {
3777                 *tmpbuf = (IN_UNI_8_BIT)
3778                           ? toLOWER_LATIN1(*s)
3779                           : toLOWER(*s);
3780             }
3781         }
3782 #ifdef USE_LOCALE_CTYPE
3783         /* is ucfirst() */
3784         else if (IN_LC_RUNTIME(LC_CTYPE)) {
3785             if (IN_UTF8_CTYPE_LOCALE) {
3786                 goto do_uni_rules;
3787             }
3788
3789             _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3790             *tmpbuf = (U8) toUPPER_LC(*s); /* This would be a bug if any
3791                                               locales have upper and title case
3792                                               different */
3793         }
3794 #endif
3795         else if (! IN_UNI_8_BIT) {
3796             *tmpbuf = toUPPER(*s);      /* Returns caseless for non-ascii, or
3797                                          * on EBCDIC machines whatever the
3798                                          * native function does */
3799         }
3800         else {
3801             /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is
3802              * UTF-8, which we treat as not in locale), and cased latin1 */
3803             UV title_ord;
3804 #ifdef USE_LOCALE_CTYPE
3805       do_uni_rules:
3806 #endif
3807
3808             title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3809             if (tculen > 1) {
3810                 assert(tculen == 2);
3811
3812                 /* If the result is an upper Latin1-range character, it can
3813                  * still be represented in one byte, which is its ordinal */
3814                 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3815                     *tmpbuf = (U8) title_ord;
3816                     tculen = 1;
3817                 }
3818                 else {
3819                     /* Otherwise it became more than one ASCII character (in
3820                      * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3821                      * beyond Latin1, so the number of bytes changed, so can't
3822                      * replace just the first character in place. */
3823                     inplace = FALSE;
3824
3825                     /* If the result won't fit in a byte, the entire result
3826                      * will have to be in UTF-8.  Assume worst case sizing in
3827                      * conversion. (all latin1 characters occupy at most two
3828                      * bytes in utf8) */
3829                     if (title_ord > 255) {
3830                         doing_utf8 = TRUE;
3831                         convert_source_to_utf8 = TRUE;
3832                         need = slen * 2 + 1;
3833
3834                         /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3835                          * (both) characters whose title case is above 255 is
3836                          * 2. */
3837                         ulen = 2;
3838                     }
3839                     else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3840                         need = slen + 1 + 1;
3841                     }
3842                 }
3843             }
3844         } /* End of use Unicode (Latin1) semantics */
3845     } /* End of changing the case of the first character */
3846
3847     /* Here, have the first character's changed case stored in tmpbuf.  Ready to
3848      * generate the result */
3849     if (inplace) {
3850
3851         /* We can convert in place.  This means we change just the first
3852          * character without disturbing the rest; no need to grow */
3853         dest = source;
3854         s = d = (U8*)SvPV_force_nomg(source, slen);
3855     } else {
3856         dTARGET;
3857
3858         dest = TARG;
3859
3860         /* Here, we can't convert in place; we earlier calculated how much
3861          * space we will need, so grow to accommodate that */
3862         SvUPGRADE(dest, SVt_PV);
3863         d = (U8*)SvGROW(dest, need);
3864         (void)SvPOK_only(dest);
3865
3866         SETs(dest);
3867     }
3868
3869     if (doing_utf8) {
3870         if (! inplace) {
3871             if (! convert_source_to_utf8) {
3872
3873                 /* Here  both source and dest are in UTF-8, but have to create
3874                  * the entire output.  We initialize the result to be the
3875                  * title/lower cased first character, and then append the rest
3876                  * of the string. */
3877                 sv_setpvn(dest, (char*)tmpbuf, tculen);
3878                 if (slen > ulen) {
3879                     sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3880                 }
3881             }
3882             else {
3883                 const U8 *const send = s + slen;
3884
3885                 /* Here the dest needs to be in UTF-8, but the source isn't,
3886                  * except we earlier UTF-8'd the first character of the source
3887                  * into tmpbuf.  First put that into dest, and then append the
3888                  * rest of the source, converting it to UTF-8 as we go. */
3889
3890                 /* Assert tculen is 2 here because the only two characters that
3891                  * get to this part of the code have 2-byte UTF-8 equivalents */
3892                 *d++ = *tmpbuf;
3893                 *d++ = *(tmpbuf + 1);
3894                 s++;    /* We have just processed the 1st char */
3895
3896                 for (; s < send; s++) {
3897                     d = uvchr_to_utf8(d, *s);
3898                 }
3899                 *d = '\0';
3900                 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3901             }
3902             SvUTF8_on(dest);
3903         }
3904         else {   /* in-place UTF-8.  Just overwrite the first character */
3905             Copy(tmpbuf, d, tculen, U8);
3906             SvCUR_set(dest, need - 1);
3907         }
3908
3909     }
3910     else {  /* Neither source nor dest are in or need to be UTF-8 */
3911         if (slen) {
3912             if (inplace) {  /* in-place, only need to change the 1st char */
3913                 *d = *tmpbuf;
3914             }
3915             else {      /* Not in-place */
3916
3917                 /* Copy the case-changed character(s) from tmpbuf */
3918                 Copy(tmpbuf, d, tculen, U8);
3919                 d += tculen - 1; /* Code below expects d to point to final
3920                                   * character stored */
3921             }
3922         }
3923         else {  /* empty source */
3924             /* See bug #39028: Don't taint if empty  */
3925             *d = *s;
3926         }
3927
3928         /* In a "use bytes" we don't treat the source as UTF-8, but, still want
3929          * the destination to retain that flag */
3930         if (SvUTF8(source) && ! IN_BYTES)
3931             SvUTF8_on(dest);
3932
3933         if (!inplace) { /* Finish the rest of the string, unchanged */
3934             /* This will copy the trailing NUL  */
3935             Copy(s + 1, d + 1, slen, U8);
3936             SvCUR_set(dest, need - 1);
3937         }
3938     }
3939 #ifdef USE_LOCALE_CTYPE
3940     if (IN_LC_RUNTIME(LC_CTYPE)) {
3941         TAINT;
3942         SvTAINTED_on(dest);
3943     }
3944 #endif
3945     if (dest != source && SvTAINTED(source))
3946         SvTAINT(dest);
3947     SvSETMAGIC(dest);
3948     return NORMAL;
3949 }
3950
3951 /* There's so much setup/teardown code common between uc and lc, I wonder if
3952    it would be worth merging the two, and just having a switch outside each
3953    of the three tight loops.  There is less and less commonality though */
3954 PP(pp_uc)
3955 {
3956     dSP;
3957     SV *source = TOPs;
3958     STRLEN len;
3959     STRLEN min;
3960     SV *dest;
3961     const U8 *s;
3962     U8 *d;
3963
3964     SvGETMAGIC(source);
3965
3966     if (   SvPADTMP(source)
3967         && !SvREADONLY(source) && SvPOK(source)
3968         && !DO_UTF8(source)
3969         && (
3970 #ifdef USE_LOCALE_CTYPE
3971             (IN_LC_RUNTIME(LC_CTYPE))
3972             ? ! IN_UTF8_CTYPE_LOCALE
3973             :
3974 #endif
3975               ! IN_UNI_8_BIT))
3976     {
3977
3978         /* We can convert in place.  The reason we can't if in UNI_8_BIT is to
3979          * make the loop tight, so we overwrite the source with the dest before
3980          * looking at it, and we need to look at the original source
3981          * afterwards.  There would also need to be code added to handle
3982          * switching to not in-place in midstream if we run into characters
3983          * that change the length.  Since being in locale overrides UNI_8_BIT,
3984          * that latter becomes irrelevant in the above test; instead for
3985          * locale, the size can't normally change, except if the locale is a
3986          * UTF-8 one */
3987         dest = source;
3988         s = d = (U8*)SvPV_force_nomg(source, len);
3989         min = len + 1;
3990     } else {
3991         dTARGET;
3992
3993         dest = TARG;
3994
3995         s = (const U8*)SvPV_nomg_const(source, len);
3996         min = len + 1;
3997
3998         SvUPGRADE(dest, SVt_PV);
3999         d = (U8*)SvGROW(dest, min);
4000         (void)SvPOK_only(dest);
4001
4002         SETs(dest);
4003     }
4004
4005     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4006        to check DO_UTF8 again here.  */
4007
4008     if (DO_UTF8(source)) {
4009         const U8 *const send = s + len;
4010         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4011
4012         /* All occurrences of these are to be moved to follow any other marks.
4013          * This is context-dependent.  We may not be passed enough context to
4014          * move the iota subscript beyond all of them, but we do the best we can
4015          * with what we're given.  The result is always better than if we
4016          * hadn't done this.  And, the problem would only arise if we are
4017          * passed a character without all its combining marks, which would be
4018          * the caller's mistake.  The information this is based on comes from a
4019          * comment in Unicode SpecialCasing.txt, (and the Standard's text
4020          * itself) and so can't be checked properly to see if it ever gets
4021          * revised.  But the likelihood of it changing is remote */
4022         bool in_iota_subscript = FALSE;
4023
4024         while (s < send) {
4025             STRLEN u;
4026             STRLEN ulen;
4027             UV uv;
4028             if (in_iota_subscript && ! _is_utf8_mark(s)) {
4029
4030                 /* A non-mark.  Time to output the iota subscript */
4031                 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
4032                 d += capital_iota_len;
4033                 in_iota_subscript = FALSE;
4034             }
4035
4036             /* Then handle the current character.  Get the changed case value
4037              * and copy it to the output buffer */
4038
4039             u = UTF8SKIP(s);
4040 #ifdef USE_LOCALE_CTYPE
4041             uv = _toUPPER_utf8_flags(s, send, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4042 #else
4043             uv = _toUPPER_utf8_flags(s, send, tmpbuf, &ulen, 0);
4044 #endif
4045 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
4046 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
4047             if (uv == GREEK_CAPITAL_LETTER_IOTA
4048                 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
4049             {
4050                 in_iota_subscript = TRUE;
4051             }
4052             else {
4053                 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4054                     /* If the eventually required minimum size outgrows the
4055                      * available space, we need to grow. */
4056                     const UV o = d - (U8*)SvPVX_const(dest);
4057
4058                     /* If someone uppercases one million U+03B0s we SvGROW()
4059                      * one million times.  Or we could try guessing how much to
4060                      * allocate without allocating too much.  Such is life.
4061                      * See corresponding comment in lc code for another option
4062                      * */
4063                     d = o + (U8*) SvGROW(dest, min);
4064                 }
4065                 Copy(tmpbuf, d, ulen, U8);
4066                 d += ulen;
4067             }
4068             s += u;
4069         }
4070         if (in_iota_subscript) {
4071             Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
4072             d += capital_iota_len;
4073         }
4074         SvUTF8_on(dest);
4075         *d = '\0';
4076
4077         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4078     }
4079     else {      /* Not UTF-8 */
4080         if (len) {
4081             const U8 *const send = s + len;
4082
4083             /* Use locale casing if in locale; regular style if not treating
4084              * latin1 as having case; otherwise the latin1 casing.  Do the
4085              * whole thing in a tight loop, for speed, */
4086 #ifdef USE_LOCALE_CTYPE
4087             if (IN_LC_RUNTIME(LC_CTYPE)) {
4088                 if (IN_UTF8_CTYPE_LOCALE) {
4089                     goto do_uni_rules;
4090                 }
4091                 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4092                 for (; s < send; d++, s++)
4093                     *d = (U8) toUPPER_LC(*s);
4094             }
4095             else
4096 #endif
4097                  if (! IN_UNI_8_BIT) {
4098                 for (; s < send; d++, s++) {
4099                     *d = toUPPER(*s);
4100                 }
4101             }
4102             else {
4103 #ifdef USE_LOCALE_CTYPE
4104           do_uni_rules:
4105 #endif
4106                 for (; s < send; d++, s++) {
4107                     *d = toUPPER_LATIN1_MOD(*s);
4108                     if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
4109                         continue;
4110                     }
4111
4112                     /* The mainstream case is the tight loop above.  To avoid
4113                      * extra tests in that, all three characters that require
4114                      * special handling are mapped by the MOD to the one tested
4115                      * just above.
4116                      * Use the source to distinguish between the three cases */
4117
4118 #if    UNICODE_MAJOR_VERSION > 2                                        \
4119    || (UNICODE_MAJOR_VERSION == 2 && UNICODE_DOT_VERSION >= 1           \
4120                                   && UNICODE_DOT_DOT_VERSION >= 8)
4121                     if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4122
4123                         /* uc() of this requires 2 characters, but they are
4124                          * ASCII.  If not enough room, grow the string */
4125                         if (SvLEN(dest) < ++min) {
4126                             const UV o = d - (U8*)SvPVX_const(dest);
4127                             d = o + (U8*) SvGROW(dest, min);
4128                         }
4129                         *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
4130                         continue;   /* Back to the tight loop; still in ASCII */
4131                     }
4132 #endif
4133
4134                     /* The other two special handling characters have their
4135                      * upper cases outside the latin1 range, hence need to be
4136                      * in UTF-8, so the whole result needs to be in UTF-8.  So,
4137                      * here we are somewhere in the middle of processing a
4138                      * non-UTF-8 string, and realize that we will have to convert
4139                      * the whole thing to UTF-8.  What to do?  There are
4140                      * several possibilities.  The simplest to code is to
4141                      * convert what we have so far, set a flag, and continue on
4142                      * in the loop.  The flag would be tested each time through
4143                      * the loop, and if set, the next character would be
4144                      * converted to UTF-8 and stored.  But, I (khw) didn't want
4145                      * to slow down the mainstream case at all for this fairly
4146                      * rare case, so I didn't want to add a test that didn't
4147                      * absolutely have to be there in the loop, besides the
4148                      * possibility that it would get too complicated for
4149                      * optimizers to deal with.  Another possibility is to just
4150                      * give up, convert the source to UTF-8, and restart the
4151                      * function that way.  Another possibility is to convert
4152                      * both what has already been processed and what is yet to
4153                      * come separately to UTF-8, then jump into the loop that
4154                      * handles UTF-8.  But the most efficient time-wise of the
4155                      * ones I could think of is what follows, and turned out to
4156                      * not require much extra code.  */
4157
4158                     /* Convert what we have so far into UTF-8, telling the
4159                      * function that we know it should be converted, and to
4160                      * allow extra space for what we haven't processed yet.
4161                      * Assume the worst case space requirements for converting
4162                      * what we haven't processed so far: that it will require
4163                      * two bytes for each remaining source character, plus the
4164                      * NUL at the end.  This may cause the string pointer to
4165                      * move, so re-find it. */
4166
4167                     len = d - (U8*)SvPVX_const(dest);
4168                     SvCUR_set(dest, len);
4169                     len = sv_utf8_upgrade_flags_grow(dest,
4170                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4171                                                 (send -s) * 2 + 1);
4172                     d = (U8*)SvPVX(dest) + len;
4173
4174                     /* Now process the remainder of the source, converting to
4175                      * upper and UTF-8.  If a resulting byte is invariant in
4176                      * UTF-8, output it as-is, otherwise convert to UTF-8 and
4177                      * append it to the output. */
4178                     for (; s < send; s++) {
4179                         (void) _to_upper_title_latin1(*s, d, &len, 'S');
4180                         d += len;
4181                     }
4182
4183                     /* Here have processed the whole source; no need to continue
4184                      * with the outer loop.  Each character has been converted
4185                      * to upper case and converted to UTF-8 */
4186
4187                     break;
4188                 } /* End of processing all latin1-style chars */
4189             } /* End of processing all chars */
4190         } /* End of source is not empty */
4191
4192         if (source != dest) {
4193             *d = '\0';  /* Here d points to 1 after last char, add NUL */
4194             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4195         }
4196     } /* End of isn't utf8 */
4197 #ifdef USE_LOCALE_CTYPE
4198     if (IN_LC_RUNTIME(LC_CTYPE)) {
4199         TAINT;
4200         SvTAINTED_on(dest);
4201     }
4202 #endif
4203     if (dest != source && SvTAINTED(source))
4204         SvTAINT(dest);
4205     SvSETMAGIC(dest);
4206     return NORMAL;
4207 }
4208
4209 PP(pp_lc)
4210 {
4211     dSP;
4212     SV *source = TOPs;
4213     STRLEN len;
4214     STRLEN min;
4215     SV *dest;
4216     const U8 *s;
4217     U8 *d;
4218
4219     SvGETMAGIC(source);
4220
4221     if (   SvPADTMP(source)
4222         && !SvREADONLY(source) && SvPOK(source)
4223         && !DO_UTF8(source)) {
4224
4225         /* We can convert in place, as lowercasing anything in the latin1 range
4226          * (or else DO_UTF8 would have been on) doesn't lengthen it */
4227         dest = source;
4228         s = d = (U8*)SvPV_force_nomg(source, len);
4229         min = len + 1;
4230     } else {
4231         dTARGET;
4232
4233         dest = TARG;
4234
4235         s = (const U8*)SvPV_nomg_const(source, len);
4236         min = len + 1;
4237
4238         SvUPGRADE(dest, SVt_PV);
4239         d = (U8*)SvGROW(dest, min);
4240         (void)SvPOK_only(dest);
4241
4242         SETs(dest);
4243     }
4244
4245     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4246        to check DO_UTF8 again here.  */
4247
4248     if (DO_UTF8(source)) {
4249         const U8 *const send = s + len;
4250         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4251
4252         while (s < send) {
4253             const STRLEN u = UTF8SKIP(s);
4254             STRLEN ulen;
4255
4256 #ifdef USE_LOCALE_CTYPE
4257             _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4258 #else
4259             _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, 0);
4260 #endif
4261
4262             /* Here is where we would do context-sensitive actions.  See the
4263              * commit message for 86510fb15 for why there isn't any */
4264
4265             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4266
4267                 /* If the eventually required minimum size outgrows the
4268                  * available space, we need to grow. */
4269                 const UV o = d - (U8*)SvPVX_const(dest);
4270
4271                 /* If someone lowercases one million U+0130s we SvGROW() one
4272                  * million times.  Or we could try guessing how much to
4273                  * allocate without allocating too much.  Such is life.
4274                  * Another option would be to grow an extra byte or two more
4275                  * each time we need to grow, which would cut down the million
4276                  * to 500K, with little waste */
4277                 d = o + (U8*) SvGROW(dest, min);
4278             }
4279
4280             /* Copy the newly lowercased letter to the output buffer we're
4281              * building */
4282             Copy(tmpbuf, d, ulen, U8);
4283             d += ulen;
4284             s += u;
4285         }   /* End of looping through the source string */
4286         SvUTF8_on(dest);
4287         *d = '\0';
4288         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4289     } else {    /* Not utf8 */
4290         if (len) {
4291             const U8 *const send = s + len;
4292
4293             /* Use locale casing if in locale; regular style if not treating
4294              * latin1 as having case; otherwise the latin1 casing.  Do the
4295              * whole thing in a tight loop, for speed, */
4296 #ifdef USE_LOCALE_CTYPE
4297             if (IN_LC_RUNTIME(LC_CTYPE)) {
4298                 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4299                 for (; s < send; d++, s++)
4300                     *d = toLOWER_LC(*s);
4301             }
4302             else
4303 #endif
4304             if (! IN_UNI_8_BIT) {
4305                 for (; s < send; d++, s++) {
4306                     *d = toLOWER(*s);
4307                 }
4308             }
4309             else {
4310                 for (; s < send; d++, s++) {
4311                     *d = toLOWER_LATIN1(*s);
4312                 }
4313             }
4314         }
4315         if (source != dest) {
4316             *d = '\0';
4317             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4318         }
4319     }
4320 #ifdef USE_LOCALE_CTYPE
4321     if (IN_LC_RUNTIME(LC_CTYPE)) {
4322         TAINT;
4323         SvTAINTED_on(dest);
4324     }
4325 #endif
4326     if (dest != source && SvTAINTED(source))
4327         SvTAINT(dest);
4328     SvSETMAGIC(dest);
4329     return NORMAL;
4330 }
4331
4332 PP(pp_quotemeta)
4333 {
4334     dSP; dTARGET;
4335     SV * const sv = TOPs;
4336     STRLEN len;
4337     const char *s = SvPV_const(sv,len);
4338
4339     SvUTF8_off(TARG);                           /* decontaminate */
4340     if (len) {
4341         char *d;
4342         SvUPGRADE(TARG, SVt_PV);
4343         SvGROW(TARG, (len * 2) + 1);
4344         d = SvPVX(TARG);
4345         if (DO_UTF8(sv)) {
4346             while (len) {
4347                 STRLEN ulen = UTF8SKIP(s);
4348                 bool to_quote = FALSE;
4349
4350                 if (UTF8_IS_INVARIANT(*s)) {
4351                     if (_isQUOTEMETA(*s)) {
4352                         to_quote = TRUE;
4353                     }
4354                 }
4355                 else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(s, s + len)) {
4356                     if (
4357 #ifdef USE_LOCALE_CTYPE
4358                     /* In locale, we quote all non-ASCII Latin1 chars.
4359                      * Otherwise use the quoting rules */
4360
4361                     IN_LC_RUNTIME(LC_CTYPE)
4362                         ||
4363 #endif
4364                         _isQUOTEMETA(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s + 1))))
4365                     {
4366                         to_quote = TRUE;
4367                     }
4368                 }
4369                 else if (is_QUOTEMETA_high(s)) {
4370                     to_quote = TRUE;
4371                 }
4372
4373                 if (to_quote) {
4374                     *d++ = '\\';
4375                 }
4376                 if (ulen > len)
4377                     ulen = len;
4378                 len -= ulen;
4379                 while (ulen--)
4380                     *d++ = *s++;
4381             }
4382             SvUTF8_on(TARG);
4383         }
4384         else if (IN_UNI_8_BIT) {
4385             while (len--) {
4386                 if (_isQUOTEMETA(*s))
4387                     *d++ = '\\';
4388                 *d++ = *s++;
4389             }
4390         }
4391         else {
4392             /* For non UNI_8_BIT (and hence in locale) just quote all \W
4393              * including everything above ASCII */
4394             while (len--) {
4395                 if (!isWORDCHAR_A(*s))
4396                     *d++ = '\\';
4397                 *d++ = *s++;
4398             }
4399         }
4400         *d = '\0';
4401         SvCUR_set(TARG, d - SvPVX_const(TARG));
4402         (void)SvPOK_only_UTF8(TARG);
4403     }
4404     else
4405         sv_setpvn(TARG, s, len);
4406     SETTARG;
4407     return NORMAL;
4408 }
4409
4410 PP(pp_fc)
4411 {
4412     dTARGET;
4413     dSP;
4414     SV *source = TOPs;
4415     STRLEN len;
4416     STRLEN min;
4417     SV *dest;
4418     const U8 *s;
4419     const U8 *send;
4420     U8 *d;
4421     U8 tmpbuf[UTF8_MAXBYTES_CASE + 1];
4422 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
4423    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
4424                                       || UNICODE_DOT_DOT_VERSION > 0)
4425     const bool full_folding = TRUE; /* This variable is here so we can easily
4426                                        move to more generality later */
4427 #else
4428     const bool full_folding = FALSE;
4429 #endif
4430     const U8 flags = ( full_folding      ? FOLD_FLAGS_FULL   : 0 )
4431 #ifdef USE_LOCALE_CTYPE
4432                    | ( IN_LC_RUNTIME(LC_CTYPE) ? FOLD_FLAGS_LOCALE : 0 )
4433 #endif
4434     ;
4435
4436     /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4437      * You are welcome(?) -Hugmeir
4438      */
4439
4440     SvGETMAGIC(source);
4441
4442     dest = TARG;
4443
4444     if (SvOK(source)) {
4445         s = (const U8*)SvPV_nomg_const(source, len);
4446     } else {
4447         if (ckWARN(WARN_UNINITIALIZED))
4448             report_uninit(source);
4449         s = (const U8*)"";
4450         len = 0;
4451     }
4452
4453     min = len + 1;
4454
4455     SvUPGRADE(dest, SVt_PV);
4456     d = (U8*)SvGROW(dest, min);
4457     (void)SvPOK_only(dest);
4458
4459     SETs(dest);
4460
4461     send = s + len;
4462     if (DO_UTF8(source)) { /* UTF-8 flagged string. */
4463         while (s < send) {
4464             const STRLEN u = UTF8SKIP(s);
4465             STRLEN ulen;
4466
4467             _toFOLD_utf8_flags(s, send, tmpbuf, &ulen, flags);
4468
4469             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4470                 const UV o = d - (U8*)SvPVX_const(dest);
4471                 d = o + (U8*) SvGROW(dest, min);
4472             }
4473
4474             Copy(tmpbuf, d, ulen, U8);
4475             d += ulen;
4476             s += u;
4477         }
4478         SvUTF8_on(dest);
4479     } /* Unflagged string */
4480     else if (len) {
4481 #ifdef USE_LOCALE_CTYPE
4482         if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
4483             if (IN_UTF8_CTYPE_LOCALE) {
4484                 goto do_uni_folding;
4485             }
4486             _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4487             for (; s < send; d++, s++)
4488                 *d = (U8) toFOLD_LC(*s);
4489         }
4490         else
4491 #endif
4492         if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
4493             for (; s < send; d++, s++)
4494                 *d = toFOLD(*s);
4495         }
4496         else {
4497 #ifdef USE_LOCALE_CTYPE
4498       do_uni_folding:
4499 #endif
4500             /* For ASCII and the Latin-1 range, there's only two troublesome
4501              * folds, \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
4502              * casefolding becomes 'ss'; and \x{B5} (\N{MICRO SIGN}), which
4503              * under any fold becomes \x{3BC} (\N{GREEK SMALL LETTER MU}) --
4504              * For the rest, the casefold is their lowercase.  */
4505             for (; s < send; d++, s++) {
4506                 if (*s == MICRO_SIGN) {
4507                     /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
4508                      * which is outside of the latin-1 range. There's a couple
4509                      * of ways to deal with this -- khw discusses them in
4510                      * pp_lc/uc, so go there :) What we do here is upgrade what
4511                      * we had already casefolded, then enter an inner loop that
4512                      * appends the rest of the characters as UTF-8. */
4513                     len = d - (U8*)SvPVX_const(dest);
4514                     SvCUR_set(dest, len);
4515                     len = sv_utf8_upgrade_flags_grow(dest,
4516                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4517                                                 /* The max expansion for latin1
4518                                                  * chars is 1 byte becomes 2 */
4519                                                 (send -s) * 2 + 1);
4520                     d = (U8*)SvPVX(dest) + len;
4521
4522                     Copy(GREEK_SMALL_LETTER_MU_UTF8, d, small_mu_len, U8);
4523                     d += small_mu_len;
4524                     s++;
4525                     for (; s < send; s++) {
4526                         STRLEN ulen;
4527                         UV fc = _to_uni_fold_flags(*s, tmpbuf, &ulen, flags);
4528                         if UVCHR_IS_INVARIANT(fc) {
4529                             if (full_folding
4530                                 && *s == LATIN_SMALL_LETTER_SHARP_S)
4531                             {
4532                                 *d++ = 's';
4533                                 *d++ = 's';
4534                             }
4535                             else
4536                                 *d++ = (U8)fc;
4537                         }
4538                         else {
4539                             Copy(tmpbuf, d, ulen, U8);
4540                             d += ulen;
4541                         }
4542                     }
4543                     break;
4544                 }
4545                 else if (full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) {
4546                     /* Under full casefolding, LATIN SMALL LETTER SHARP S
4547                      * becomes "ss", which may require growing the SV. */
4548                     if (SvLEN(dest) < ++min) {
4549                         const UV o = d - (U8*)SvPVX_const(dest);
4550                         d = o + (U8*) SvGROW(dest, min);
4551                      }
4552                     *(d)++ = 's';
4553                     *d = 's';
4554                 }
4555                 else { /* If it's not one of those two, the fold is their lower
4556                           case */
4557                     *d = toLOWER_LATIN1(*s);
4558                 }
4559              }
4560         }
4561     }
4562     *d = '\0';
4563     SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4564
4565 #ifdef USE_LOCALE_CTYPE
4566     if (IN_LC_RUNTIME(LC_CTYPE)) {
4567         TAINT;
4568         SvTAINTED_on(dest);
4569     }
4570 #endif
4571     if (SvTAINTED(source))
4572         SvTAINT(dest);
4573     SvSETMAGIC(dest);
4574     RETURN;
4575 }
4576
4577 /* Arrays. */
4578
4579 PP(pp_aslice)
4580 {
4581     dSP; dMARK; dORIGMARK;
4582     AV *const av = MUTABLE_AV(POPs);
4583     const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4584
4585     if (SvTYPE(av) == SVt_PVAV) {
4586         const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4587         bool can_preserve = FALSE;
4588
4589         if (localizing) {
4590             MAGIC *mg;
4591             HV *stash;
4592
4593             can_preserve = SvCANEXISTDELETE(av);
4594         }
4595
4596         if (lval && localizing) {
4597             SV **svp;
4598             SSize_t max = -1;
4599             for (svp = MARK + 1; svp <= SP; svp++) {
4600                 const SSize_t elem = SvIV(*svp);
4601                 if (elem > max)
4602                     max = elem;
4603             }
4604             if (max > AvMAX(av))
4605                 av_extend(av, max);
4606         }
4607
4608         while (++MARK <= SP) {
4609             SV **svp;
4610             SSize_t elem = SvIV(*MARK);
4611             bool preeminent = TRUE;
4612
4613             if (localizing && can_preserve) {
4614                 /* If we can determine whether the element exist,
4615                  * Try to preserve the existenceness of a tied array
4616                  * element by using EXISTS and DELETE if possible.
4617                  * Fallback to FETCH and STORE otherwise. */
4618                 preeminent = av_exists(av, elem);
4619             }
4620
4621             svp = av_fetch(av, elem, lval);
4622             if (lval) {
4623                 if (!svp || !*svp)
4624                     DIE(aTHX_ PL_no_aelem, elem);
4625                 if (localizing) {
4626                     if (preeminent)
4627                         save_aelem(av, elem, svp);
4628                     else
4629                         SAVEADELETE(av, elem);
4630                 }
4631             }
4632             *MARK = svp ? *svp : &PL_sv_undef;
4633         }
4634     }
4635     if (GIMME_V != G_ARRAY) {
4636         MARK = ORIGMARK;
4637         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4638         SP = MARK;
4639     }
4640     RETURN;
4641 }
4642
4643 PP(pp_kvaslice)
4644 {
4645     dSP; dMARK;
4646     AV *const av = MUTABLE_AV(POPs);
4647     I32 lval = (PL_op->op_flags & OPf_MOD);
4648     SSize_t items = SP - MARK;
4649
4650     if (PL_op->op_private & OPpMAYBE_LVSUB) {
4651        const I32 flags = is_lvalue_sub();
4652        if (flags) {
4653            if (!(flags & OPpENTERSUB_INARGS))
4654                /* diag_listed_as: Can't modify %s in %s */
4655                Perl_croak(aTHX_ "Can't modify index/value array slice in list assignment");
4656            lval = flags;
4657        }
4658     }
4659
4660     MEXTEND(SP,items);
4661     while (items > 1) {
4662         *(MARK+items*2-1) = *(MARK+items);
4663         items--;
4664     }
4665     items = SP-MARK;
4666     SP += items;
4667
4668     while (++MARK <= SP) {
4669         SV **svp;
4670
4671         svp = av_fetch(av, SvIV(*MARK), lval);
4672         if (lval) {
4673             if (!svp || !*svp || *svp == &PL_sv_undef) {
4674                 DIE(aTHX_ PL_no_aelem, SvIV(*MARK));
4675             }
4676             *MARK