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