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                     prepare_SV_for_RV(sv);
 144                     SvRV_set(sv, MUTABLE_SV(gv));
 145                     SvROK_on(sv);
 146                     SvSETMAGIC(sv);
 147                     goto wasref;
 148                 }
 149                 if (PL_op->op_flags & OPf_REF || strict) {
 150                     Perl_die(aTHX_ PL_no_usym, "a symbol");
 151                 }
 152                 if (ckWARN(WARN_UNINITIALIZED))
 153                     report_uninit(sv);
 154                 return &PL_sv_undef;
 155             }
 156             if (noinit)
 157             {
 158                 if (!(sv = MUTABLE_SV(gv_fetchsv_nomg(
 159                            sv, GV_ADDMG, SVt_PVGV
 160                    ))))
 161                     return &PL_sv_undef;
 162             }
 163             else {
 164                 if (strict) {
 165                     Perl_die(aTHX_
 166                              PL_no_symref_sv,
 167                              sv,
 168                              (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""),
 169                              "a symbol"
 170                              );
 171                 }
 172                 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
 173                     == OPpDONT_INIT_GV) {
 174                     /* We are the target of a coderef assignment.  Return
 175                        the scalar unchanged, and let pp_sasssign deal with
 176                        things.  */
 177                     return sv;
 178                 }
 179                 sv = MUTABLE_SV(gv_fetchsv_nomg(sv, GV_ADD, SVt_PVGV));
 180             }
 181             /* FAKE globs in the symbol table cause weird bugs (#77810) */
 182             SvFAKE_off(sv);
 183         }
 184     }
 185     if (SvFAKE(sv) && !(PL_op->op_private & OPpALLOW_FAKE)) {
 186         SV *newsv = sv_newmortal();
 187         sv_setsv_flags(newsv, sv, 0);
 188         SvFAKE_off(newsv);
 189         sv = newsv;
 190     }
 191     return sv;
 192 }
 193
 194 PP(pp_rv2gv)
 195 {
 196     dSP; dTOPss;
 197
 198     sv = S_rv2gv(aTHX_
 199           sv, PL_op->op_private & OPpDEREF,
 200           PL_op->op_private & HINT_STRICT_REFS,
 201           ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD))
 202              || PL_op->op_type == OP_READLINE
 203          );
 204     if (PL_op->op_private & OPpLVAL_INTRO)
 205         save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
 206     SETs(sv);
 207     RETURN;
 208 }
 209
 210 /* Helper function for pp_rv2sv and pp_rv2av  */
 211 GV *
 212 Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
 213                 const svtype type, SV ***spp)
 214 {
 215     GV *gv;
 216
 217     PERL_ARGS_ASSERT_SOFTREF2XV;
 218
 219     if (PL_op->op_private & HINT_STRICT_REFS) {
 220         if (SvOK(sv))
 221             Perl_die(aTHX_ PL_no_symref_sv, sv,
 222                      (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
 223         else
 224             Perl_die(aTHX_ PL_no_usym, what);
 225     }
 226     if (!SvOK(sv)) {
 227         if (
 228           PL_op->op_flags & OPf_REF
 229         )
 230             Perl_die(aTHX_ PL_no_usym, what);
 231         if (ckWARN(WARN_UNINITIALIZED))
 232             report_uninit(sv);
 233         if (type != SVt_PV && GIMME_V == G_ARRAY) {
 234             (*spp)--;
 235             return NULL;
 236         }
 237         **spp = &PL_sv_undef;
 238         return NULL;
 239     }
 240     if ((PL_op->op_flags & OPf_SPECIAL) &&
 241         !(PL_op->op_flags & OPf_MOD))
 242         {
 243             if (!(gv = gv_fetchsv_nomg(sv, GV_ADDMG, type)))
 244                 {
 245                     **spp = &PL_sv_undef;
 246                     return NULL;
 247                 }
 248         }
 249     else {
 250         gv = gv_fetchsv_nomg(sv, GV_ADD, type);
 251     }
 252     return gv;
 253 }
 254
 255 PP(pp_rv2sv)
 256 {
 257     dSP; dTOPss;
 258     GV *gv = NULL;
 259
 260     SvGETMAGIC(sv);
 261     if (SvROK(sv)) {
 262         if (SvAMAGIC(sv)) {
 263             sv = amagic_deref_call(sv, to_sv_amg);
 264         }
 265
 266         sv = SvRV(sv);
 267         if (SvTYPE(sv) >= SVt_PVAV)
 268             DIE(aTHX_ "Not a SCALAR reference");
 269     }
 270     else {
 271         gv = MUTABLE_GV(sv);
 272
 273         if (!isGV_with_GP(gv)) {
 274             gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
 275             if (!gv)
 276                 RETURN;
 277         }
 278         sv = GvSVn(gv);
 279     }
 280     if (PL_op->op_flags & OPf_MOD) {
 281         if (PL_op->op_private & OPpLVAL_INTRO) {
 282             if (cUNOP->op_first->op_type == OP_NULL)
 283                 sv = save_scalar(MUTABLE_GV(TOPs));
 284             else if (gv)
 285                 sv = save_scalar(gv);
 286             else
 287                 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
 288         }
 289         else if (PL_op->op_private & OPpDEREF)
 290             sv = vivify_ref(sv, PL_op->op_private & OPpDEREF);
 291     }
 292     SPAGAIN; /* in case chasing soft refs reallocated the stack */
 293     SETs(sv);
 294     RETURN;
 295 }
 296
 297 PP(pp_av2arylen)
 298 {
 299     dSP;
 300     AV * const av = MUTABLE_AV(TOPs);
 301     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
 302     if (lvalue) {
 303         SV ** const svp = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
 304         if (!*svp) {
 305             *svp = newSV_type(SVt_PVMG);
 306             sv_magic(*svp, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
 307         }
 308         SETs(*svp);
 309     } else {
 310         SETs(sv_2mortal(newSViv(AvFILL(MUTABLE_AV(av)))));
 311     }
 312     RETURN;
 313 }
 314
 315 PP(pp_pos)
 316 {
 317     dSP; dTOPss;
 318
 319     if (PL_op->op_flags & OPf_MOD || LVRET) {
 320         SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));/* Not TARG RT#67838 */
 321         sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
 322         LvTYPE(ret) = '.';
 323         LvTARG(ret) = SvREFCNT_inc_simple(sv);
 324         SETs(ret);    /* no SvSETMAGIC */
 325     }
 326     else {
 327             const MAGIC * const mg = mg_find_mglob(sv);
 328             if (mg && mg->mg_len != -1) {
 329                 STRLEN i = mg->mg_len;
 330                 if (PL_op->op_private & OPpTRUEBOOL)
 331                     SETs(i ? &PL_sv_yes : &PL_sv_zero);
 332                 else {
 333                     dTARGET;
 334                     if (mg->mg_flags & MGf_BYTES && DO_UTF8(sv))
 335                         i = sv_pos_b2u_flags(sv, i, SV_GMAGIC|SV_CONST_RETURN);
 336                     SETu(i);
 337                 }
 338                 return NORMAL;
 339             }
 340             SETs(&PL_sv_undef);
 341     }
 342     return NORMAL;
 343 }
 344
 345 PP(pp_rv2cv)
 346 {
 347     dSP;
 348     GV *gv;
 349     HV *stash_unused;
 350     const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
 351         ? GV_ADDMG
 352         : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT))
 353                                                     == OPpMAY_RETURN_CONSTANT)
 354             ? GV_ADD|GV_NOEXPAND
 355             : GV_ADD;
 356     /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
 357     /* (But not in defined().) */
 358
 359     CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
 360     if (cv) NOOP;
 361     else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
 362         cv = SvTYPE(SvRV(gv)) == SVt_PVCV
 363             ? MUTABLE_CV(SvRV(gv))
 364             : MUTABLE_CV(gv);
 365     }
 366     else
 367         cv = MUTABLE_CV(&PL_sv_undef);
 368     SETs(MUTABLE_SV(cv));
 369     return NORMAL;
 370 }
 371
 372 PP(pp_prototype)
 373 {
 374     dSP;
 375     CV *cv;
 376     HV *stash;
 377     GV *gv;
 378     SV *ret = &PL_sv_undef;
 379
 380     if (SvGMAGICAL(TOPs)) SETs(sv_mortalcopy(TOPs));
 381     if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
 382         const char * s = SvPVX_const(TOPs);
 383         if (memBEGINs(s, SvCUR(TOPs), "CORE::")) {
 384             const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
 385             if (!code)
 386                 DIE(aTHX_ "Can't find an opnumber for \"%" UTF8f "\"",
 387                    UTF8fARG(SvFLAGS(TOPs) & SVf_UTF8, SvCUR(TOPs)-6, s+6));
 388             {
 389                 SV * const sv = core_prototype(NULL, s + 6, code, NULL);
 390                 if (sv) ret = sv;
 391             }
 392             goto set;
 393         }
 394     }
 395     cv = sv_2cv(TOPs, &stash, &gv, 0);
 396     if (cv && SvPOK(cv))
 397         ret = newSVpvn_flags(
 398             CvPROTO(cv), CvPROTOLEN(cv), SVs_TEMP | SvUTF8(cv)
 399         );
 400   set:
 401     SETs(ret);
 402     RETURN;
 403 }
 404
 405 PP(pp_anoncode)
 406 {
 407     dSP;
 408     CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
 409     if (CvCLONE(cv))
 410         cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
 411     EXTEND(SP,1);
 412     PUSHs(MUTABLE_SV(cv));
 413     RETURN;
 414 }
 415
 416 PP(pp_srefgen)
 417 {
 418     dSP;
 419     *SP = refto(*SP);
 420     return NORMAL;
 421 }
 422
 423 PP(pp_refgen)
 424 {
 425     dSP; dMARK;
 426     if (GIMME_V != G_ARRAY) {
 427         if (++MARK <= SP)
 428             *MARK = *SP;
 429         else
 430         {
 431             MEXTEND(SP, 1);
 432             *MARK = &PL_sv_undef;
 433         }
 434         *MARK = refto(*MARK);
 435         SP = MARK;
 436         RETURN;
 437     }
 438     EXTEND_MORTAL(SP - MARK);
 439     while (++MARK <= SP)
 440         *MARK = refto(*MARK);
 441     RETURN;
 442 }
 443
 444 STATIC SV*
 445 S_refto(pTHX_ SV *sv)
 446 {
 447     SV* rv;
 448
 449     PERL_ARGS_ASSERT_REFTO;
 450
 451     if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
 452         if (LvTARGLEN(sv))
 453             vivify_defelem(sv);
 454         if (!(sv = LvTARG(sv)))
 455             sv = &PL_sv_undef;
 456         else
 457             SvREFCNT_inc_void_NN(sv);
 458     }
 459     else if (SvTYPE(sv) == SVt_PVAV) {
 460         if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
 461             av_reify(MUTABLE_AV(sv));
 462         SvTEMP_off(sv);
 463         SvREFCNT_inc_void_NN(sv);
 464     }
 465     else if (SvPADTMP(sv)) {
 466         sv = newSVsv(sv);
 467     }
 468     else if (UNLIKELY(SvSMAGICAL(sv) && mg_find(sv, PERL_MAGIC_nonelem)))
 469         sv_unmagic(SvREFCNT_inc_simple_NN(sv), PERL_MAGIC_nonelem);
 470     else {
 471         SvTEMP_off(sv);
 472         SvREFCNT_inc_void_NN(sv);
 473     }
 474     rv = sv_newmortal();
 475     sv_upgrade(rv, SVt_IV);
 476     SvRV_set(rv, sv);
 477     SvROK_on(rv);
 478     return rv;
 479 }
 480
 481 PP(pp_ref)
 482 {
 483     dSP;
 484     SV * const sv = TOPs;
 485
 486     SvGETMAGIC(sv);
 487     if (!SvROK(sv)) {
 488         SETs(&PL_sv_no);
 489         return NORMAL;
 490     }
 491
 492     /* op is in boolean context? */
 493     if (   (PL_op->op_private & OPpTRUEBOOL)
 494         || (   (PL_op->op_private & OPpMAYBE_TRUEBOOL)
 495             && block_gimme() == G_VOID))
 496     {
 497         /* refs are always true - unless it's to an object blessed into a
 498          * class with a false name, i.e. "0". So we have to check for
 499          * that remote possibility. The following is is basically an
 500          * unrolled SvTRUE(sv_reftype(rv)) */
 501         SV * const rv = SvRV(sv);
 502         if (SvOBJECT(rv)) {
 503             HV *stash = SvSTASH(rv);
 504             HEK *hek = HvNAME_HEK(stash);
 505             if (hek) {
 506                 I32 len = HEK_LEN(hek);
 507                 /* bail out and do it the hard way? */
 508                 if (UNLIKELY(
 509                        len == HEf_SVKEY
 510                     || (len == 1 && HEK_KEY(hek)[0] == '0')
 511                 ))
 512                     goto do_sv_ref;
 513             }
 514         }
 515         SETs(&PL_sv_yes);
 516         return NORMAL;
 517     }
 518
 519   do_sv_ref:
 520     {
 521         dTARGET;
 522         SETs(TARG);
 523         sv_ref(TARG, SvRV(sv), TRUE);
 524         SvSETMAGIC(TARG);
 525         return NORMAL;
 526     }
 527
 528 }
 529
 530
 531 PP(pp_bless)
 532 {
 533     dSP;
 534     HV *stash;
 535
 536     if (MAXARG == 1)
 537     {
 538       curstash:
 539         stash = CopSTASH(PL_curcop);
 540         if (SvTYPE(stash) != SVt_PVHV)
 541             Perl_croak(aTHX_ "Attempt to bless into a freed package");
 542     }
 543     else {
 544         SV * const ssv = POPs;
 545         STRLEN len;
 546         const char *ptr;
 547
 548         if (!ssv) goto curstash;
 549         SvGETMAGIC(ssv);
 550         if (SvROK(ssv)) {
 551           if (!SvAMAGIC(ssv)) {
 552            frog:
 553             Perl_croak(aTHX_ "Attempt to bless into a reference");
 554           }
 555           /* SvAMAGIC is on here, but it only means potentially overloaded,
 556              so after stringification: */
 557           ptr = SvPV_nomg_const(ssv,len);
 558           /* We need to check the flag again: */
 559           if (!SvAMAGIC(ssv)) goto frog;
 560         }
 561         else ptr = SvPV_nomg_const(ssv,len);
 562         if (len == 0)
 563             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
 564                            "Explicit blessing to '' (assuming package main)");
 565         stash = gv_stashpvn(ptr, len, GV_ADD|SvUTF8(ssv));
 566     }
 567
 568     (void)sv_bless(TOPs, stash);
 569     RETURN;
 570 }
 571
 572 PP(pp_gelem)
 573 {
 574     dSP;
 575
 576     SV *sv = POPs;
 577     STRLEN len;
 578     const char * const elem = SvPV_const(sv, len);
 579     GV * const gv = MUTABLE_GV(TOPs);
 580     SV * tmpRef = NULL;
 581
 582     sv = NULL;
 583     if (elem) {
 584         /* elem will always be NUL terminated.  */
 585         switch (*elem) {
 586         case 'A':
 587             if (memEQs(elem, len, "ARRAY"))
 588             {
 589                 tmpRef = MUTABLE_SV(GvAV(gv));
 590                 if (tmpRef && !AvREAL((const AV *)tmpRef)
 591                  && AvREIFY((const AV *)tmpRef))
 592                     av_reify(MUTABLE_AV(tmpRef));
 593             }
 594             break;
 595         case 'C':
 596             if (memEQs(elem, len, "CODE"))
 597                 tmpRef = MUTABLE_SV(GvCVu(gv));
 598             break;
 599         case 'F':
 600             if (memEQs(elem, len, "FILEHANDLE")) {
 601                 tmpRef = MUTABLE_SV(GvIOp(gv));
 602             }
 603             else
 604                 if (memEQs(elem, len, "FORMAT"))
 605                     tmpRef = MUTABLE_SV(GvFORM(gv));
 606             break;
 607         case 'G':
 608             if (memEQs(elem, len, "GLOB"))
 609                 tmpRef = MUTABLE_SV(gv);
 610             break;
 611         case 'H':
 612             if (memEQs(elem, len, "HASH"))
 613                 tmpRef = MUTABLE_SV(GvHV(gv));
 614             break;
 615         case 'I':
 616             if (memEQs(elem, len, "IO"))
 617                 tmpRef = MUTABLE_SV(GvIOp(gv));
 618             break;
 619         case 'N':
 620             if (memEQs(elem, len, "NAME"))
 621                 sv = newSVhek(GvNAME_HEK(gv));
 622             break;
 623         case 'P':
 624             if (memEQs(elem, len, "PACKAGE")) {
 625                 const HV * const stash = GvSTASH(gv);
 626                 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
 627                 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
 628             }
 629             break;
 630         case 'S':
 631             if (memEQs(elem, len, "SCALAR"))
 632                 tmpRef = GvSVn(gv);
 633             break;
 634         }
 635     }
 636     if (tmpRef)
 637         sv = newRV(tmpRef);
 638     if (sv)
 639         sv_2mortal(sv);
 640     else
 641         sv = &PL_sv_undef;
 642     SETs(sv);
 643     RETURN;
 644 }
 645
 646 /* Pattern matching */
 647
 648 PP(pp_study)
 649 {
 650     dSP; dTOPss;
 651     STRLEN len;
 652
 653     (void)SvPV(sv, len);
 654     if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) {
 655         /* Historically, study was skipped in these cases. */
 656         SETs(&PL_sv_no);
 657         return NORMAL;
 658     }
 659
 660     /* Make study a no-op. It's no longer useful and its existence
 661        complicates matters elsewhere. */
 662     SETs(&PL_sv_yes);
 663     return NORMAL;
 664 }
 665
 666
 667 /* also used for: pp_transr() */
 668
 669 PP(pp_trans)
 670 {
 671     dSP;
 672     SV *sv;
 673
 674     if (PL_op->op_flags & OPf_STACKED)
 675         sv = POPs;
 676     else {
 677         EXTEND(SP,1);
 678         if (ARGTARG)
 679             sv = PAD_SV(ARGTARG);
 680         else {
 681             sv = DEFSV;
 682         }
 683     }
 684     if(PL_op->op_type == OP_TRANSR) {
 685         STRLEN len;
 686         const char * const pv = SvPV(sv,len);
 687         SV * const newsv = newSVpvn_flags(pv, len, SVs_TEMP|SvUTF8(sv));
 688         do_trans(newsv);
 689         PUSHs(newsv);
 690     }
 691     else {
 692         Size_t i = do_trans(sv);
 693         mPUSHi((UV)i);
 694     }
 695     RETURN;
 696 }
 697
 698 /* Lvalue operators. */
 699
 700 static size_t
 701 S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
 702 {
 703     STRLEN len;
 704     char *s;
 705     size_t count = 0;
 706
 707     PERL_ARGS_ASSERT_DO_CHOMP;
 708
 709     if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
 710         return 0;
 711     if (SvTYPE(sv) == SVt_PVAV) {
 712         I32 i;
 713         AV *const av = MUTABLE_AV(sv);
 714         const I32 max = AvFILL(av);
 715
 716         for (i = 0; i <= max; i++) {
 717             sv = MUTABLE_SV(av_fetch(av, i, FALSE));
 718             if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
 719                 count += do_chomp(retval, sv, chomping);
 720         }
 721         return count;
 722     }
 723     else if (SvTYPE(sv) == SVt_PVHV) {
 724         HV* const hv = MUTABLE_HV(sv);
 725         HE* entry;
 726         (void)hv_iterinit(hv);
 727         while ((entry = hv_iternext(hv)))
 728             count += do_chomp(retval, hv_iterval(hv,entry), chomping);
 729         return count;
 730     }
 731     else if (SvREADONLY(sv)) {
 732             Perl_croak_no_modify();
 733     }
 734
 735     s = SvPV(sv, len);
 736     if (chomping) {
 737         if (s && len) {
 738             char *temp_buffer = NULL;
 739             SV *svrecode = NULL;
 740             s += --len;
 741             if (RsPARA(PL_rs)) {
 742                 if (*s != '\n')
 743                     goto nope_free_nothing;
 744                 ++count;
 745                 while (len && s[-1] == '\n') {
 746                     --len;
 747                     --s;
 748                     ++count;
 749                 }
 750             }
 751             else {
 752                 STRLEN rslen, rs_charlen;
 753                 const char *rsptr = SvPV_const(PL_rs, rslen);
 754
 755                 rs_charlen = SvUTF8(PL_rs)
 756                     ? sv_len_utf8(PL_rs)
 757                     : rslen;
 758
 759                 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
 760                     /* Assumption is that rs is shorter than the scalar.  */
 761                     if (SvUTF8(PL_rs)) {
 762                         /* RS is utf8, scalar is 8 bit.  */
 763                         bool is_utf8 = TRUE;
 764                         temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
 765                                                              &rslen, &is_utf8);
 766                         if (is_utf8) {
 767                             /* Cannot downgrade, therefore cannot possibly match.
 768                                At this point, temp_buffer is not alloced, and
 769                                is the buffer inside PL_rs, so dont free it.
 770                              */
 771                             assert (temp_buffer == rsptr);
 772                             goto nope_free_sv;
 773                         }
 774                         rsptr = temp_buffer;
 775                     }
 776                     else {
 777                         /* RS is 8 bit, scalar is utf8.  */
 778                         temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
 779                         rsptr = temp_buffer;
 780                     }
 781                 }
 782                 if (rslen == 1) {
 783                     if (*s != *rsptr)
 784                         goto nope_free_all;
 785                     ++count;
 786                 }
 787                 else {
 788                     if (len < rslen - 1)
 789                         goto nope_free_all;
 790                     len -= rslen - 1;
 791                     s -= rslen - 1;
 792                     if (memNE(s, rsptr, rslen))
 793                         goto nope_free_all;
 794                     count += rs_charlen;
 795                 }
 796             }
 797             SvPV_force_nomg_nolen(sv);
 798             SvCUR_set(sv, len);
 799             *SvEND(sv) = '\0';
 800             SvNIOK_off(sv);
 801             SvSETMAGIC(sv);
 802
 803             nope_free_all:
 804             Safefree(temp_buffer);
 805             nope_free_sv:
 806             SvREFCNT_dec(svrecode);
 807             nope_free_nothing: ;
 808         }
 809     } else {
 810         if (len && (!SvPOK(sv) || SvIsCOW(sv)))
 811             s = SvPV_force_nomg(sv, len);
 812         if (DO_UTF8(sv)) {
 813             if (s && len) {
 814                 char * const send = s + len;
 815                 char * const start = s;
 816                 s = send - 1;
 817                 while (s > start && UTF8_IS_CONTINUATION(*s))
 818                     s--;
 819                 if (is_utf8_string((U8*)s, send - s)) {
 820                     sv_setpvn(retval, s, send - s);
 821                     *s = '\0';
 822                     SvCUR_set(sv, s - start);
 823                     SvNIOK_off(sv);
 824                     SvUTF8_on(retval);
 825                 }
 826             }
 827             else
 828                 SvPVCLEAR(retval);
 829         }
 830         else if (s && len) {
 831             s += --len;
 832             sv_setpvn(retval, s, 1);
 833             *s = '\0';
 834             SvCUR_set(sv, len);
 835             SvUTF8_off(sv);
 836             SvNIOK_off(sv);
 837         }
 838         else
 839             SvPVCLEAR(retval);
 840         SvSETMAGIC(sv);
 841     }
 842     return count;
 843 }
 844
 845
 846 /* also used for: pp_schomp() */
 847
 848 PP(pp_schop)
 849 {
 850     dSP; dTARGET;
 851     const bool chomping = PL_op->op_type == OP_SCHOMP;
 852
 853     const size_t count = do_chomp(TARG, TOPs, chomping);
 854     if (chomping)
 855         sv_setiv(TARG, count);
 856     SETTARG;
 857     return NORMAL;
 858 }
 859
 860
 861 /* also used for: pp_chomp() */
 862
 863 PP(pp_chop)
 864 {
 865     dSP; dMARK; dTARGET; dORIGMARK;
 866     const bool chomping = PL_op->op_type == OP_CHOMP;
 867     size_t count = 0;
 868
 869     while (MARK < SP)
 870         count += do_chomp(TARG, *++MARK, chomping);
 871     if (chomping)
 872         sv_setiv(TARG, count);
 873     SP = ORIGMARK;
 874     XPUSHTARG;
 875     RETURN;
 876 }
 877
 878 PP(pp_undef)
 879 {
 880     dSP;
 881     SV *sv;
 882
 883     if (!PL_op->op_private) {
 884         EXTEND(SP, 1);
 885         RETPUSHUNDEF;
 886     }
 887
 888     sv = TOPs;
 889     if (!sv)
 890     {
 891         SETs(&PL_sv_undef);
 892         return NORMAL;
 893     }
 894
 895     if (SvTHINKFIRST(sv))
 896         sv_force_normal_flags(sv, SV_COW_DROP_PV|SV_IMMEDIATE_UNREF);
 897
 898     switch (SvTYPE(sv)) {
 899     case SVt_NULL:
 900         break;
 901     case SVt_PVAV:
 902         av_undef(MUTABLE_AV(sv));
 903         break;
 904     case SVt_PVHV:
 905         hv_undef(MUTABLE_HV(sv));
 906         break;
 907     case SVt_PVCV:
 908         if (cv_const_sv((const CV *)sv))
 909             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
 910                           "Constant subroutine %" SVf " undefined",
 911                            SVfARG(CvANON((const CV *)sv)
 912                              ? newSVpvs_flags("(anonymous)", SVs_TEMP)
 913                              : sv_2mortal(newSVhek(
 914                                 CvNAMED(sv)
 915                                  ? CvNAME_HEK((CV *)sv)
 916                                  : GvENAME_HEK(CvGV((const CV *)sv))
 917                                ))
 918                            ));
 919         /* FALLTHROUGH */
 920     case SVt_PVFM:
 921             /* let user-undef'd sub keep its identity */
 922         cv_undef_flags(MUTABLE_CV(sv), CV_UNDEF_KEEP_NAME);
 923         break;
 924     case SVt_PVGV:
 925         assert(isGV_with_GP(sv));
 926         assert(!SvFAKE(sv));
 927         {
 928             GP *gp;
 929             HV *stash;
 930
 931             /* undef *Pkg::meth_name ... */
 932             bool method_changed
 933              =   GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
 934               && HvENAME_get(stash);
 935             /* undef *Foo:: */
 936             if((stash = GvHV((const GV *)sv))) {
 937                 if(HvENAME_get(stash))
 938                     SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
 939                 else stash = NULL;
 940             }
 941
 942             SvREFCNT_inc_simple_void_NN(sv_2mortal(sv));
 943             gp_free(MUTABLE_GV(sv));
 944             Newxz(gp, 1, GP);
 945             GvGP_set(sv, gp_ref(gp));
 946 #ifndef PERL_DONT_CREATE_GVSV
 947             GvSV(sv) = newSV(0);
 948 #endif
 949             GvLINE(sv) = CopLINE(PL_curcop);
 950             GvEGV(sv) = MUTABLE_GV(sv);
 951             GvMULTI_on(sv);
 952
 953             if(stash)
 954                 mro_package_moved(NULL, stash, (const GV *)sv, 0);
 955             stash = NULL;
 956             /* undef *Foo::ISA */
 957             if( strEQ(GvNAME((const GV *)sv), "ISA")
 958              && (stash = GvSTASH((const GV *)sv))
 959              && (method_changed || HvENAME(stash)) )
 960                 mro_isa_changed_in(stash);
 961             else if(method_changed)
 962                 mro_method_changed_in(
 963                  GvSTASH((const GV *)sv)
 964                 );
 965
 966             break;
 967         }
 968     default:
 969         if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
 970             SvPV_free(sv);
 971             SvPV_set(sv, NULL);
 972             SvLEN_set(sv, 0);
 973         }
 974         SvOK_off(sv);
 975         SvSETMAGIC(sv);
 976     }
 977
 978     SETs(&PL_sv_undef);
 979     return NORMAL;
 980 }
 981
 982
 983 /* common "slow" code for pp_postinc and pp_postdec */
 984
 985 static OP *
 986 S_postincdec_common(pTHX_ SV *sv, SV *targ)
 987 {
 988     dSP;
 989     const bool inc =
 990         PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC;
 991
 992     if (SvROK(sv))
 993         TARG = sv_newmortal();
 994     sv_setsv(TARG, sv);
 995     if (inc)
 996         sv_inc_nomg(sv);
 997     else
 998         sv_dec_nomg(sv);
 999     SvSETMAGIC(sv);
1000     /* special case for undef: see thread at 2003-03/msg00536.html in archive */
1001     if (inc && !SvOK(TARG))
1002         sv_setiv(TARG, 0);
1003     SETTARG;
1004     return NORMAL;
1005 }
1006
1007
1008 /* also used for: pp_i_postinc() */
1009
1010 PP(pp_postinc)
1011 {
1012     dSP; dTARGET;
1013     SV *sv = TOPs;
1014
1015     /* special-case sv being a simple integer */
1016     if (LIKELY(((sv->sv_flags &
1017                         (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1018                          SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1019                 == SVf_IOK))
1020         && SvIVX(sv) != IV_MAX)
1021     {
1022         IV iv = SvIVX(sv);
1023         SvIV_set(sv,  iv + 1);
1024         TARGi(iv, 0); /* arg not GMG, so can't be tainted */
1025         SETs(TARG);
1026         return NORMAL;
1027     }
1028
1029     return S_postincdec_common(aTHX_ sv, TARG);
1030 }
1031
1032
1033 /* also used for: pp_i_postdec() */
1034
1035 PP(pp_postdec)
1036 {
1037     dSP; dTARGET;
1038     SV *sv = TOPs;
1039
1040     /* special-case sv being a simple integer */
1041     if (LIKELY(((sv->sv_flags &
1042                         (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1043                          SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1044                 == SVf_IOK))
1045         && SvIVX(sv) != IV_MIN)
1046     {
1047         IV iv = SvIVX(sv);
1048         SvIV_set(sv,  iv - 1);
1049         TARGi(iv, 0); /* arg not GMG, so can't be tainted */
1050         SETs(TARG);
1051         return NORMAL;
1052     }
1053
1054     return S_postincdec_common(aTHX_ sv, TARG);
1055 }
1056
1057
1058 /* Ordinary operators. */
1059
1060 PP(pp_pow)
1061 {
1062     dSP; dATARGET; SV *svl, *svr;
1063 #ifdef PERL_PRESERVE_IVUV
1064     bool is_int = 0;
1065 #endif
1066     tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
1067     svr = TOPs;
1068     svl = TOPm1s;
1069 #ifdef PERL_PRESERVE_IVUV
1070     /* For integer to integer power, we do the calculation by hand wherever
1071        we're sure it is safe; otherwise we call pow() and try to convert to
1072        integer afterwards. */
1073     if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1074                 UV power;
1075                 bool baseuok;
1076                 UV baseuv;
1077
1078                 if (SvUOK(svr)) {
1079                     power = SvUVX(svr);
1080                 } else {
1081                     const IV iv = SvIVX(svr);
1082                     if (iv >= 0) {
1083                         power = iv;
1084                     } else {
1085                         goto float_it; /* Can't do negative powers this way.  */
1086                     }
1087                 }
1088
1089                 baseuok = SvUOK(svl);
1090                 if (baseuok) {
1091                     baseuv = SvUVX(svl);
1092                 } else {
1093                     const IV iv = SvIVX(svl);
1094                     if (iv >= 0) {
1095                         baseuv = iv;
1096                         baseuok = TRUE; /* effectively it's a UV now */
1097                     } else {
1098                         baseuv = -iv; /* abs, baseuok == false records sign */
1099                     }
1100                 }
1101                 /* now we have integer ** positive integer. */
1102                 is_int = 1;
1103
1104                 /* foo & (foo - 1) is zero only for a power of 2.  */
1105                 if (!(baseuv & (baseuv - 1))) {
1106                     /* We are raising power-of-2 to a positive integer.
1107                        The logic here will work for any base (even non-integer
1108                        bases) but it can be less accurate than
1109                        pow (base,power) or exp (power * log (base)) when the
1110                        intermediate values start to spill out of the mantissa.
1111                        With powers of 2 we know this can't happen.
1112                        And powers of 2 are the favourite thing for perl
1113                        programmers to notice ** not doing what they mean. */
1114                     NV result = 1.0;
1115                     NV base = baseuok ? baseuv : -(NV)baseuv;
1116
1117                     if (power & 1) {
1118                         result *= base;
1119                     }
1120                     while (power >>= 1) {
1121                         base *= base;
1122                         if (power & 1) {
1123                             result *= base;
1124                         }
1125                     }
1126                     SP--;
1127                     SETn( result );
1128                     SvIV_please_nomg(svr);
1129                     RETURN;
1130                 } else {
1131                     unsigned int highbit = 8 * sizeof(UV);
1132                     unsigned int diff = 8 * sizeof(UV);
1133                     while (diff >>= 1) {
1134                         highbit -= diff;
1135                         if (baseuv >> highbit) {
1136                             highbit += diff;
1137                         }
1138                     }
1139                     /* we now have baseuv < 2 ** highbit */
1140                     if (power * highbit <= 8 * sizeof(UV)) {
1141                         /* result will definitely fit in UV, so use UV math
1142                            on same algorithm as above */
1143                         UV result = 1;
1144                         UV base = baseuv;
1145                         const bool odd_power = cBOOL(power & 1);
1146                         if (odd_power) {
1147                             result *= base;
1148                         }
1149                         while (power >>= 1) {
1150                             base *= base;
1151                             if (power & 1) {
1152                                 result *= base;
1153                             }
1154                         }
1155                         SP--;
1156                         if (baseuok || !odd_power)
1157                             /* answer is positive */
1158                             SETu( result );
1159                         else if (result <= (UV)IV_MAX)
1160                             /* answer negative, fits in IV */
1161                             SETi( -(IV)result );
1162                         else if (result == (UV)IV_MIN)
1163                             /* 2's complement assumption: special case IV_MIN */
1164                             SETi( IV_MIN );
1165                         else
1166                             /* answer negative, doesn't fit */
1167                             SETn( -(NV)result );
1168                         RETURN;
1169                     }
1170                 }
1171     }
1172   float_it:
1173 #endif
1174     {
1175         NV right = SvNV_nomg(svr);
1176         NV left  = SvNV_nomg(svl);
1177         (void)POPs;
1178
1179 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1180     /*
1181     We are building perl with long double support and are on an AIX OS
1182     afflicted with a powl() function that wrongly returns NaNQ for any
1183     negative base.  This was reported to IBM as PMR #23047-379 on
1184     03/06/2006.  The problem exists in at least the following versions
1185     of AIX and the libm fileset, and no doubt others as well:
1186
1187         AIX 4.3.3-ML10      bos.adt.libm 4.3.3.50
1188         AIX 5.1.0-ML04      bos.adt.libm 5.1.0.29
1189         AIX 5.2.0           bos.adt.libm 5.2.0.85
1190
1191     So, until IBM fixes powl(), we provide the following workaround to
1192     handle the problem ourselves.  Our logic is as follows: for
1193     negative bases (left), we use fmod(right, 2) to check if the
1194     exponent is an odd or even integer:
1195
1196         - if odd,  powl(left, right) == -powl(-left, right)
1197         - if even, powl(left, right) ==  powl(-left, right)
1198
1199     If the exponent is not an integer, the result is rightly NaNQ, so
1200     we just return that (as NV_NAN).
1201     */
1202
1203         if (left < 0.0) {
1204             NV mod2 = Perl_fmod( right, 2.0 );
1205             if (mod2 == 1.0 || mod2 == -1.0) {  /* odd integer */
1206                 SETn( -Perl_pow( -left, right) );
1207             } else if (mod2 == 0.0) {           /* even integer */
1208                 SETn( Perl_pow( -left, right) );
1209             } else {                            /* fractional power */
1210                 SETn( NV_NAN );
1211             }
1212         } else {
1213             SETn( Perl_pow( left, right) );
1214         }
1215 #else
1216         SETn( Perl_pow( left, right) );
1217 #endif  /* HAS_AIX_POWL_NEG_BASE_BUG */
1218
1219 #ifdef PERL_PRESERVE_IVUV
1220         if (is_int)
1221             SvIV_please_nomg(svr);
1222 #endif
1223         RETURN;
1224     }
1225 }
1226
1227 PP(pp_multiply)
1228 {
1229     dSP; dATARGET; SV *svl, *svr;
1230     tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1231     svr = TOPs;
1232     svl = TOPm1s;
1233
1234 #ifdef PERL_PRESERVE_IVUV
1235
1236     /* special-case some simple common cases */
1237     if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1238         IV il, ir;
1239         U32 flags = (svl->sv_flags & svr->sv_flags);
1240         if (flags & SVf_IOK) {
1241             /* both args are simple IVs */
1242             UV topl, topr;
1243             il = SvIVX(svl);
1244             ir = SvIVX(svr);
1245           do_iv:
1246             topl = ((UV)il) >> (UVSIZE * 4 - 1);
1247             topr = ((UV)ir) >> (UVSIZE * 4 - 1);
1248
1249             /* if both are in a range that can't under/overflow, do a
1250              * simple integer multiply: if the top halves(*) of both numbers
1251              * are 00...00  or 11...11, then it's safe.
1252              * (*) for 32-bits, the "top half" is the top 17 bits,
1253              *     for 64-bits, its 33 bits */
1254             if (!(
1255                       ((topl+1) | (topr+1))
1256                     & ( (((UV)1) << (UVSIZE * 4 + 1)) - 2) /* 11..110 */
1257             )) {
1258                 SP--;
1259                 TARGi(il * ir, 0); /* args not GMG, so can't be tainted */
1260                 SETs(TARG);
1261                 RETURN;
1262             }
1263             goto generic;
1264         }
1265         else if (flags & SVf_NOK) {
1266             /* both args are NVs */
1267             NV nl = SvNVX(svl);
1268             NV nr = SvNVX(svr);
1269             NV result;
1270
1271             if (lossless_NV_to_IV(nl, &il) && lossless_NV_to_IV(nr, &ir)) {
1272                 /* nothing was lost by converting to IVs */
1273                 goto do_iv;
1274             }
1275             SP--;
1276             result = nl * nr;
1277 #  if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16
1278             if (Perl_isinf(result)) {
1279                 Zero((U8*)&result + 8, 8, U8);
1280             }
1281 #  endif
1282             TARGn(result, 0); /* args not GMG, so can't be tainted */
1283             SETs(TARG);
1284             RETURN;
1285         }
1286     }
1287
1288   generic:
1289
1290     if (SvIV_please_nomg(svr)) {
1291         /* Unless the left argument is integer in range we are going to have to
1292            use NV maths. Hence only attempt to coerce the right argument if
1293            we know the left is integer.  */
1294         /* Left operand is defined, so is it IV? */
1295         if (SvIV_please_nomg(svl)) {
1296             bool auvok = SvUOK(svl);
1297             bool buvok = SvUOK(svr);
1298             const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1299             const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1300             UV alow;
1301             UV ahigh;
1302             UV blow;
1303             UV bhigh;
1304
1305             if (auvok) {
1306                 alow = SvUVX(svl);
1307             } else {
1308                 const IV aiv = SvIVX(svl);
1309                 if (aiv >= 0) {
1310                     alow = aiv;
1311                     auvok = TRUE; /* effectively it's a UV now */
1312                 } else {
1313                     /* abs, auvok == false records sign; Using 0- here and
1314                      * later to silence bogus warning from MS VC */
1315                     alow = (UV) (0 - (UV) aiv);
1316                 }
1317             }
1318             if (buvok) {
1319                 blow = SvUVX(svr);
1320             } else {
1321                 const IV biv = SvIVX(svr);
1322                 if (biv >= 0) {
1323                     blow = biv;
1324                     buvok = TRUE; /* effectively it's a UV now */
1325                 } else {
1326                     /* abs, buvok == false records sign */
1327                     blow = (UV) (0 - (UV) biv);
1328                 }
1329             }
1330
1331             /* If this does sign extension on unsigned it's time for plan B  */
1332             ahigh = alow >> (4 * sizeof (UV));
1333             alow &= botmask;
1334             bhigh = blow >> (4 * sizeof (UV));
1335             blow &= botmask;
1336             if (ahigh && bhigh) {
1337                 NOOP;
1338                 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1339                    which is overflow. Drop to NVs below.  */
1340             } else if (!ahigh && !bhigh) {
1341                 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1342                    so the unsigned multiply cannot overflow.  */
1343                 const UV product = alow * blow;
1344                 if (auvok == buvok) {
1345                     /* -ve * -ve or +ve * +ve gives a +ve result.  */
1346                     SP--;
1347                     SETu( product );
1348                     RETURN;
1349                 } else if (product <= (UV)IV_MIN) {
1350                     /* 2s complement assumption that (UV)-IV_MIN is correct.  */
1351                     /* -ve result, which could overflow an IV  */
1352                     SP--;
1353                     /* can't negate IV_MIN, but there are aren't two
1354                      * integers such that !ahigh && !bhigh, where the
1355                      * product equals 0x800....000 */
1356                     assert(product != (UV)IV_MIN);
1357                     SETi( -(IV)product );
1358                     RETURN;
1359                 } /* else drop to NVs below. */
1360             } else {
1361                 /* One operand is large, 1 small */
1362                 UV product_middle;
1363                 if (bhigh) {
1364                     /* swap the operands */
1365                     ahigh = bhigh;
1366                     bhigh = blow; /* bhigh now the temp var for the swap */
1367                     blow = alow;
1368                     alow = bhigh;
1369                 }
1370                 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1371                    multiplies can't overflow. shift can, add can, -ve can.  */
1372                 product_middle = ahigh * blow;
1373                 if (!(product_middle & topmask)) {
1374                     /* OK, (ahigh * blow) won't lose bits when we shift it.  */
1375                     UV product_low;
1376                     product_middle <<= (4 * sizeof (UV));
1377                     product_low = alow * blow;
1378
1379                     /* as for pp_add, UV + something mustn't get smaller.
1380                        IIRC ANSI mandates this wrapping *behaviour* for
1381                        unsigned whatever the actual representation*/
1382                     product_low += product_middle;
1383                     if (product_low >= product_middle) {
1384                         /* didn't overflow */
1385                         if (auvok == buvok) {
1386                             /* -ve * -ve or +ve * +ve gives a +ve result.  */
1387                             SP--;
1388                             SETu( product_low );
1389                             RETURN;
1390                         } else if (product_low <= (UV)IV_MIN) {
1391                             /* 2s complement assumption again  */
1392                             /* -ve result, which could overflow an IV  */
1393                             SP--;
1394                             SETi(product_low == (UV)IV_MIN
1395                                     ? IV_MIN : -(IV)product_low);
1396                             RETURN;
1397                         } /* else drop to NVs below. */
1398                     }
1399                 } /* product_middle too large */
1400             } /* ahigh && bhigh */
1401         } /* SvIOK(svl) */
1402     } /* SvIOK(svr) */
1403 #endif
1404     {
1405       NV right = SvNV_nomg(svr);
1406       NV left  = SvNV_nomg(svl);
1407       NV result = left * right;
1408
1409       (void)POPs;
1410 #if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16
1411       if (Perl_isinf(result)) {
1412           Zero((U8*)&result + 8, 8, U8);
1413       }
1414 #endif
1415       SETn(result);
1416       RETURN;
1417     }
1418 }
1419
1420 PP(pp_divide)
1421 {
1422     dSP; dATARGET; SV *svl, *svr;
1423     tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1424     svr = TOPs;
1425     svl = TOPm1s;
1426     /* Only try to do UV divide first
1427        if ((SLOPPYDIVIDE is true) or
1428            (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1429             to preserve))
1430        The assumption is that it is better to use floating point divide
1431        whenever possible, only doing integer divide first if we can't be sure.
1432        If NV_PRESERVES_UV is true then we know at compile time that no UV
1433        can be too large to preserve, so don't need to compile the code to
1434        test the size of UVs.  */
1435
1436 #if defined(SLOPPYDIVIDE) || (defined(PERL_PRESERVE_IVUV) && !defined(NV_PRESERVES_UV))
1437 #  define PERL_TRY_UV_DIVIDE
1438     /* ensure that 20./5. == 4. */
1439 #endif
1440
1441 #ifdef PERL_TRY_UV_DIVIDE
1442     if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1443             bool left_non_neg = SvUOK(svl);
1444             bool right_non_neg = SvUOK(svr);
1445             UV left;
1446             UV right;
1447
1448             if (right_non_neg) {
1449                 right = SvUVX(svr);
1450             }
1451             else {
1452                 const IV biv = SvIVX(svr);
1453                 if (biv >= 0) {
1454                     right = biv;
1455                     right_non_neg = TRUE; /* effectively it's a UV now */
1456                 }
1457                 else {
1458                     right = -(UV)biv;
1459                 }
1460             }
1461             /* historically undef()/0 gives a "Use of uninitialized value"
1462                warning before dieing, hence this test goes here.
1463                If it were immediately before the second SvIV_please, then
1464                DIE() would be invoked before left was even inspected, so
1465                no inspection would give no warning.  */
1466             if (right == 0)
1467                 DIE(aTHX_ "Illegal division by zero");
1468
1469             if (left_non_neg) {
1470                 left = SvUVX(svl);
1471             }
1472             else {
1473                 const IV aiv = SvIVX(svl);
1474                 if (aiv >= 0) {
1475                     left = aiv;
1476                     left_non_neg = TRUE; /* effectively it's a UV now */
1477                 }
1478                 else {
1479                     left = -(UV)aiv;
1480                 }
1481             }
1482
1483             if (left >= right
1484 #ifdef SLOPPYDIVIDE
1485                 /* For sloppy divide we always attempt integer division.  */
1486 #else
1487                 /* Otherwise we only attempt it if either or both operands
1488                    would not be preserved by an NV.  If both fit in NVs
1489                    we fall through to the NV divide code below.  However,
1490                    as left >= right to ensure integer result here, we know that
1491                    we can skip the test on the right operand - right big
1492                    enough not to be preserved can't get here unless left is
1493                    also too big.  */
1494
1495                 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1496 #endif
1497                 ) {
1498                 /* Integer division can't overflow, but it can be imprecise.  */
1499
1500                 /* Modern compilers optimize division followed by
1501                  * modulo into a single div instruction */
1502                 const UV result = left / right;
1503                 if (left % right == 0) {
1504                     SP--; /* result is valid */
1505                     if (left_non_neg == right_non_neg) {
1506                         /* signs identical, result is positive.  */
1507                         SETu( result );
1508                         RETURN;
1509                     }
1510                     /* 2s complement assumption */
1511                     if (result <= (UV)IV_MIN)
1512                         SETi(result == (UV)IV_MIN ? IV_MIN : -(IV)result);
1513                     else {
1514                         /* It's exact but too negative for IV. */
1515                         SETn( -(NV)result );
1516                     }
1517                     RETURN;
1518                 } /* tried integer divide but it was not an integer result */
1519             } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1520     } /* one operand wasn't SvIOK */
1521 #endif /* PERL_TRY_UV_DIVIDE */
1522     {
1523         NV right = SvNV_nomg(svr);
1524         NV left  = SvNV_nomg(svl);
1525         (void)POPs;(void)POPs;
1526 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1527         if (! Perl_isnan(right) && right == 0.0)
1528 #else
1529         if (right == 0.0)
1530 #endif
1531             DIE(aTHX_ "Illegal division by zero");
1532         PUSHn( left / right );
1533         RETURN;
1534     }
1535 }
1536
1537 PP(pp_modulo)
1538 {
1539     dSP; dATARGET;
1540     tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
1541     {
1542         UV left  = 0;
1543         UV right = 0;
1544         bool left_neg = FALSE;
1545         bool right_neg = FALSE;
1546         bool use_double = FALSE;
1547         bool dright_valid = FALSE;
1548         NV dright = 0.0;
1549         NV dleft  = 0.0;
1550         SV * const svr = TOPs;
1551         SV * const svl = TOPm1s;
1552         if (SvIV_please_nomg(svr)) {
1553             right_neg = !SvUOK(svr);
1554             if (!right_neg) {
1555                 right = SvUVX(svr);
1556             } else {
1557                 const IV biv = SvIVX(svr);
1558                 if (biv >= 0) {
1559                     right = biv;
1560                     right_neg = FALSE; /* effectively it's a UV now */
1561                 } else {
1562                     right = (UV) (0 - (UV) biv);
1563                 }
1564             }
1565         }
1566         else {
1567             dright = SvNV_nomg(svr);
1568             right_neg = dright < 0;
1569             if (right_neg)
1570                 dright = -dright;
1571             if (dright < UV_MAX_P1) {
1572                 right = U_V(dright);
1573                 dright_valid = TRUE; /* In case we need to use double below.  */
1574             } else {
1575                 use_double = TRUE;
1576             }
1577         }
1578
1579         /* At this point use_double is only true if right is out of range for
1580            a UV.  In range NV has been rounded down to nearest UV and
1581            use_double false.  */
1582         if (!use_double && SvIV_please_nomg(svl)) {
1583                 left_neg = !SvUOK(svl);
1584                 if (!left_neg) {
1585                     left = SvUVX(svl);
1586                 } else {
1587                     const IV aiv = SvIVX(svl);
1588                     if (aiv >= 0) {
1589                         left = aiv;
1590                         left_neg = FALSE; /* effectively it's a UV now */
1591                     } else {
1592                         left = (UV) (0 - (UV) aiv);
1593                     }
1594                 }
1595         }
1596         else {
1597             dleft = SvNV_nomg(svl);
1598             left_neg = dleft < 0;
1599             if (left_neg)
1600                 dleft = -dleft;
1601
1602             /* This should be exactly the 5.6 behaviour - if left and right are
1603                both in range for UV then use U_V() rather than floor.  */
1604             if (!use_double) {
1605                 if (dleft < UV_MAX_P1) {
1606                     /* right was in range, so is dleft, so use UVs not double.
1607                      */
1608                     left = U_V(dleft);
1609                 }
1610                 /* left is out of range for UV, right was in range, so promote
1611                    right (back) to double.  */
1612                 else {
1613                     /* The +0.5 is used in 5.6 even though it is not strictly
1614                        consistent with the implicit +0 floor in the U_V()
1615                        inside the #if 1. */
1616                     dleft = Perl_floor(dleft + 0.5);
1617                     use_double = TRUE;
1618                     if (dright_valid)
1619                         dright = Perl_floor(dright + 0.5);
1620                     else
1621                         dright = right;
1622                 }
1623             }
1624         }
1625         sp -= 2;
1626         if (use_double) {
1627             NV dans;
1628
1629             if (!dright)
1630                 DIE(aTHX_ "Illegal modulus zero");
1631
1632             dans = Perl_fmod(dleft, dright);
1633             if ((left_neg != right_neg) && dans)
1634                 dans = dright - dans;
1635             if (right_neg)
1636                 dans = -dans;
1637             sv_setnv(TARG, dans);
1638         }
1639         else {
1640             UV ans;
1641
1642             if (!right)
1643                 DIE(aTHX_ "Illegal modulus zero");
1644
1645             ans = left % right;
1646             if ((left_neg != right_neg) && ans)
1647                 ans = right - ans;
1648             if (right_neg) {
1649                 /* XXX may warn: unary minus operator applied to unsigned type */
1650                 /* could change -foo to be (~foo)+1 instead     */
1651                 if (ans <= ~((UV)IV_MAX)+1)
1652                     sv_setiv(TARG, ~ans+1);
1653                 else
1654                     sv_setnv(TARG, -(NV)ans);
1655             }
1656             else
1657                 sv_setuv(TARG, ans);
1658         }
1659         PUSHTARG;
1660         RETURN;
1661     }
1662 }
1663
1664 PP(pp_repeat)
1665 {
1666     dSP; dATARGET;
1667     IV count;
1668     SV *sv;
1669     bool infnan = FALSE;
1670     const U8 gimme = GIMME_V;
1671
1672     if (gimme == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1673         /* TODO: think of some way of doing list-repeat overloading ??? */
1674         sv = POPs;
1675         SvGETMAGIC(sv);
1676     }
1677     else {
1678         if (UNLIKELY(PL_op->op_private & OPpREPEAT_DOLIST)) {
1679             /* The parser saw this as a list repeat, and there
1680                are probably several items on the stack. But we're
1681                in scalar/void context, and there's no pp_list to save us
1682                now. So drop the rest of the items -- robin@kitsite.com
1683              */
1684             dMARK;
1685             if (MARK + 1 < SP) {
1686                 MARK[1] = TOPm1s;
1687                 MARK[2] = TOPs;
1688             }
1689             else {
1690                 dTOPss;
1691                 ASSUME(MARK + 1 == SP);
1692                 MEXTEND(SP, 1);
1693                 PUSHs(sv);
1694                 MARK[1] = &PL_sv_undef;
1695             }
1696             SP = MARK + 2;
1697         }
1698         tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1699         sv = POPs;
1700     }
1701
1702     if (SvIOKp(sv)) {
1703          if (SvUOK(sv)) {
1704               const UV uv = SvUV_nomg(sv);
1705               if (uv > IV_MAX)
1706                    count = IV_MAX; /* The best we can do? */
1707               else
1708                    count = uv;
1709          } else {
1710               count = SvIV_nomg(sv);
1711          }
1712     }
1713     else if (SvNOKp(sv)) {
1714         const NV nv = SvNV_nomg(sv);
1715         infnan = Perl_isinfnan(nv);
1716         if (UNLIKELY(infnan)) {
1717             count = 0;
1718         } else {
1719             if (nv < 0.0)
1720                 count = -1;   /* An arbitrary negative integer */
1721             else
1722                 count = (IV)nv;
1723         }
1724     }
1725     else
1726         count = SvIV_nomg(sv);
1727
1728     if (infnan) {
1729         Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1730                        "Non-finite repeat count does nothing");
1731     } else if (count < 0) {
1732         count = 0;
1733         Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1734                        "Negative repeat count does nothing");
1735     }
1736
1737     if (gimme == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1738         dMARK;
1739         const SSize_t items = SP - MARK;
1740         const U8 mod = PL_op->op_flags & OPf_MOD;
1741
1742         if (count > 1) {
1743             SSize_t max;
1744
1745             if (  items > SSize_t_MAX / count   /* max would overflow */
1746                                                 /* repeatcpy would overflow */
1747                || items > I32_MAX / (I32)sizeof(SV *)
1748             )
1749                Perl_croak(aTHX_ "%s","Out of memory during list extend");
1750             max = items * count;
1751             MEXTEND(MARK, max);
1752
1753             while (SP > MARK) {
1754                 if (*SP) {
1755                    if (mod && SvPADTMP(*SP)) {
1756                        *SP = sv_mortalcopy(*SP);
1757                    }
1758                    SvTEMP_off((*SP));
1759                 }
1760                 SP--;
1761             }
1762             MARK++;
1763             repeatcpy((char*)(MARK + items), (char*)MARK,
1764                 items * sizeof(const SV *), count - 1);
1765             SP += max;
1766         }
1767         else if (count <= 0)
1768             SP = MARK;
1769     }
1770     else {      /* Note: mark already snarfed by pp_list */
1771         SV * const tmpstr = POPs;
1772         STRLEN len;
1773         bool isutf;
1774
1775         if (TARG != tmpstr)
1776             sv_setsv_nomg(TARG, tmpstr);
1777         SvPV_force_nomg(TARG, len);
1778         isutf = DO_UTF8(TARG);
1779         if (count != 1) {
1780             if (count < 1)
1781                 SvCUR_set(TARG, 0);
1782             else {
1783                 STRLEN max;
1784
1785                 if (   len > (MEM_SIZE_MAX-1) / (UV)count /* max would overflow */
1786                     || len > (U32)I32_MAX  /* repeatcpy would overflow */
1787                 )
1788                      Perl_croak(aTHX_ "%s",
1789                                         "Out of memory during string extend");
1790                 max = (UV)count * len + 1;
1791                 SvGROW(TARG, max);
1792
1793                 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1794                 SvCUR_set(TARG, SvCUR(TARG) * count);
1795             }
1796             *SvEND(TARG) = '\0';
1797         }
1798         if (isutf)
1799             (void)SvPOK_only_UTF8(TARG);
1800         else
1801             (void)SvPOK_only(TARG);
1802
1803         PUSHTARG;
1804     }
1805     RETURN;
1806 }
1807
1808 PP(pp_subtract)
1809 {
1810     dSP; dATARGET; bool useleft; SV *svl, *svr;
1811     tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1812     svr = TOPs;
1813     svl = TOPm1s;
1814
1815 #ifdef PERL_PRESERVE_IVUV
1816
1817     /* special-case some simple common cases */
1818     if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1819         IV il, ir;
1820         U32 flags = (svl->sv_flags & svr->sv_flags);
1821         if (flags & SVf_IOK) {
1822             /* both args are simple IVs */
1823             UV topl, topr;
1824             il = SvIVX(svl);
1825             ir = SvIVX(svr);
1826           do_iv:
1827             topl = ((UV)il) >> (UVSIZE * 8 - 2);
1828             topr = ((UV)ir) >> (UVSIZE * 8 - 2);
1829
1830             /* if both are in a range that can't under/overflow, do a
1831              * simple integer subtract: if the top of both numbers
1832              * are 00  or 11, then it's safe */
1833             if (!( ((topl+1) | (topr+1)) & 2)) {
1834                 SP--;
1835                 TARGi(il - ir, 0); /* args not GMG, so can't be tainted */
1836                 SETs(TARG);
1837                 RETURN;
1838             }
1839             goto generic;
1840         }
1841         else if (flags & SVf_NOK) {
1842             /* both args are NVs */
1843             NV nl = SvNVX(svl);
1844             NV nr = SvNVX(svr);
1845
1846             if (lossless_NV_to_IV(nl, &il) && lossless_NV_to_IV(nr, &ir)) {
1847                 /* nothing was lost by converting to IVs */
1848                 goto do_iv;
1849             }
1850             SP--;
1851             TARGn(nl - nr, 0); /* args not GMG, so can't be tainted */
1852             SETs(TARG);
1853             RETURN;
1854         }
1855     }
1856
1857   generic:
1858
1859     useleft = USE_LEFT(svl);
1860     /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1861        "bad things" happen if you rely on signed integers wrapping.  */
1862     if (SvIV_please_nomg(svr)) {
1863         /* Unless the left argument is integer in range we are going to have to
1864            use NV maths. Hence only attempt to coerce the right argument if
1865            we know the left is integer.  */
1866         UV auv = 0;
1867         bool auvok = FALSE;
1868         bool a_valid = 0;
1869
1870         if (!useleft) {
1871             auv = 0;
1872             a_valid = auvok = 1;
1873             /* left operand is undef, treat as zero.  */
1874         } else {
1875             /* Left operand is defined, so is it IV? */
1876             if (SvIV_please_nomg(svl)) {
1877                 if ((auvok = SvUOK(svl)))
1878                     auv = SvUVX(svl);
1879                 else {
1880                     const IV aiv = SvIVX(svl);
1881                     if (aiv >= 0) {
1882                         auv = aiv;
1883                         auvok = 1;      /* Now acting as a sign flag.  */
1884                     } else {
1885                         auv = (UV) (0 - (UV) aiv);
1886                     }
1887                 }
1888                 a_valid = 1;
1889             }
1890         }
1891         if (a_valid) {
1892             bool result_good = 0;
1893             UV result;
1894             UV buv;
1895             bool buvok = SvUOK(svr);
1896
1897             if (buvok)
1898                 buv = SvUVX(svr);
1899             else {
1900                 const IV biv = SvIVX(svr);
1901                 if (biv >= 0) {
1902                     buv = biv;
1903                     buvok = 1;
1904                 } else
1905                     buv = (UV) (0 - (UV) biv);
1906             }
1907             /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1908                else "IV" now, independent of how it came in.
1909                if a, b represents positive, A, B negative, a maps to -A etc
1910                a - b =>  (a - b)
1911                A - b => -(a + b)
1912                a - B =>  (a + b)
1913                A - B => -(a - b)
1914                all UV maths. negate result if A negative.
1915                subtract if signs same, add if signs differ. */
1916
1917             if (auvok ^ buvok) {
1918                 /* Signs differ.  */
1919                 result = auv + buv;
1920                 if (result >= auv)
1921                     result_good = 1;
1922             } else {
1923                 /* Signs same */
1924                 if (auv >= buv) {
1925                     result = auv - buv;
1926                     /* Must get smaller */
1927                     if (result <= auv)
1928                         result_good = 1;
1929                 } else {
1930                     result = buv - auv;
1931                     if (result <= buv) {
1932                         /* result really should be -(auv-buv). as its negation
1933                            of true value, need to swap our result flag  */
1934                         auvok = !auvok;
1935                         result_good = 1;
1936                     }
1937                 }
1938             }
1939             if (result_good) {
1940                 SP--;
1941                 if (auvok)
1942                     SETu( result );
1943                 else {
1944                     /* Negate result */
1945                     if (result <= (UV)IV_MIN)
1946                         SETi(result == (UV)IV_MIN
1947                                 ? IV_MIN : -(IV)result);
1948                     else {
1949                         /* result valid, but out of range for IV.  */
1950                         SETn( -(NV)result );
1951                     }
1952                 }
1953                 RETURN;
1954             } /* Overflow, drop through to NVs.  */
1955         }
1956     }
1957 #else
1958     useleft = USE_LEFT(svl);
1959 #endif
1960     {
1961         NV value = SvNV_nomg(svr);
1962         (void)POPs;
1963
1964         if (!useleft) {
1965             /* left operand is undef, treat as zero - value */
1966             SETn(-value);
1967             RETURN;
1968         }
1969         SETn( SvNV_nomg(svl) - value );
1970         RETURN;
1971     }
1972 }
1973
1974 #define IV_BITS (IVSIZE * 8)
1975
1976 static UV S_uv_shift(UV uv, int shift, bool left)
1977 {
1978    if (shift < 0) {
1979        shift = -shift;
1980        left = !left;
1981    }
1982    if (UNLIKELY(shift >= IV_BITS)) {
1983        return 0;
1984    }
1985    return left ? uv << shift : uv >> shift;
1986 }
1987
1988 static IV S_iv_shift(IV iv, int shift, bool left)
1989 {
1990     if (shift < 0) {
1991         shift = -shift;
1992         left = !left;
1993     }
1994
1995     if (UNLIKELY(shift >= IV_BITS)) {
1996         return iv < 0 && !left ? -1 : 0;
1997     }
1998
1999     /* For left shifts, perl 5 has chosen to treat the value as unsigned for
2000      * the * purposes of shifting, then cast back to signed.  This is very
2001      * different from Raku:
2002      *
2003      * $ raku -e 'say -2 +< 5'
2004      * -64
2005      *
2006      * $ ./perl -le 'print -2 << 5'
2007      * 18446744073709551552
2008      * */
2009     if (left) {
2010         if (iv == IV_MIN) { /* Casting this to a UV is undefined behavior */
2011             return 0;
2012         }
2013         return (IV) (((UV) iv) << shift);
2014     }
2015
2016     /* Here is right shift */
2017     return iv >> shift;
2018 }
2019
2020 #define UV_LEFT_SHIFT(uv, shift) S_uv_shift(uv, shift, TRUE)
2021 #define UV_RIGHT_SHIFT(uv, shift) S_uv_shift(uv, shift, FALSE)
2022 #define IV_LEFT_SHIFT(iv, shift) S_iv_shift(iv, shift, TRUE)
2023 #define IV_RIGHT_SHIFT(iv, shift) S_iv_shift(iv, shift, FALSE)
2024
2025 PP(pp_left_shift)
2026 {
2027     dSP; dATARGET; SV *svl, *svr;
2028     tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
2029     svr = POPs;
2030     svl = TOPs;
2031     {
2032       const IV shift = SvIV_nomg(svr);
2033       if (PL_op->op_private & HINT_INTEGER) {
2034           SETi(IV_LEFT_SHIFT(SvIV_nomg(svl), shift));
2035       }
2036       else {
2037           SETu(UV_LEFT_SHIFT(SvUV_nomg(svl), shift));
2038       }
2039       RETURN;
2040     }
2041 }
2042
2043 PP(pp_right_shift)
2044 {
2045     dSP; dATARGET; SV *svl, *svr;
2046     tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
2047     svr = POPs;
2048     svl = TOPs;
2049     {
2050       const IV shift = SvIV_nomg(svr);
2051       if (PL_op->op_private & HINT_INTEGER) {
2052           SETi(IV_RIGHT_SHIFT(SvIV_nomg(svl), shift));
2053       }
2054       else {
2055           SETu(UV_RIGHT_SHIFT(SvUV_nomg(svl), shift));
2056       }
2057       RETURN;
2058     }
2059 }
2060
2061 PP(pp_lt)
2062 {
2063     dSP;
2064     SV *left, *right;
2065     U32 flags_and, flags_or;
2066
2067     tryAMAGICbin_MG(lt_amg, AMGf_numeric);
2068     right = POPs;
2069     left  = TOPs;
2070     flags_and = SvFLAGS(left) & SvFLAGS(right);
2071     flags_or  = SvFLAGS(left) | SvFLAGS(right);
2072
2073     SETs(boolSV(
2074         ( (flags_and & SVf_IOK) && ((flags_or & SVf_IVisUV) ==0 ) )
2075         ?    (SvIVX(left) < SvIVX(right))
2076         : (flags_and & SVf_NOK)
2077         ?    (SvNVX(left) < SvNVX(right))
2078         : (do_ncmp(left, right) == -1)
2079     ));
2080     RETURN;
2081 }
2082
2083 PP(pp_gt)
2084 {
2085     dSP;
2086     SV *left, *right;
2087     U32 flags_and, flags_or;
2088
2089     tryAMAGICbin_MG(gt_amg, AMGf_numeric);
2090     right = POPs;
2091     left  = TOPs;
2092     flags_and = SvFLAGS(left) & SvFLAGS(right);
2093     flags_or  = SvFLAGS(left) | SvFLAGS(right);
2094
2095     SETs(boolSV(
2096         ( (flags_and & SVf_IOK) && ((flags_or & SVf_IVisUV) ==0 ) )
2097         ?    (SvIVX(left) > SvIVX(right))
2098         : (flags_and & SVf_NOK)
2099         ?    (SvNVX(left) > SvNVX(right))
2100         : (do_ncmp(left, right) == 1)
2101     ));
2102     RETURN;
2103 }
2104
2105 PP(pp_le)
2106 {
2107     dSP;
2108     SV *left, *right;
2109     U32 flags_and, flags_or;
2110
2111     tryAMAGICbin_MG(le_amg, AMGf_numeric);
2112     right = POPs;
2113     left  = TOPs;
2114     flags_and = SvFLAGS(left) & SvFLAGS(right);
2115     flags_or  = SvFLAGS(left) | SvFLAGS(right);
2116
2117     SETs(boolSV(
2118         ( (flags_and & SVf_IOK) && ((flags_or & SVf_IVisUV) ==0 ) )
2119         ?    (SvIVX(left) <= SvIVX(right))
2120         : (flags_and & SVf_NOK)
2121         ?    (SvNVX(left) <= SvNVX(right))
2122         : (do_ncmp(left, right) <= 0)
2123     ));
2124     RETURN;
2125 }
2126
2127 PP(pp_ge)
2128 {
2129     dSP;
2130     SV *left, *right;
2131     U32 flags_and, flags_or;
2132
2133     tryAMAGICbin_MG(ge_amg, AMGf_numeric);
2134     right = POPs;
2135     left  = TOPs;
2136     flags_and = SvFLAGS(left) & SvFLAGS(right);
2137     flags_or  = SvFLAGS(left) | SvFLAGS(right);
2138
2139     SETs(boolSV(
2140         ( (flags_and & SVf_IOK) && ((flags_or & SVf_IVisUV) ==0 ) )
2141         ?    (SvIVX(left) >= SvIVX(right))
2142         : (flags_and & SVf_NOK)
2143         ?    (SvNVX(left) >= SvNVX(right))
2144         : ( (do_ncmp(left, right) & 2) == 0)
2145     ));
2146     RETURN;
2147 }
2148
2149 PP(pp_ne)
2150 {
2151     dSP;
2152     SV *left, *right;
2153     U32 flags_and, flags_or;
2154
2155     tryAMAGICbin_MG(ne_amg, AMGf_numeric);
2156     right = POPs;
2157     left  = TOPs;
2158     flags_and = SvFLAGS(left) & SvFLAGS(right);
2159     flags_or  = SvFLAGS(left) | SvFLAGS(right);
2160
2161     SETs(boolSV(
2162         ( (flags_and & SVf_IOK) && ((flags_or & SVf_IVisUV) ==0 ) )
2163         ?    (SvIVX(left) != SvIVX(right))
2164         : (flags_and & SVf_NOK)
2165         ?    (SvNVX(left) != SvNVX(right))
2166         : (do_ncmp(left, right) != 0)
2167     ));
2168     RETURN;
2169 }
2170
2171 /* compare left and right SVs. Returns:
2172  * -1: <
2173  *  0: ==
2174  *  1: >
2175  *  2: left or right was a NaN
2176  */
2177 I32
2178 Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
2179 {
2180     PERL_ARGS_ASSERT_DO_NCMP;
2181 #ifdef PERL_PRESERVE_IVUV
2182     /* Fortunately it seems NaN isn't IOK */
2183     if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
2184             if (!SvUOK(left)) {
2185                 const IV leftiv = SvIVX(left);
2186                 if (!SvUOK(right)) {
2187                     /* ## IV <=> IV ## */
2188                     const IV rightiv = SvIVX(right);
2189                     return (leftiv > rightiv) - (leftiv < rightiv);
2190                 }
2191                 /* ## IV <=> UV ## */
2192                 if (leftiv < 0)
2193                     /* As (b) is a UV, it's >=0, so it must be < */
2194                     return -1;
2195                 {
2196                     const UV rightuv = SvUVX(right);
2197                     return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
2198                 }
2199             }
2200
2201             if (SvUOK(right)) {
2202                 /* ## UV <=> UV ## */
2203                 const UV leftuv = SvUVX(left);
2204                 const UV rightuv = SvUVX(right);
2205                 return (leftuv > rightuv) - (leftuv < rightuv);
2206             }
2207             /* ## UV <=> IV ## */
2208             {
2209                 const IV rightiv = SvIVX(right);
2210                 if (rightiv < 0)
2211                     /* As (a) is a UV, it's >=0, so it cannot be < */
2212                     return 1;
2213                 {
2214                     const UV leftuv = SvUVX(left);
2215                     return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
2216                 }
2217             }
2218             NOT_REACHED; /* NOTREACHED */
2219     }
2220 #endif
2221     {
2222       NV const rnv = SvNV_nomg(right);
2223       NV const lnv = SvNV_nomg(left);
2224
2225 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2226       if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2227           return 2;
2228        }
2229       return (lnv > rnv) - (lnv < rnv);
2230 #else
2231       if (lnv < rnv)
2232         return -1;
2233       if (lnv > rnv)
2234         return 1;
2235       if (lnv == rnv)
2236         return 0;
2237       return 2;
2238 #endif
2239     }
2240 }
2241
2242
2243 PP(pp_ncmp)
2244 {
2245     dSP;
2246     SV *left, *right;
2247     I32 value;
2248     tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
2249     right = POPs;
2250     left  = TOPs;
2251     value = do_ncmp(left, right);
2252     if (value == 2) {
2253         SETs(&PL_sv_undef);
2254     }
2255     else {
2256         dTARGET;
2257         SETi(value);
2258     }
2259     RETURN;
2260 }
2261
2262
2263 /* also used for: pp_sge() pp_sgt() pp_slt() */
2264
2265 PP(pp_sle)
2266 {
2267     dSP;
2268
2269     int amg_type = sle_amg;
2270     int multiplier = 1;
2271     int rhs = 1;
2272
2273     switch (PL_op->op_type) {
2274     case OP_SLT:
2275         amg_type = slt_amg;
2276         /* cmp < 0 */
2277         rhs = 0;
2278         break;
2279     case OP_SGT:
2280         amg_type = sgt_amg;
2281         /* cmp > 0 */
2282         multiplier = -1;
2283         rhs = 0;
2284         break;
2285     case OP_SGE:
2286         amg_type = sge_amg;
2287         /* cmp >= 0 */
2288         multiplier = -1;
2289         break;
2290     }
2291
2292     tryAMAGICbin_MG(amg_type, 0);
2293     {
2294       dPOPTOPssrl;
2295       const int cmp =
2296 #ifdef USE_LOCALE_COLLATE
2297                       (IN_LC_RUNTIME(LC_COLLATE))
2298                       ? sv_cmp_locale_flags(left, right, 0)
2299                       :
2300 #endif
2301                         sv_cmp_flags(left, right, 0);
2302       SETs(boolSV(cmp * multiplier < rhs));
2303       RETURN;
2304     }
2305 }
2306
2307 PP(pp_seq)
2308 {
2309     dSP;
2310     tryAMAGICbin_MG(seq_amg, 0);
2311     {
2312       dPOPTOPssrl;
2313       SETs(boolSV(sv_eq_flags(left, right, 0)));
2314       RETURN;
2315     }
2316 }
2317
2318 PP(pp_sne)
2319 {
2320     dSP;
2321     tryAMAGICbin_MG(sne_amg, 0);
2322     {
2323       dPOPTOPssrl;
2324       SETs(boolSV(!sv_eq_flags(left, right, 0)));
2325       RETURN;
2326     }
2327 }
2328
2329 PP(pp_scmp)
2330 {
2331     dSP; dTARGET;
2332     tryAMAGICbin_MG(scmp_amg, 0);
2333     {
2334       dPOPTOPssrl;
2335       const int cmp =
2336 #ifdef USE_LOCALE_COLLATE
2337                       (IN_LC_RUNTIME(LC_COLLATE))
2338                       ? sv_cmp_locale_flags(left, right, 0)
2339                       :
2340 #endif
2341                         sv_cmp_flags(left, right, 0);
2342       SETi( cmp );
2343       RETURN;
2344     }
2345 }
2346
2347 PP(pp_bit_and)
2348 {
2349     dSP; dATARGET;
2350     tryAMAGICbin_MG(band_amg, AMGf_assign);
2351     {
2352       dPOPTOPssrl;
2353       if (SvNIOKp(left) || SvNIOKp(right)) {
2354         const bool left_ro_nonnum  = !SvNIOKp(left) && SvREADONLY(left);
2355         const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2356         if (PL_op->op_private & HINT_INTEGER) {
2357           const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2358           SETi(i);
2359         }
2360         else {
2361           const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2362           SETu(u);
2363         }
2364         if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2365         if (right_ro_nonnum) SvNIOK_off(right);
2366       }
2367       else {
2368         do_vop(PL_op->op_type, TARG, left, right);
2369         SETTARG;
2370       }
2371       RETURN;
2372     }
2373 }
2374
2375 PP(pp_nbit_and)
2376 {
2377     dSP;
2378     tryAMAGICbin_MG(band_amg, AMGf_assign|AMGf_numarg);
2379     {
2380         dATARGET; dPOPTOPssrl;
2381         if (PL_op->op_private & HINT_INTEGER) {
2382           const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2383           SETi(i);
2384         }
2385         else {
2386           const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2387           SETu(u);
2388         }
2389     }
2390     RETURN;
2391 }
2392
2393 PP(pp_sbit_and)
2394 {
2395     dSP;
2396     tryAMAGICbin_MG(sband_amg, AMGf_assign);
2397     {
2398         dATARGET; dPOPTOPssrl;
2399         do_vop(OP_BIT_AND, TARG, left, right);
2400         RETSETTARG;
2401     }
2402 }
2403
2404 /* also used for: pp_bit_xor() */
2405
2406 PP(pp_bit_or)
2407 {
2408     dSP; dATARGET;
2409     const int op_type = PL_op->op_type;
2410
2411     tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2412     {
2413       dPOPTOPssrl;
2414       if (SvNIOKp(left) || SvNIOKp(right)) {
2415         const bool left_ro_nonnum  = !SvNIOKp(left) && SvREADONLY(left);
2416         const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2417         if (PL_op->op_private & HINT_INTEGER) {
2418           const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2419           const IV r = SvIV_nomg(right);
2420           const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2421           SETi(result);
2422         }
2423         else {
2424           const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2425           const UV r = SvUV_nomg(right);
2426           const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2427           SETu(result);
2428         }
2429         if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2430         if (right_ro_nonnum) SvNIOK_off(right);
2431       }
2432       else {
2433         do_vop(op_type, TARG, left, right);
2434         SETTARG;
2435       }
2436       RETURN;
2437     }
2438 }
2439
2440 /* also used for: pp_nbit_xor() */
2441
2442 PP(pp_nbit_or)
2443 {
2444     dSP;
2445     const int op_type = PL_op->op_type;
2446
2447     tryAMAGICbin_MG((op_type == OP_NBIT_OR ? bor_amg : bxor_amg),
2448                     AMGf_assign|AMGf_numarg);
2449     {
2450         dATARGET; dPOPTOPssrl;
2451         if (PL_op->op_private & HINT_INTEGER) {
2452           const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2453           const IV r = SvIV_nomg(right);
2454           const IV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2455           SETi(result);
2456         }
2457         else {
2458           const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2459           const UV r = SvUV_nomg(right);
2460           const UV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2461           SETu(result);
2462         }
2463     }
2464     RETURN;
2465 }
2466
2467 /* also used for: pp_sbit_xor() */
2468
2469 PP(pp_sbit_or)
2470 {
2471     dSP;
2472     const int op_type = PL_op->op_type;
2473
2474     tryAMAGICbin_MG((op_type == OP_SBIT_OR ? sbor_amg : sbxor_amg),
2475                     AMGf_assign);
2476     {
2477         dATARGET; dPOPTOPssrl;
2478         do_vop(op_type == OP_SBIT_OR ? OP_BIT_OR : OP_BIT_XOR, TARG, left,
2479                right);
2480         RETSETTARG;
2481     }
2482 }
2483
2484 PERL_STATIC_INLINE bool
2485 S_negate_string(pTHX)
2486 {
2487     dTARGET; dSP;
2488     STRLEN len;
2489     const char *s;
2490     SV * const sv = TOPs;
2491     if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2492         return FALSE;
2493     s = SvPV_nomg_const(sv, len);
2494     if (isIDFIRST(*s)) {
2495         sv_setpvs(TARG, "-");
2496         sv_catsv(TARG, sv);
2497     }
2498     else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2499         sv_setsv_nomg(TARG, sv);
2500         *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2501     }
2502     else return FALSE;
2503     SETTARG;
2504     return TRUE;
2505 }
2506
2507 PP(pp_negate)
2508 {
2509     dSP; dTARGET;
2510     tryAMAGICun_MG(neg_amg, AMGf_numeric);
2511     if (S_negate_string(aTHX)) return NORMAL;
2512     {
2513         SV * const sv = TOPs;
2514
2515         if (SvIOK(sv)) {
2516             /* It's publicly an integer */
2517         oops_its_an_int:
2518             if (SvIsUV(sv)) {
2519                 if (SvIVX(sv) == IV_MIN) {
2520                     /* 2s complement assumption. */
2521                     SETi(SvIVX(sv));    /* special case: -((UV)IV_MAX+1) ==
2522                                            IV_MIN */
2523                     return NORMAL;
2524                 }
2525                 else if (SvUVX(sv) <= IV_MAX) {
2526                     SETi(-SvIVX(sv));
2527                     return NORMAL;
2528                 }
2529             }
2530             else if (SvIVX(sv) != IV_MIN) {
2531                 SETi(-SvIVX(sv));
2532                 return NORMAL;
2533             }
2534 #ifdef PERL_PRESERVE_IVUV
2535             else {
2536                 SETu((UV)IV_MIN);
2537                 return NORMAL;
2538             }
2539 #endif
2540         }
2541         if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
2542             SETn(-SvNV_nomg(sv));
2543         else if (SvPOKp(sv) && SvIV_please_nomg(sv))
2544                   goto oops_its_an_int;
2545         else
2546             SETn(-SvNV_nomg(sv));
2547     }
2548     return NORMAL;
2549 }
2550
2551 PP(pp_not)
2552 {
2553     dSP;
2554     SV *sv;
2555
2556     tryAMAGICun_MG(not_amg, 0);
2557     sv = *PL_stack_sp;
2558     *PL_stack_sp = boolSV(!SvTRUE_nomg_NN(sv));
2559     return NORMAL;
2560 }
2561
2562 static void
2563 S_scomplement(pTHX_ SV *targ, SV *sv)
2564 {
2565         U8 *tmps;
2566         I32 anum;
2567         STRLEN len;
2568
2569         sv_copypv_nomg(TARG, sv);
2570         tmps = (U8*)SvPV_nomg(TARG, len);
2571
2572         if (SvUTF8(TARG)) {
2573             if (len && ! utf8_to_bytes(tmps, &len)) {
2574                 Perl_croak(aTHX_ FATAL_ABOVE_FF_MSG, PL_op_desc[PL_op->op_type]);
2575             }
2576             SvCUR_set(TARG, len);
2577             SvUTF8_off(TARG);
2578         }
2579
2580         anum = len;
2581
2582         {
2583             long *tmpl;
2584             for ( ; anum && PTR2nat(tmps) % sizeof(long); anum--, tmps++)
2585                 *tmps = ~*tmps;
2586             tmpl = (long*)tmps;
2587             for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2588                 *tmpl = ~*tmpl;
2589             tmps = (U8*)tmpl;
2590         }
2591
2592         for ( ; anum > 0; anum--, tmps++)
2593             *tmps = ~*tmps;
2594 }
2595
2596 PP(pp_complement)
2597 {
2598     dSP; dTARGET;
2599     tryAMAGICun_MG(compl_amg, AMGf_numeric);
2600     {
2601       dTOPss;
2602       if (SvNIOKp(sv)) {
2603         if (PL_op->op_private & HINT_INTEGER) {
2604           const IV i = ~SvIV_nomg(sv);
2605           SETi(i);
2606         }
2607         else {
2608           const UV u = ~SvUV_nomg(sv);
2609           SETu(u);
2610         }
2611       }
2612       else {
2613         S_scomplement(aTHX_ TARG, sv);
2614         SETTARG;
2615       }
2616       return NORMAL;
2617     }
2618 }
2619
2620 PP(pp_ncomplement)
2621 {
2622     dSP;
2623     tryAMAGICun_MG(compl_amg, AMGf_numeric|AMGf_numarg);
2624     {
2625         dTARGET; dTOPss;
2626         if (PL_op->op_private & HINT_INTEGER) {
2627           const IV i = ~SvIV_nomg(sv);
2628           SETi(i);
2629         }
2630         else {
2631           const UV u = ~SvUV_nomg(sv);
2632           SETu(u);
2633         }
2634     }
2635     return NORMAL;
2636 }
2637
2638 PP(pp_scomplement)
2639 {
2640     dSP;
2641     tryAMAGICun_MG(scompl_amg, AMGf_numeric);
2642     {
2643         dTARGET; dTOPss;
2644         S_scomplement(aTHX_ TARG, sv);
2645         SETTARG;
2646         return NORMAL;
2647     }
2648 }
2649
2650 /* integer versions of some of the above */
2651
2652 PP(pp_i_multiply)
2653 {
2654     dSP; dATARGET;
2655     tryAMAGICbin_MG(mult_amg, AMGf_assign);
2656     {
2657       dPOPTOPiirl_nomg;
2658       SETi( left * right );
2659       RETURN;
2660     }
2661 }
2662
2663 PP(pp_i_divide)
2664 {
2665     IV num;
2666     dSP; dATARGET;
2667     tryAMAGICbin_MG(div_amg, AMGf_assign);
2668     {
2669       dPOPTOPssrl;
2670       IV value = SvIV_nomg(right);
2671       if (value == 0)
2672           DIE(aTHX_ "Illegal division by zero");
2673       num = SvIV_nomg(left);
2674
2675       /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2676       if (value == -1)
2677           value = - num;
2678       else
2679           value = num / value;
2680       SETi(value);
2681       RETURN;
2682     }
2683 }
2684
2685 PP(pp_i_modulo)
2686 {
2687      dSP; dATARGET;
2688      tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2689      {
2690           dPOPTOPiirl_nomg;
2691           if (!right)
2692                DIE(aTHX_ "Illegal modulus zero");
2693           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2694           if (right == -1)
2695               SETi( 0 );
2696           else
2697               SETi( left % right );
2698           RETURN;
2699      }
2700 }
2701
2702 PP(pp_i_add)
2703 {
2704     dSP; dATARGET;
2705     tryAMAGICbin_MG(add_amg, AMGf_assign);
2706     {
2707       dPOPTOPiirl_ul_nomg;
2708       SETi( left + right );
2709       RETURN;
2710     }
2711 }
2712
2713 PP(pp_i_subtract)
2714 {
2715     dSP; dATARGET;
2716     tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2717     {
2718       dPOPTOPiirl_ul_nomg;
2719       SETi( left - right );
2720       RETURN;
2721     }
2722 }
2723
2724 PP(pp_i_lt)
2725 {
2726     dSP;
2727     tryAMAGICbin_MG(lt_amg, 0);
2728     {
2729       dPOPTOPiirl_nomg;
2730       SETs(boolSV(left < right));
2731       RETURN;
2732     }
2733 }
2734
2735 PP(pp_i_gt)
2736 {
2737     dSP;
2738     tryAMAGICbin_MG(gt_amg, 0);
2739     {
2740       dPOPTOPiirl_nomg;
2741       SETs(boolSV(left > right));
2742       RETURN;
2743     }
2744 }
2745
2746 PP(pp_i_le)
2747 {
2748     dSP;
2749     tryAMAGICbin_MG(le_amg, 0);
2750     {
2751       dPOPTOPiirl_nomg;
2752       SETs(boolSV(left <= right));
2753       RETURN;
2754     }
2755 }
2756
2757 PP(pp_i_ge)
2758 {
2759     dSP;
2760     tryAMAGICbin_MG(ge_amg, 0);
2761     {
2762       dPOPTOPiirl_nomg;
2763       SETs(boolSV(left >= right));
2764       RETURN;
2765     }
2766 }
2767
2768 PP(pp_i_eq)
2769 {
2770     dSP;
2771     tryAMAGICbin_MG(eq_amg, 0);
2772     {
2773       dPOPTOPiirl_nomg;
2774       SETs(boolSV(left == right));
2775       RETURN;
2776     }
2777 }
2778
2779 PP(pp_i_ne)
2780 {
2781     dSP;
2782     tryAMAGICbin_MG(ne_amg, 0);
2783     {
2784       dPOPTOPiirl_nomg;
2785       SETs(boolSV(left != right));
2786       RETURN;
2787     }
2788 }
2789
2790 PP(pp_i_ncmp)
2791 {
2792     dSP; dTARGET;
2793     tryAMAGICbin_MG(ncmp_amg, 0);
2794     {
2795       dPOPTOPiirl_nomg;
2796       I32 value;
2797
2798       if (left > right)
2799         value = 1;
2800       else if (left < right)
2801         value = -1;
2802       else
2803         value = 0;
2804       SETi(value);
2805       RETURN;
2806     }
2807 }
2808
2809 PP(pp_i_negate)
2810 {
2811     dSP; dTARGET;
2812     tryAMAGICun_MG(neg_amg, 0);
2813     if (S_negate_string(aTHX)) return NORMAL;
2814     {
2815         SV * const sv = TOPs;
2816         IV const i = SvIV_nomg(sv);
2817         SETi(-i);
2818         return NORMAL;
2819     }
2820 }
2821
2822 /* High falutin' math. */
2823
2824 PP(pp_atan2)
2825 {
2826     dSP; dTARGET;
2827     tryAMAGICbin_MG(atan2_amg, 0);
2828     {
2829       dPOPTOPnnrl_nomg;
2830       SETn(Perl_atan2(left, right));
2831       RETURN;
2832     }
2833 }
2834
2835
2836 /* also used for: pp_cos() pp_exp() pp_log() pp_sqrt() */
2837
2838 PP(pp_sin)
2839 {
2840     dSP; dTARGET;
2841     int amg_type = fallback_amg;
2842     const char *neg_report = NULL;
2843     const int op_type = PL_op->op_type;
2844
2845     switch (op_type) {
2846     case OP_SIN:  amg_type = sin_amg; break;
2847     case OP_COS:  amg_type = cos_amg; break;
2848     case OP_EXP:  amg_type = exp_amg; break;
2849     case OP_LOG:  amg_type = log_amg;  neg_report = "log";  break;
2850     case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break;
2851     }
2852
2853     assert(amg_type != fallback_amg);
2854
2855     tryAMAGICun_MG(amg_type, 0);
2856     {
2857       SV * const arg = TOPs;
2858       const NV value = SvNV_nomg(arg);
2859 #ifdef NV_NAN
2860       NV result = NV_NAN;
2861 #else
2862       NV result = 0.0;
2863 #endif
2864       if (neg_report) { /* log or sqrt */
2865           if (
2866 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2867               ! Perl_isnan(value) &&
2868 #endif
2869               (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0))) {
2870               SET_NUMERIC_STANDARD();
2871               /* diag_listed_as: Can't take log of %g */
2872               DIE(aTHX_ "Can't take %s of %" NVgf, neg_report, value);
2873           }
2874       }
2875       switch (op_type) {
2876       default:
2877       case OP_SIN:  result = Perl_sin(value);  break;
2878       case OP_COS:  result = Perl_cos(value);  break;
2879       case OP_EXP:  result = Perl_exp(value);  break;
2880       case OP_LOG:  result = Perl_log(value);  break;
2881       case OP_SQRT: result = Perl_sqrt(value); break;
2882       }
2883       SETn(result);
2884       return NORMAL;
2885     }
2886 }
2887
2888 /* Support Configure command-line overrides for rand() functions.
2889    After 5.005, perhaps we should replace this by Configure support
2890    for drand48(), random(), or rand().  For 5.005, though, maintain
2891    compatibility by calling rand() but allow the user to override it.
2892    See INSTALL for details.  --Andy Dougherty  15 July 1998
2893 */
2894 /* Now it's after 5.005, and Configure supports drand48() and random(),
2895    in addition to rand().  So the overrides should not be needed any more.
2896    --Jarkko Hietaniemi  27 September 1998
2897  */
2898
2899 PP(pp_rand)
2900 {
2901     if (!PL_srand_called) {
2902         (void)seedDrand01((Rand_seed_t)seed());
2903         PL_srand_called = TRUE;
2904     }
2905     {
2906         dSP;
2907         NV value;
2908
2909         if (MAXARG < 1)
2910         {
2911             EXTEND(SP, 1);
2912             value = 1.0;
2913         }
2914         else {
2915             SV * const sv = POPs;
2916             if(!sv)
2917                 value = 1.0;
2918             else
2919                 value = SvNV(sv);
2920         }
2921     /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
2922 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2923         if (! Perl_isnan(value) && value == 0.0)
2924 #else
2925         if (value == 0.0)
2926 #endif
2927             value = 1.0;
2928         {
2929             dTARGET;
2930             PUSHs(TARG);
2931             PUTBACK;
2932             value *= Drand01();
2933             sv_setnv_mg(TARG, value);
2934         }
2935     }
2936     return NORMAL;
2937 }
2938
2939 PP(pp_srand)
2940 {
2941     dSP; dTARGET;
2942     UV anum;
2943
2944     if (MAXARG >= 1 && (TOPs || POPs)) {
2945         SV *top;
2946         char *pv;
2947         STRLEN len;
2948         int flags;
2949
2950         top = POPs;
2951         pv = SvPV(top, len);
2952         flags = grok_number(pv, len, &anum);
2953
2954         if (!(flags & IS_NUMBER_IN_UV)) {
2955             Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
2956                              "Integer overflow in srand");
2957             anum = UV_MAX;
2958         }
2959     }
2960     else {
2961         anum = seed();
2962     }
2963
2964     (void)seedDrand01((Rand_seed_t)anum);
2965     PL_srand_called = TRUE;
2966     if (anum)
2967         XPUSHu(anum);
2968     else {
2969         /* Historically srand always returned true. We can avoid breaking
2970            that like this:  */
2971         sv_setpvs(TARG, "0 but true");
2972         XPUSHTARG;
2973     }
2974     RETURN;
2975 }
2976
2977 PP(pp_int)
2978 {
2979     dSP; dTARGET;
2980     tryAMAGICun_MG(int_amg, AMGf_numeric);
2981     {
2982       SV * const sv = TOPs;
2983       const IV iv = SvIV_nomg(sv);
2984       /* XXX it's arguable that compiler casting to IV might be subtly
2985          different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2986          else preferring IV has introduced a subtle behaviour change bug. OTOH
2987          relying on floating point to be accurate is a bug.  */
2988
2989       if (!SvOK(sv)) {
2990         SETu(0);
2991       }
2992       else if (SvIOK(sv)) {
2993         if (SvIsUV(sv))
2994             SETu(SvUV_nomg(sv));
2995         else
2996             SETi(iv);
2997       }
2998       else {
2999           const NV value = SvNV_nomg(sv);
3000           if (UNLIKELY(Perl_isinfnan(value)))
3001               SETn(value);
3002           else if (value >= 0.0) {
3003               if (value < (NV)UV_MAX + 0.5) {
3004                   SETu(U_V(value));
3005               } else {
3006                   SETn(Perl_floor(value));
3007               }
3008           }
3009           else {
3010               if (value > (NV)IV_MIN - 0.5) {
3011                   SETi(I_V(value));
3012               } else {
3013                   SETn(Perl_ceil(value));
3014               }
3015           }
3016       }
3017     }
3018     return NORMAL;
3019 }
3020
3021 PP(pp_abs)
3022 {
3023     dSP; dTARGET;
3024     tryAMAGICun_MG(abs_amg, AMGf_numeric);
3025     {
3026       SV * const sv = TOPs;
3027       /* This will cache the NV value if string isn't actually integer  */
3028       const IV iv = SvIV_nomg(sv);
3029
3030       if (!SvOK(sv)) {
3031         SETu(0);
3032       }
3033       else if (SvIOK(sv)) {
3034         /* IVX is precise  */
3035         if (SvIsUV(sv)) {
3036           SETu(SvUV_nomg(sv));  /* force it to be numeric only */
3037         } else {
3038           if (iv >= 0) {
3039             SETi(iv);
3040           } else {
3041             if (iv != IV_MIN) {
3042               SETi(-iv);
3043             } else {
3044               /* 2s complement assumption. Also, not really needed as
3045                  IV_MIN and -IV_MIN should both be %100...00 and NV-able  */
3046               SETu((UV)IV_MIN);
3047             }
3048           }
3049         }
3050       } else{
3051         const NV value = SvNV_nomg(sv);
3052         if (value < 0.0)
3053           SETn(-value);
3054         else
3055           SETn(value);
3056       }
3057     }
3058     return NORMAL;
3059 }
3060
3061
3062 /* also used for: pp_hex() */
3063
3064 PP(pp_oct)
3065 {
3066     dSP; dTARGET;
3067     const char *tmps;
3068     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
3069     STRLEN len;
3070     NV result_nv;
3071     UV result_uv;
3072     SV* const sv = TOPs;
3073
3074     tmps = (SvPV_const(sv, len));
3075     if (DO_UTF8(sv)) {
3076          /* If Unicode, try to downgrade
3077           * If not possible, croak. */
3078          SV* const tsv = sv_2mortal(newSVsv(sv));
3079
3080          SvUTF8_on(tsv);
3081          sv_utf8_downgrade(tsv, FALSE);
3082          tmps = SvPV_const(tsv, len);
3083     }
3084     if (PL_op->op_type == OP_HEX)
3085         goto hex;
3086
3087     while (*tmps && len && isSPACE(*tmps))
3088         tmps++, len--;
3089     if (*tmps == '0')
3090         tmps++, len--;
3091     if (isALPHA_FOLD_EQ(*tmps, 'x')) {
3092         tmps++, len--;
3093         flags |= PERL_SCAN_DISALLOW_PREFIX;
3094     hex:
3095         result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3096     }
3097     else if (isALPHA_FOLD_EQ(*tmps, 'b')) {
3098         tmps++, len--;
3099         flags |= PERL_SCAN_DISALLOW_PREFIX;
3100         result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3101     }
3102     else {
3103         if (isALPHA_FOLD_EQ(*tmps, 'o')) {
3104             tmps++, len--;
3105         }
3106         result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3107     }
3108
3109     if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3110         SETn(result_nv);
3111     }
3112     else {
3113         SETu(result_uv);
3114     }
3115     return NORMAL;
3116 }
3117
3118 /* String stuff. */
3119
3120
3121 PP(pp_length)
3122 {
3123     dSP; dTARGET;
3124     SV * const sv = TOPs;
3125
3126     U32 in_bytes = IN_BYTES;
3127     /* Simplest case shortcut:
3128      * set svflags to just the SVf_POK|SVs_GMG|SVf_UTF8 from the SV,
3129      * with the SVf_UTF8 flag inverted if under 'use bytes' (HINT_BYTES
3130      * set)
3131      */
3132     U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8);
3133
3134     STATIC_ASSERT_STMT(SVf_UTF8 == (HINT_BYTES << 26));
3135     SETs(TARG);
3136
3137     if (LIKELY(svflags == SVf_POK))
3138         goto simple_pv;
3139
3140     if (svflags & SVs_GMG)
3141         mg_get(sv);
3142
3143     if (SvOK(sv)) {
3144         STRLEN len;
3145         if (!IN_BYTES) { /* reread to avoid using an C auto/register */
3146             if ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == SVf_POK)
3147                 goto simple_pv;
3148             if ( SvPOK(sv) && (PL_op->op_private & OPpTRUEBOOL)) {
3149                 /* no need to convert from bytes to chars */
3150                 len = SvCUR(sv);
3151                 goto return_bool;
3152             }
3153             len = sv_len_utf8_nomg(sv);
3154         }
3155         else {
3156             /* unrolled SvPV_nomg_const(sv,len) */
3157             if (SvPOK_nog(sv)) {
3158               simple_pv:
3159                 len = SvCUR(sv);
3160                 if (PL_op->op_private & OPpTRUEBOOL) {
3161                   return_bool:
3162                     SETs(len ? &PL_sv_yes : &PL_sv_zero);
3163                     return NORMAL;
3164                 }
3165             }
3166             else {
3167                 (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN);
3168             }
3169         }
3170         TARGi((IV)(len), 1);
3171     }
3172     else {
3173         if (!SvPADTMP(TARG)) {
3174             /* OPpTARGET_MY: targ is var in '$lex = length()' */
3175             sv_set_undef(TARG);
3176             SvSETMAGIC(TARG);
3177         }
3178         else
3179             /* TARG is on stack at this point and is overwriten by SETs.
3180              * This branch is the odd one out, so put TARG by default on
3181              * stack earlier to let local SP go out of liveness sooner */
3182             SETs(&PL_sv_undef);
3183     }
3184     return NORMAL; /* no putback, SP didn't move in this opcode */
3185 }
3186
3187
3188 /* Returns false if substring is completely outside original string.
3189    No length is indicated by len_iv = 0 and len_is_uv = 0.  len_is_uv must
3190    always be true for an explicit 0.
3191 */
3192 bool
3193 Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv,
3194                                 bool pos1_is_uv, IV len_iv,
3195                                 bool len_is_uv, STRLEN *posp,
3196                                 STRLEN *lenp)
3197 {
3198     IV pos2_iv;
3199     int    pos2_is_uv;
3200
3201     PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
3202
3203     if (!pos1_is_uv && pos1_iv < 0 && curlen) {
3204         pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3205         pos1_iv += curlen;
3206     }
3207     if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
3208         return FALSE;
3209
3210     if (len_iv || len_is_uv) {
3211         if (!len_is_uv && len_iv < 0) {
3212             pos2_iv = curlen + len_iv;
3213             if (curlen)
3214                 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3215             else
3216                 pos2_is_uv = 0;
3217         } else {  /* len_iv >= 0 */
3218             if (!pos1_is_uv && pos1_iv < 0) {
3219                 pos2_iv = pos1_iv + len_iv;
3220                 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3221             } else {
3222                 if ((UV)len_iv > curlen-(UV)pos1_iv)
3223                     pos2_iv = curlen;
3224                 else
3225                     pos2_iv = pos1_iv+len_iv;
3226                 pos2_is_uv = 1;
3227             }
3228         }
3229     }
3230     else {
3231         pos2_iv = curlen;
3232         pos2_is_uv = 1;
3233     }
3234
3235     if (!pos2_is_uv && pos2_iv < 0) {
3236         if (!pos1_is_uv && pos1_iv < 0)
3237             return FALSE;
3238         pos2_iv = 0;
3239     }
3240     else if (!pos1_is_uv && pos1_iv < 0)
3241         pos1_iv = 0;
3242
3243     if ((UV)pos2_iv < (UV)pos1_iv)
3244         pos2_iv = pos1_iv;
3245     if ((UV)pos2_iv > curlen)
3246         pos2_iv = curlen;
3247
3248     /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3249     *posp = (STRLEN)( (UV)pos1_iv );
3250     *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3251
3252     return TRUE;
3253 }
3254
3255 PP(pp_substr)
3256 {
3257     dSP; dTARGET;
3258     SV *sv;
3259     STRLEN curlen;
3260     STRLEN utf8_curlen;
3261     SV *   pos_sv;
3262     IV     pos1_iv;
3263     int    pos1_is_uv;
3264     SV *   len_sv;
3265     IV     len_iv = 0;
3266     int    len_is_uv = 0;
3267     I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3268     const bool rvalue = (GIMME_V != G_VOID);
3269     const char *tmps;
3270     SV *repl_sv = NULL;
3271     const char *repl = NULL;
3272     STRLEN repl_len;
3273     int num_args = PL_op->op_private & 7;
3274     bool repl_need_utf8_upgrade = FALSE;
3275
3276     if (num_args > 2) {
3277         if (num_args > 3) {
3278           if(!(repl_sv = POPs)) num_args--;
3279         }
3280         if ((len_sv = POPs)) {
3281             len_iv    = SvIV(len_sv);
3282             len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
3283         }
3284         else num_args--;
3285     }
3286     pos_sv     = POPs;
3287     pos1_iv    = SvIV(pos_sv);
3288     pos1_is_uv = SvIOK_UV(pos_sv);
3289     sv = POPs;
3290     if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3291         assert(!repl_sv);
3292         repl_sv = POPs;
3293     }
3294     if (lvalue && !repl_sv) {
3295         SV * ret;
3296         ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
3297         sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3298         LvTYPE(ret) = 'x';
3299         LvTARG(ret) = SvREFCNT_inc_simple(sv);
3300         LvTARGOFF(ret) =
3301             pos1_is_uv || pos1_iv >= 0
3302                 ? (STRLEN)(UV)pos1_iv
3303                 : (LvFLAGS(ret) |= LVf_NEG_OFF, (STRLEN)(UV)-pos1_iv);
3304         LvTARGLEN(ret) =
3305             len_is_uv || len_iv > 0
3306                 ? (STRLEN)(UV)len_iv
3307                 : (LvFLAGS(ret) |= LVf_NEG_LEN, (STRLEN)(UV)-len_iv);
3308
3309         PUSHs(ret);    /* avoid SvSETMAGIC here */
3310         RETURN;
3311     }
3312     if (repl_sv) {
3313         repl = SvPV_const(repl_sv, repl_len);
3314         SvGETMAGIC(sv);
3315         if (SvROK(sv))
3316             Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3317                             "Attempt to use reference as lvalue in substr"
3318             );
3319         tmps = SvPV_force_nomg(sv, curlen);
3320         if (DO_UTF8(repl_sv) && repl_len) {
3321             if (!DO_UTF8(sv)) {
3322                 /* Upgrade the dest, and recalculate tmps in case the buffer
3323                  * got reallocated; curlen may also have been changed */
3324                 sv_utf8_upgrade_nomg(sv);
3325                 tmps = SvPV_nomg(sv, curlen);
3326             }
3327         }
3328         else if (DO_UTF8(sv))
3329             repl_need_utf8_upgrade = TRUE;
3330     }
3331     else tmps = SvPV_const(sv, curlen);
3332     if (DO_UTF8(sv)) {
3333         utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
3334         if (utf8_curlen == curlen)
3335             utf8_curlen = 0;
3336         else
3337             curlen = utf8_curlen;
3338     }
3339     else
3340         utf8_curlen = 0;
3341
3342     {
3343         STRLEN pos, len, byte_len, byte_pos;
3344
3345         if (!translate_substr_offsets(
3346                 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3347         )) goto bound_fail;
3348
3349         byte_len = len;
3350         byte_pos = utf8_curlen
3351             ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
3352
3353         tmps += byte_pos;
3354
3355         if (rvalue) {
3356             SvTAINTED_off(TARG);                        /* decontaminate */
3357             SvUTF8_off(TARG);                   /* decontaminate */
3358             sv_setpvn(TARG, tmps, byte_len);
3359 #ifdef USE_LOCALE_COLLATE
3360             sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3361 #endif
3362             if (utf8_curlen)
3363                 SvUTF8_on(TARG);
3364         }
3365
3366         if (repl) {
3367             SV* repl_sv_copy = NULL;
3368
3369             if (repl_need_utf8_upgrade) {
3370                 repl_sv_copy = newSVsv(repl_sv);
3371                 sv_utf8_upgrade(repl_sv_copy);
3372                 repl = SvPV_const(repl_sv_copy, repl_len);
3373             }
3374             if (!SvOK(sv))
3375                 SvPVCLEAR(sv);
3376             sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3377             SvREFCNT_dec(repl_sv_copy);
3378         }
3379     }
3380     if (PL_op->op_private & OPpSUBSTR_REPL_FIRST)
3381         SP++;
3382     else if (rvalue) {
3383         SvSETMAGIC(TARG);
3384         PUSHs(TARG);
3385     }
3386     RETURN;
3387
3388   bound_fail:
3389     if (repl)
3390         Perl_croak(aTHX_ "substr outside of string");
3391     Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3392     RETPUSHUNDEF;
3393 }
3394
3395 PP(pp_vec)
3396 {
3397     dSP;
3398     const IV size   = POPi;
3399     SV* offsetsv   = POPs;
3400     SV * const src = POPs;
3401     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3402     SV * ret;
3403     UV   retuv;
3404     STRLEN offset = 0;
3405     char errflags = 0;
3406
3407     /* extract a STRLEN-ranged integer value from offsetsv into offset,
3408      * or flag that its out of range */
3409     {
3410         IV iv = SvIV(offsetsv);
3411
3412         /* avoid a large UV being wrapped to a negative value */
3413         if (SvIOK_UV(offsetsv) && SvUVX(offsetsv) > (UV)IV_MAX)
3414             errflags = LVf_OUT_OF_RANGE;
3415         else if (iv < 0)
3416             errflags = (LVf_NEG_OFF|LVf_OUT_OF_RANGE);
3417 #if PTRSIZE < IVSIZE
3418         else if (iv > Size_t_MAX)
3419             errflags = LVf_OUT_OF_RANGE;
3420 #endif
3421         else
3422             offset = (STRLEN)iv;
3423     }
3424
3425     retuv = errflags ? 0 : do_vecget(src, offset, size);
3426
3427     if (lvalue) {                       /* it's an lvalue! */
3428         ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
3429         sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3430         LvTYPE(ret) = 'v';
3431         LvTARG(ret) = SvREFCNT_inc_simple(src);
3432         LvTARGOFF(ret) = offset;
3433         LvTARGLEN(ret) = size;
3434         LvFLAGS(ret)   = errflags;
3435     }
3436     else {
3437         dTARGET;
3438         SvTAINTED_off(TARG);            /* decontaminate */
3439         ret = TARG;
3440     }
3441
3442     sv_setuv(ret, retuv);
3443     if (!lvalue)
3444         SvSETMAGIC(ret);
3445     PUSHs(ret);
3446     RETURN;
3447 }
3448
3449
3450 /* also used for: pp_rindex() */
3451
3452 PP(pp_index)
3453 {
3454     dSP; dTARGET;
3455     SV *big;
3456     SV *little;
3457     SV *temp = NULL;
3458     STRLEN biglen;
3459     STRLEN llen = 0;
3460     SSize_t offset = 0;
3461     SSize_t retval;
3462     const char *big_p;
3463     const char *little_p;
3464     bool big_utf8;
3465     bool little_utf8;
3466     const bool is_index = PL_op->op_type == OP_INDEX;
3467     const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
3468
3469     if (threeargs)
3470         offset = POPi;
3471     little = POPs;
3472     big = POPs;
3473     big_p = SvPV_const(big, biglen);
3474     little_p = SvPV_const(little, llen);
3475
3476     big_utf8 = DO_UTF8(big);
3477     little_utf8 = DO_UTF8(little);
3478     if (big_utf8 ^ little_utf8) {
3479         /* One needs to be upgraded.  */
3480         if (little_utf8) {
3481             /* Well, maybe instead we might be able to downgrade the small
3482                string?  */
3483             char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3484                                                      &little_utf8);
3485             if (little_utf8) {
3486                 /* If the large string is ISO-8859-1, and it's not possible to
3487                    convert the small string to ISO-8859-1, then there is no
3488                    way that it could be found anywhere by index.  */
3489                 retval = -1;
3490                 goto push_result;
3491             }
3492
3493             /* At this point, pv is a malloc()ed string. So donate it to temp
3494                to ensure it will get free()d  */
3495             little = temp = newSV(0);
3496             sv_usepvn(temp, pv, llen);
3497             little_p = SvPVX(little);
3498         } else {
3499             temp = newSVpvn(little_p, llen);
3500
3501             sv_utf8_upgrade(temp);
3502             little = temp;
3503             little_p = SvPV_const(little, llen);
3504         }
3505     }
3506     if (SvGAMAGIC(big)) {
3507         /* Life just becomes a lot easier if I use a temporary here.
3508            Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3509            will trigger magic and overloading again, as will fbm_instr()
3510         */
3511         big = newSVpvn_flags(big_p, biglen,
3512                              SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3513         big_p = SvPVX(big);
3514     }
3515     if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3516         /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3517            warn on undef, and we've already triggered a warning with the
3518            SvPV_const some lines above. We can't remove that, as we need to
3519            call some SvPV to trigger overloading early and find out if the
3520            string is UTF-8.
3521            This is all getting too messy. The API isn't quite clean enough,
3522            because data access has side effects.
3523         */
3524         little = newSVpvn_flags(little_p, llen,
3525                                 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3526         little_p = SvPVX(little);
3527     }
3528
3529     if (!threeargs)
3530         offset = is_index ? 0 : biglen;
3531     else {
3532         if (big_utf8 && offset > 0)
3533             offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
3534         if (!is_index)
3535             offset += llen;
3536     }
3537     if (offset < 0)
3538         offset = 0;
3539     else if (offset > (SSize_t)biglen)
3540         offset = biglen;
3541     if (!(little_p = is_index
3542           ? fbm_instr((unsigned char*)big_p + offset,
3543                       (unsigned char*)big_p + biglen, little, 0)
3544           : rninstr(big_p,  big_p  + offset,
3545                     little_p, little_p + llen)))
3546         retval = -1;
3547     else {
3548         retval = little_p - big_p;
3549         if (retval > 1 && big_utf8)
3550             retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
3551     }
3552     SvREFCNT_dec(temp);
3553
3554   push_result:
3555     /* OPpTRUEBOOL indicates an '== -1' has been optimised away */
3556     if (PL_op->op_private & OPpTRUEBOOL) {
3557         SV *result = ((retval != -1) ^ cBOOL(PL_op->op_private & OPpINDEX_BOOLNEG))
3558             ? &PL_sv_yes : &PL_sv_no;
3559         if (PL_op->op_private & OPpTARGET_MY) {
3560             /* $lex = (index() == -1) */
3561             sv_setsv_mg(TARG, result);
3562             PUSHs(TARG);
3563         }
3564         else {
3565             PUSHs(result);
3566         }
3567     }
3568     else
3569         PUSHi(retval);
3570     RETURN;
3571 }
3572
3573 PP(pp_sprintf)
3574 {
3575     dSP; dMARK; dORIGMARK; dTARGET;
3576     SvTAINTED_off(TARG);
3577     do_sprintf(TARG, SP-MARK, MARK+1);
3578     TAINT_IF(SvTAINTED(TARG));
3579     SP = ORIGMARK;
3580     PUSHTARG;
3581     RETURN;
3582 }
3583
3584 PP(pp_ord)
3585 {
3586     dSP; dTARGET;
3587
3588     SV *argsv = TOPs;
3589     STRLEN len;
3590     const U8 *s = (U8*)SvPV_const(argsv, len);
3591
3592     SETu(DO_UTF8(argsv)
3593            ? (len ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV) : 0)
3594            : (UV)(*s));
3595
3596     return NORMAL;
3597 }
3598
3599 PP(pp_chr)
3600 {
3601     dSP; dTARGET;
3602     char *tmps;
3603     UV value;
3604     SV *top = TOPs;
3605
3606     SvGETMAGIC(top);
3607     if (UNLIKELY(SvAMAGIC(top)))
3608         top = sv_2num(top);
3609     if (UNLIKELY(isinfnansv(top)))
3610         Perl_croak(aTHX_ "Cannot chr %" NVgf, SvNV(top));
3611     else {
3612         if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3613             && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3614                 ||
3615                 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3616                  && SvNV_nomg(top) < 0.0)))
3617         {
3618             if (ckWARN(WARN_UTF8)) {
3619                 if (SvGMAGICAL(top)) {
3620                     SV *top2 = sv_newmortal();
3621                     sv_setsv_nomg(top2, top);
3622                     top = top2;
3623                 }
3624                 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3625                             "Invalid negative number (%" SVf ") in chr", SVfARG(top));
3626             }
3627             value = UNICODE_REPLACEMENT;
3628         } else {
3629             value = SvUV_nomg(top);
3630         }
3631     }
3632
3633     SvUPGRADE(TARG,SVt_PV);
3634
3635     if (value > 255 && !IN_BYTES) {
3636         SvGROW(TARG, (STRLEN)UVCHR_SKIP(value)+1);
3637         tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3638         SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3639         *tmps = '\0';
3640         (void)SvPOK_only(TARG);
3641         SvUTF8_on(TARG);
3642         SETTARG;
3643         return NORMAL;
3644     }
3645
3646     SvGROW(TARG,2);
3647     SvCUR_set(TARG, 1);
3648     tmps = SvPVX(TARG);
3649     *tmps++ = (char)value;
3650     *tmps = '\0';
3651     (void)SvPOK_only(TARG);
3652
3653     SETTARG;
3654     return NORMAL;
3655 }
3656
3657 PP(pp_crypt)
3658 {
3659 #ifdef HAS_CRYPT
3660     dSP; dTARGET;
3661     dPOPTOPssrl;
3662     STRLEN len;
3663     const char *tmps = SvPV_const(left, len);
3664
3665     if (DO_UTF8(left)) {
3666          /* If Unicode, try to downgrade.
3667           * If not possible, croak.
3668           * Yes, we made this up.  */
3669          SV* const tsv = newSVpvn_flags(tmps, len, SVf_UTF8|SVs_TEMP);
3670
3671          sv_utf8_downgrade(tsv, FALSE);
3672          tmps = SvPV_const(tsv, len);
3673     }
3674 #  ifdef USE_ITHREADS
3675 #    ifdef HAS_CRYPT_R
3676     if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3677       /* This should be threadsafe because in ithreads there is only
3678        * one thread per interpreter.  If this would not be true,
3679        * we would need a mutex to protect this malloc. */
3680         PL_reentrant_buffer->_crypt_struct_buffer =
3681           (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3682 #      if defined(__GLIBC__) || defined(__EMX__)
3683         if (PL_reentrant_buffer->_crypt_struct_buffer) {
3684             PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3685         }
3686 #      endif
3687     }
3688 #    endif /* HAS_CRYPT_R */
3689 #  endif /* USE_ITHREADS */
3690
3691     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3692
3693     SvUTF8_off(TARG);
3694     SETTARG;
3695     RETURN;
3696 #else
3697     DIE(aTHX_
3698       "The crypt() function is unimplemented due to excessive paranoia.");
3699 #endif
3700 }
3701
3702 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level.  So
3703  * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3704
3705
3706 /* also used for: pp_lcfirst() */
3707
3708 PP(pp_ucfirst)
3709 {
3710     /* Actually is both lcfirst() and ucfirst().  Only the first character
3711      * changes.  This means that possibly we can change in-place, ie., just
3712      * take the source and change that one character and store it back, but not
3713      * if read-only etc, or if the length changes */
3714
3715     dSP;
3716     SV *source = TOPs;
3717     STRLEN slen; /* slen is the byte length of the whole SV. */
3718     STRLEN need;
3719     SV *dest;
3720     bool inplace;   /* ? Convert first char only, in-place */
3721     bool doing_utf8 = FALSE;               /* ? using utf8 */
3722     bool convert_source_to_utf8 = FALSE;   /* ? need to convert */
3723     const int op_type = PL_op->op_type;
3724     const U8 *s;
3725     U8 *d;
3726     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3727     STRLEN ulen;    /* ulen is the byte length of the original Unicode character
3728                      * stored as UTF-8 at s. */
3729     STRLEN tculen;  /* tculen is the byte length of the freshly titlecased (or
3730                      * lowercased) character stored in tmpbuf.  May be either
3731                      * UTF-8 or not, but in either case is the number of bytes */
3732     bool remove_dot_above = FALSE;
3733
3734     s = (const U8*)SvPV_const(source, slen);
3735
3736     /* We may be able to get away with changing only the first character, in
3737      * place, but not if read-only, etc.  Later we may discover more reasons to
3738      * not convert in-place. */
3739     inplace = !SvREADONLY(source) && SvPADTMP(source);
3740
3741 #ifdef USE_LOCALE_CTYPE
3742
3743     if (IN_LC_RUNTIME(LC_CTYPE)) {
3744         _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3745     }
3746
3747 #endif
3748
3749     /* First calculate what the changed first character should be.  This affects
3750      * whether we can just swap it out, leaving the rest of the string unchanged,
3751      * or even if have to convert the dest to UTF-8 when the source isn't */
3752
3753     if (! slen) {   /* If empty */
3754         need = 1; /* still need a trailing NUL */
3755         ulen = 0;
3756         *tmpbuf = '\0';
3757     }
3758     else if (DO_UTF8(source)) { /* Is the source utf8? */
3759         doing_utf8 = TRUE;
3760         ulen = UTF8SKIP(s);
3761
3762         if (op_type == OP_UCFIRST) {
3763 #ifdef USE_LOCALE_CTYPE
3764             _toTITLE_utf8_flags(s, s +slen, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3765 #else
3766             _toTITLE_utf8_flags(s, s +slen, tmpbuf, &tculen, 0);
3767 #endif
3768         }
3769         else {
3770
3771 #ifdef USE_LOCALE_CTYPE
3772
3773             _toLOWER_utf8_flags(s, s + slen, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3774
3775             /* In turkic locales, lower casing an 'I' normally yields U+0131,
3776              * LATIN SMALL LETTER DOTLESS I, but not if the grapheme also
3777              * contains a COMBINING DOT ABOVE.  Instead it is treated like
3778              * LATIN CAPITAL LETTER I WITH DOT ABOVE lowercased to 'i'.  The
3779              * call to lowercase above has handled this.  But SpecialCasing.txt
3780              * says we are supposed to remove the COMBINING DOT ABOVE.  We can
3781              * tell if we have this situation if I ==> i in a turkic locale. */
3782             if (   UNLIKELY(PL_in_utf8_turkic_locale)
3783                 && IN_LC_RUNTIME(LC_CTYPE)
3784                 && (UNLIKELY(*s == 'I' && tmpbuf[0] == 'i')))
3785             {
3786                 /* Here, we know there was a COMBINING DOT ABOVE.  We won't be
3787                  * able to handle this in-place. */
3788                 inplace = FALSE;
3789
3790                 /* It seems likely that the DOT will immediately follow the
3791                  * 'I'.  If so, we can remove it simply by indicating to the
3792                  * code below to start copying the source just beyond the DOT.
3793                  * We know its length is 2 */
3794                 if (LIKELY(memBEGINs(s + 1, s + slen, COMBINING_DOT_ABOVE_UTF8))) {
3795                     ulen += 2;
3796                 }
3797                 else {  /* But if it doesn't follow immediately, set a flag for
3798                            the code below */
3799                     remove_dot_above = TRUE;
3800                 }
3801             }
3802 #else
3803             PERL_UNUSED_VAR(remove_dot_above);
3804
3805             _toLOWER_utf8_flags(s, s + slen, tmpbuf, &tculen, 0);
3806 #endif
3807
3808         }
3809
3810         /* we can't do in-place if the length changes.  */
3811         if (ulen != tculen) inplace = FALSE;
3812         need = slen + 1 - ulen + tculen;
3813     }
3814     else { /* Non-zero length, non-UTF-8,  Need to consider locale and if
3815             * latin1 is treated as caseless.  Note that a locale takes
3816             * precedence */
3817         ulen = 1;       /* Original character is 1 byte */
3818         tculen = 1;     /* Most characters will require one byte, but this will
3819                          * need to be overridden for the tricky ones */
3820         need = slen + 1;
3821
3822
3823 #ifdef USE_LOCALE_CTYPE
3824
3825         if (IN_LC_RUNTIME(LC_CTYPE)) {
3826             if (    UNLIKELY(PL_in_utf8_turkic_locale)
3827                 && (   (op_type == OP_LCFIRST && UNLIKELY(*s == 'I'))
3828                     || (op_type == OP_UCFIRST && UNLIKELY(*s == 'i'))))
3829             {
3830                 if (*s == 'I') { /* lcfirst('I') */
3831                     tmpbuf[0] = UTF8_TWO_BYTE_HI(LATIN_SMALL_LETTER_DOTLESS_I);
3832                     tmpbuf[1] = UTF8_TWO_BYTE_LO(LATIN_SMALL_LETTER_DOTLESS_I);
3833                 }
3834                 else {  /* ucfirst('i') */
3835                     tmpbuf[0] = UTF8_TWO_BYTE_HI(LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
3836                     tmpbuf[1] = UTF8_TWO_BYTE_LO(LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
3837                 }
3838                 tculen = 2;
3839                 inplace = FALSE;
3840                 doing_utf8 = TRUE;
3841                 convert_source_to_utf8 = TRUE;
3842                 need += variant_under_utf8_count(s, s + slen);
3843             }
3844             else if (op_type == OP_LCFIRST) {
3845
3846                 /* For lc, there are no gotchas for UTF-8 locales (other than
3847                  * the turkish ones already handled above) */
3848                 *tmpbuf = toLOWER_LC(*s);
3849             }
3850             else { /* ucfirst */
3851
3852                 /* But for uc, some characters require special handling */
3853                 if (IN_UTF8_CTYPE_LOCALE) {
3854                     goto do_uni_rules;
3855                 }
3856
3857                 /* This would be a bug if any locales have upper and title case
3858                  * different */
3859                 *tmpbuf = (U8) toUPPER_LC(*s);
3860             }
3861         }
3862         else
3863 #endif
3864         /* Here, not in locale.  If not using Unicode rules, is a simple
3865          * lower/upper, depending */
3866         if (! IN_UNI_8_BIT) {
3867             *tmpbuf = (op_type == OP_LCFIRST)
3868                       ? toLOWER(*s)
3869                       : toUPPER(*s);
3870         }
3871         else if (op_type == OP_LCFIRST) {
3872             /* lower case the first letter: no trickiness for any character */
3873             *tmpbuf = toLOWER_LATIN1(*s);
3874         }
3875         else {
3876             /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is
3877              * non-turkic UTF-8, which we treat as not in locale), and cased
3878              * latin1 */
3879             UV title_ord;
3880 #ifdef USE_LOCALE_CTYPE
3881       do_uni_rules:
3882 #endif
3883
3884             title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3885             if (tculen > 1) {
3886                 assert(tculen == 2);
3887
3888                 /* If the result is an upper Latin1-range character, it can
3889                  * still be represented in one byte, which is its ordinal */
3890                 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3891                     *tmpbuf = (U8) title_ord;
3892                     tculen = 1;
3893                 }
3894                 else {
3895                     /* Otherwise it became more than one ASCII character (in
3896                      * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3897                      * beyond Latin1, so the number of bytes changed, so can't
3898                      * replace just the first character in place. */
3899                     inplace = FALSE;
3900
3901                     /* If the result won't fit in a byte, the entire result
3902                      * will have to be in UTF-8.  Allocate enough space for the
3903                      * expanded first byte, and if UTF-8, the rest of the input
3904                      * string, some or all of which may also expand to two
3905                      * bytes, plus the terminating NUL. */
3906                     if (title_ord > 255) {
3907                         doing_utf8 = TRUE;
3908                         convert_source_to_utf8 = TRUE;
3909                         need = slen
3910                             + variant_under_utf8_count(s, s + slen)
3911                             + 1;
3912
3913                         /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3914                          * characters whose title case is above 255 is
3915                          * 2. */
3916                         ulen = 2;
3917                     }
3918                     else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3919                         need = slen + 1 + 1;
3920                     }
3921                 }
3922             }
3923         } /* End of use Unicode (Latin1) semantics */
3924     } /* End of changing the case of the first character */
3925
3926     /* Here, have the first character's changed case stored in tmpbuf.  Ready to
3927      * generate the result */
3928     if (inplace) {
3929
3930         /* We can convert in place.  This means we change just the first
3931          * character without disturbing the rest; no need to grow */
3932         dest = source;
3933         s = d = (U8*)SvPV_force_nomg(source, slen);
3934     } else {
3935         dTARGET;
3936
3937         dest = TARG;
3938
3939         /* Here, we can't convert in place; we earlier calculated how much
3940          * space we will need, so grow to accommodate that */
3941         SvUPGRADE(dest, SVt_PV);
3942         d = (U8*)SvGROW(dest, need);
3943         (void)SvPOK_only(dest);
3944
3945         SETs(dest);
3946     }
3947
3948     if (doing_utf8) {
3949         if (! inplace) {
3950             if (! convert_source_to_utf8) {
3951
3952                 /* Here  both source and dest are in UTF-8, but have to create
3953                  * the entire output.  We initialize the result to be the
3954                  * title/lower cased first character, and then append the rest
3955                  * of the string. */
3956                 sv_setpvn(dest, (char*)tmpbuf, tculen);
3957                 if (slen > ulen) {
3958
3959                     /* But this boolean being set means we are in a turkic
3960                      * locale, and there is a DOT character that needs to be
3961                      * removed, and it isn't immediately after the current
3962                      * character.  Keep concatenating characters to the output
3963                      * one at a time, until we find the DOT, which we simply
3964                      * skip */
3965                     if (UNLIKELY(remove_dot_above)) {
3966                         do {
3967                             Size_t this_len = UTF8SKIP(s + ulen);
3968
3969                             sv_catpvn(dest, (char*)(s + ulen), this_len);
3970
3971                             ulen += this_len;
3972                             if (memBEGINs(s + ulen, s + slen, COMBINING_DOT_ABOVE_UTF8)) {
3973                                 ulen += 2;
3974                                 break;
3975                             }
3976                         } while (s + ulen < s + slen);
3977                     }
3978
3979                     /* The rest of the string can be concatenated unchanged,
3980                      * all at once */
3981                     sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3982                 }
3983             }
3984             else {
3985                 const U8 *const send = s + slen;
3986
3987                 /* Here the dest needs to be in UTF-8, but the source isn't,
3988                  * except we earlier UTF-8'd the first character of the source
3989                  * into tmpbuf.  First put that into dest, and then append the
3990                  * rest of the source, converting it to UTF-8 as we go. */
3991
3992                 /* Assert tculen is 2 here because the only characters that
3993                  * get to this part of the code have 2-byte UTF-8 equivalents */
3994                 assert(tculen == 2);
3995                 *d++ = *tmpbuf;
3996                 *d++ = *(tmpbuf + 1);
3997                 s++;    /* We have just processed the 1st char */
3998
3999                 while (s < send) {
4000                     append_utf8_from_native_byte(*s, &d);
4001                     s++;
4002                 }
4003
4004                 *d = '\0';
4005                 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4006             }
4007             SvUTF8_on(dest);
4008         }
4009         else {   /* in-place UTF-8.  Just overwrite the first character */
4010             Copy(tmpbuf, d, tculen, U8);
4011             SvCUR_set(dest, need - 1);
4012         }
4013
4014     }
4015     else {  /* Neither source nor dest are, nor need to be UTF-8 */
4016         if (slen) {
4017             if (inplace) {  /* in-place, only need to change the 1st char */
4018                 *d = *tmpbuf;
4019             }
4020             else {      /* Not in-place */
4021
4022                 /* Copy the case-changed character(s) from tmpbuf */
4023                 Copy(tmpbuf, d, tculen, U8);
4024                 d += tculen - 1; /* Code below expects d to point to final
4025                                   * character stored */
4026             }
4027         }
4028         else {  /* empty source */
4029             /* See bug #39028: Don't taint if empty  */
4030             *d = *s;
4031         }
4032
4033         /* In a "use bytes" we don't treat the source as UTF-8, but, still want
4034          * the destination to retain that flag */
4035         if (DO_UTF8(source))
4036             SvUTF8_on(dest);
4037
4038         if (!inplace) { /* Finish the rest of the string, unchanged */
4039             /* This will copy the trailing NUL  */
4040             Copy(s + 1, d + 1, slen, U8);
4041             SvCUR_set(dest, need - 1);
4042         }
4043     }
4044 #ifdef USE_LOCALE_CTYPE
4045     if (IN_LC_RUNTIME(LC_CTYPE)) {
4046         TAINT;
4047         SvTAINTED_on(dest);
4048     }
4049 #endif
4050     if (dest != source && SvTAINTED(source))
4051         SvTAINT(dest);
4052     SvSETMAGIC(dest);
4053     return NORMAL;
4054 }
4055
4056 PP(pp_uc)
4057 {
4058     dSP;
4059     SV *source = TOPs;
4060     STRLEN len;
4061     STRLEN min;
4062     SV *dest;
4063     const U8 *s;
4064     U8 *d;
4065
4066     SvGETMAGIC(source);
4067
4068     if (   SvPADTMP(source)
4069         && !SvREADONLY(source) && SvPOK(source)
4070         && !DO_UTF8(source)
4071         && (
4072 #ifdef USE_LOCALE_CTYPE
4073             (IN_LC_RUNTIME(LC_CTYPE))
4074             ? ! IN_UTF8_CTYPE_LOCALE
4075             :
4076 #endif
4077               ! IN_UNI_8_BIT))
4078     {
4079
4080         /* We can convert in place.  The reason we can't if in UNI_8_BIT is to
4081          * make the loop tight, so we overwrite the source with the dest before
4082          * looking at it, and we need to look at the original source
4083          * afterwards.  There would also need to be code added to handle
4084          * switching to not in-place in midstream if we run into characters
4085          * that change the length.  Since being in locale overrides UNI_8_BIT,
4086          * that latter becomes irrelevant in the above test; instead for
4087          * locale, the size can't normally change, except if the locale is a
4088          * UTF-8 one */
4089         dest = source;
4090         s = d = (U8*)SvPV_force_nomg(source, len);
4091         min = len + 1;
4092     } else {
4093         dTARGET;
4094
4095         dest = TARG;
4096
4097         s = (const U8*)SvPV_nomg_const(source, len);
4098         min = len + 1;
4099
4100         SvUPGRADE(dest, SVt_PV);
4101         d = (U8*)SvGROW(dest, min);
4102         (void)SvPOK_only(dest);
4103
4104         SETs(dest);
4105     }
4106
4107 #ifdef USE_LOCALE_CTYPE
4108
4109     if (IN_LC_RUNTIME(LC_CTYPE)) {
4110         _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4111     }
4112
4113 #endif
4114
4115     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4116        to check DO_UTF8 again here.  */
4117
4118     if (DO_UTF8(source)) {
4119         const U8 *const send = s + len;
4120         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4121
4122 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
4123 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
4124         /* All occurrences of these are to be moved to follow any other marks.
4125          * This is context-dependent.  We may not be passed enough context to
4126          * move the iota subscript beyond all of them, but we do the best we can
4127          * with what we're given.  The result is always better than if we
4128          * hadn't done this.  And, the problem would only arise if we are
4129          * passed a character without all its combining marks, which would be
4130          * the caller's mistake.  The information this is based on comes from a
4131          * comment in Unicode SpecialCasing.txt, (and the Standard's text
4132          * itself) and so can't be checked properly to see if it ever gets
4133          * revised.  But the likelihood of it changing is remote */
4134         bool in_iota_subscript = FALSE;
4135
4136         while (s < send) {
4137             STRLEN u;
4138             STRLEN ulen;
4139             UV uv;
4140             if (UNLIKELY(in_iota_subscript)) {
4141                 UV cp = utf8_to_uvchr_buf(s, send, NULL);
4142
4143                 if (! _invlist_contains_cp(PL_utf8_mark, cp)) {
4144
4145                     /* A non-mark.  Time to output the iota subscript */
4146                     *d++ = UTF8_TWO_BYTE_HI(GREEK_CAPITAL_LETTER_IOTA);
4147                     *d++ = UTF8_TWO_BYTE_LO(GREEK_CAPITAL_LETTER_IOTA);
4148                     in_iota_subscript = FALSE;
4149                 }
4150             }
4151
4152             /* Then handle the current character.  Get the changed case value
4153              * and copy it to the output buffer */
4154
4155             u = UTF8SKIP(s);
4156 #ifdef USE_LOCALE_CTYPE
4157             uv = _toUPPER_utf8_flags(s, send, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4158 #else
4159             uv = _toUPPER_utf8_flags(s, send, tmpbuf, &ulen, 0);
4160 #endif
4161             if (uv == GREEK_CAPITAL_LETTER_IOTA
4162                 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
4163             {
4164                 in_iota_subscript = TRUE;
4165             }
4166             else {
4167                 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4168                     /* If the eventually required minimum size outgrows the
4169                      * available space, we need to grow. */
4170                     const UV o = d - (U8*)SvPVX_const(dest);
4171
4172                     /* If someone uppercases one million U+03B0s we SvGROW()
4173                      * one million times.  Or we could try guessing how much to
4174                      * allocate without allocating too much.  But we can't
4175                      * really guess without examining the rest of the string.
4176                      * Such is life.  See corresponding comment in lc code for
4177                      * another option */
4178                     d = o + (U8*) SvGROW(dest, min);
4179                 }
4180                 Copy(tmpbuf, d, ulen, U8);
4181                 d += ulen;
4182             }
4183             s += u;
4184         }
4185         if (in_iota_subscript) {
4186             *d++ = UTF8_TWO_BYTE_HI(GREEK_CAPITAL_LETTER_IOTA);
4187             *d++ = UTF8_TWO_BYTE_LO(GREEK_CAPITAL_LETTER_IOTA);
4188         }
4189         SvUTF8_on(dest);
4190         *d = '\0';
4191
4192         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4193     }
4194     else {      /* Not UTF-8 */
4195         if (len) {
4196             const U8 *const send = s + len;
4197
4198             /* Use locale casing if in locale; regular style if not treating
4199              * latin1 as having case; otherwise the latin1 casing.  Do the
4200              * whole thing in a tight loop, for speed, */
4201 #ifdef USE_LOCALE_CTYPE
4202             if (IN_LC_RUNTIME(LC_CTYPE)) {
4203                 if (IN_UTF8_CTYPE_LOCALE) {
4204                     goto do_uni_rules;
4205                 }
4206                 for (; s < send; d++, s++)
4207                     *d = (U8) toUPPER_LC(*s);
4208             }
4209             else
4210 #endif
4211                  if (! IN_UNI_8_BIT) {
4212                 for (; s < send; d++, s++) {
4213                     *d = toUPPER(*s);
4214                 }
4215             }
4216             else {
4217 #ifdef USE_LOCALE_CTYPE
4218           do_uni_rules:
4219 #endif
4220                 for (; s < send; d++, s++) {
4221                     Size_t extra;
4222
4223                     *d = toUPPER_LATIN1_MOD(*s);
4224                     if (   LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)
4225
4226 #ifdef USE_LOCALE_CTYPE
4227
4228                         && (LIKELY(   ! PL_in_utf8_turkic_locale
4229                                    || ! IN_LC_RUNTIME(LC_CTYPE))
4230                                    || *s != 'i')
4231 #endif
4232
4233                     ) {
4234                         continue;
4235                     }
4236
4237                     /* The mainstream case is the tight loop above.  To avoid
4238                      * extra tests in that, all three characters that always
4239                      * require special handling are mapped by the MOD to the
4240                      * one tested just above.  Use the source to distinguish
4241                      * between those cases */
4242
4243 #if    UNICODE_MAJOR_VERSION > 2                                        \
4244    || (UNICODE_MAJOR_VERSION == 2 && UNICODE_DOT_VERSION >= 1           \
4245                                   && UNICODE_DOT_DOT_VERSION >= 8)
4246                     if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4247
4248                         /* uc() of this requires 2 characters, but they are
4249                          * ASCII.  If not enough room, grow the string */
4250                         if (SvLEN(dest) < ++min) {
4251                             const UV o = d - (U8*)SvPVX_const(dest);
4252                             d = o + (U8*) SvGROW(dest, min);
4253                         }
4254                         *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
4255                         continue;   /* Back to the tight loop; still in ASCII */
4256                     }
4257 #endif
4258
4259                     /* The other special handling characters have their
4260                      * upper cases outside the latin1 range, hence need to be
4261                      * in UTF-8, so the whole result needs to be in UTF-8.
4262                      *
4263                      * So, here we are somewhere in the middle of processing a
4264                      * non-UTF-8 string, and realize that we will have to
4265                      * convert the whole thing to UTF-8.  What to do?  There
4266                      * are several possibilities.  The simplest to code is to
4267                      * convert what we have so far, set a flag, and continue on
4268                      * in the loop.  The flag would be tested each time through
4269                      * the loop, and if set, the next character would be
4270                      * converted to UTF-8 and stored.  But, I (khw) didn't want
4271                      * to slow down the mainstream case at all for this fairly
4272                      * rare case, so I didn't want to add a test that didn't
4273                      * absolutely have to be there in the loop, besides the
4274                      * possibility that it would get too complicated for
4275                      * optimizers to deal with.  Another possibility is to just
4276                      * give up, convert the source to UTF-8, and restart the
4277                      * function that way.  Another possibility is to convert
4278                      * both what has already been processed and what is yet to
4279                      * come separately to UTF-8, then jump into the loop that
4280                      * handles UTF-8.  But the most efficient time-wise of the
4281                      * ones I could think of is what follows, and turned out to
4282                      * not require much extra code.
4283                      *
4284                      * First, calculate the extra space needed for the
4285                      * remainder of the source needing to be in UTF-8.  Except
4286                      * for the 'i' in Turkic locales, in UTF-8 strings, the
4287                      * uppercase of a character below 256 occupies the same
4288                      * number of bytes as the original.  Therefore, the space
4289                      * needed is the that number plus the number of characters
4290                      * that become two bytes when converted to UTF-8, plus, in
4291                      * turkish locales, the number of 'i's. */
4292
4293                     extra = send - s + variant_under_utf8_count(s, send);
4294
4295 #ifdef USE_LOCALE_CTYPE
4296
4297                     if (UNLIKELY(*s == 'i')) {  /* We wouldn't get an 'i' here
4298                                                    unless are in a Turkic
4299                                                    locale */
4300                         const U8 * s_peek = s;
4301
4302                         do {
4303                             extra++;
4304
4305                             s_peek = (U8 *) memchr(s_peek + 1, 'i',
4306                                                    send - (s_peek + 1));
4307                         } while (s_peek != NULL);
4308                     }
4309 #endif
4310
4311                     /* Convert what we have so far into UTF-8, telling the
4312                      * function that we know it should be converted, and to
4313                      * allow extra space for what we haven't processed yet.
4314                      *
4315                      * This may cause the string pointer to move, so need to
4316                      * save and re-find it. */
4317
4318                     len = d - (U8*)SvPVX_const(dest);
4319                     SvCUR_set(dest, len);
4320                     len = sv_utf8_upgrade_flags_grow(dest,
4321                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4322                                                 extra
4323                                               + 1 /* trailing NUL */ );
4324                     d = (U8*)SvPVX(dest) + len;
4325
4326                     /* Now process the remainder of the source, simultaneously
4327                      * converting to upper and UTF-8.
4328                      *
4329                      * To avoid extra tests in the loop body, and since the
4330                      * loop is so simple, split out the rare Turkic case into
4331                      * its own loop */
4332
4333 #ifdef USE_LOCALE_CTYPE
4334                     if (   UNLIKELY(PL_in_utf8_turkic_locale)
4335                         && UNLIKELY(IN_LC_RUNTIME(LC_CTYPE)))
4336                     {
4337                         for (; s < send; s++) {
4338                             if (*s == 'i') {
4339                                 *d++ = UTF8_TWO_BYTE_HI(LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
4340                                 *d++ = UTF8_TWO_BYTE_LO(LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
4341                             }
4342                             else {
4343                                 (void) _to_upper_title_latin1(*s, d, &len, 'S');
4344                                 d += len;
4345                             }
4346                         }
4347                     }
4348                     else
4349 #endif
4350                         for (; s < send; s++) {
4351                             (void) _to_upper_title_latin1(*s, d, &len, 'S');
4352                             d += len;
4353                         }
4354
4355                     /* Here have processed the whole source; no need to
4356                      * continue with the outer loop.  Each character has been
4357                      * converted to upper case and converted to UTF-8. */
4358                     break;
4359                 } /* End of processing all latin1-style chars */
4360             } /* End of processing all chars */
4361         } /* End of source is not empty */
4362
4363         if (source != dest) {
4364             *d = '\0';  /* Here d points to 1 after last char, add NUL */
4365             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4366         }
4367     } /* End of isn't utf8 */
4368 #ifdef USE_LOCALE_CTYPE
4369     if (IN_LC_RUNTIME(LC_CTYPE)) {
4370         TAINT;
4371         SvTAINTED_on(dest);
4372     }
4373 #endif
4374     if (dest != source && SvTAINTED(source))
4375         SvTAINT(dest);
4376     SvSETMAGIC(dest);
4377     return NORMAL;
4378 }
4379
4380 PP(pp_lc)
4381 {
4382     dSP;
4383     SV *source = TOPs;
4384     STRLEN len;
4385     STRLEN min;
4386     SV *dest;
4387     const U8 *s;
4388     U8 *d;
4389     bool has_turkic_I = FALSE;
4390
4391     SvGETMAGIC(source);
4392
4393     if (   SvPADTMP(source)
4394         && !SvREADONLY(source) && SvPOK(source)
4395         && !DO_UTF8(source)
4396
4397 #ifdef USE_LOCALE_CTYPE
4398
4399         && (   LIKELY(! IN_LC_RUNTIME(LC_CTYPE))
4400             || LIKELY(! PL_in_utf8_turkic_locale))
4401
4402 #endif
4403
4404     ) {
4405
4406         /* We can convert in place, as, outside of Turkic UTF-8 locales,
4407          * lowercasing anything in the latin1 range (or else DO_UTF8 would have
4408          * been on) doesn't lengthen it. */
4409         dest = source;
4410         s = d = (U8*)SvPV_force_nomg(source, len);
4411         min = len + 1;
4412     } else {
4413         dTARGET;
4414
4415         dest = TARG;
4416
4417         s = (const U8*)SvPV_nomg_const(source, len);
4418         min = len + 1;
4419
4420         SvUPGRADE(dest, SVt_PV);
4421         d = (U8*)SvGROW(dest, min);
4422         (void)SvPOK_only(dest);
4423
4424         SETs(dest);
4425     }
4426
4427 #ifdef USE_LOCALE_CTYPE
4428
4429     if (IN_LC_RUNTIME(LC_CTYPE)) {
4430         const U8 * next_I;
4431
4432         _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4433
4434         /* Lowercasing in a Turkic locale can cause non-UTF-8 to need to become
4435          * UTF-8 for the single case of the character 'I' */
4436         if (     UNLIKELY(PL_in_utf8_turkic_locale)
4437             && ! DO_UTF8(source)
4438             &&   (next_I = (U8 *) memchr(s, 'I', len)))
4439         {
4440             Size_t I_count = 0;
4441             const U8 *const send = s + len;
4442
4443             do {
4444                 I_count++;
4445
4446                 next_I = (U8 *) memchr(next_I + 1, 'I',
4447                                         send - (next_I + 1));
4448             } while (next_I != NULL);
4449
4450             /* Except for the 'I', in UTF-8 strings, the lower case of a
4451              * character below 256 occupies the same number of bytes as the
4452              * original.  Therefore, the space needed is the original length
4453              * plus I_count plus the number of characters that become two bytes
4454              * when converted to UTF-8 */
4455             sv_utf8_upgrade_flags_grow(dest, 0, len
4456                                               + I_count
4457                                               + variant_under_utf8_count(s, send)
4458                                               + 1 /* Trailing NUL */ );
4459             d = (U8*)SvPVX(dest);
4460             has_turkic_I = TRUE;
4461         }
4462     }
4463
4464 #endif
4465
4466     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4467        to check DO_UTF8 again here.  */
4468
4469     if (DO_UTF8(source)) {
4470         const U8 *const send = s + len;
4471         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4472         bool remove_dot_above = FALSE;
4473
4474         while (s < send) {
4475             const STRLEN u = UTF8SKIP(s);
4476             STRLEN ulen;
4477
4478 #ifdef USE_LOCALE_CTYPE
4479
4480             _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4481
4482             /* If we are in a Turkic locale, we have to do more work.  As noted
4483              * in the comments for lcfirst, there is a special case if a 'I'
4484              * is in a grapheme with COMBINING DOT ABOVE UTF8.  It turns into a
4485              * 'i', and the DOT must be removed.  We check for that situation,
4486              * and set a flag if the DOT is there.  Then each time through the
4487              * loop, we have to see if we need to remove the next DOT above,
4488              * and if so, do it.  We know that there is a DOT because
4489              * _toLOWER_utf8_flags() wouldn't have returned 'i' unless there
4490              * was one in a proper position. */
4491             if (   UNLIKELY(PL_in_utf8_turkic_locale)
4492                 && IN_LC_RUNTIME(LC_CTYPE))
4493             {
4494                 if (   UNLIKELY(remove_dot_above)
4495                     && memBEGINs(tmpbuf, sizeof(tmpbuf), COMBINING_DOT_ABOVE_UTF8))
4496                 {
4497                     s += u;
4498                     remove_dot_above = FALSE;
4499                     continue;
4500                 }
4501                 else if (UNLIKELY(*s == 'I' && tmpbuf[0] == 'i')) {
4502                     remove_dot_above = TRUE;
4503                 }
4504             }
4505 #else
4506             PERL_UNUSED_VAR(remove_dot_above);
4507
4508             _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, 0);
4509 #endif
4510
4511             /* Here is where we would do context-sensitive actions for the
4512              * Greek final sigma.  See the commit message for 86510fb15 for why
4513              * there isn't any */
4514
4515             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4516
4517                 /* If the eventually required minimum size outgrows the
4518                  * available space, we need to grow. */
4519                 const UV o = d - (U8*)SvPVX_const(dest);
4520
4521                 /* If someone lowercases one million U+0130s we SvGROW() one
4522                  * million times.  Or we could try guessing how much to
4523                  * allocate without allocating too much.  Such is life.
4524                  * Another option would be to grow an extra byte or two more
4525                  * each time we need to grow, which would cut down the million
4526                  * to 500K, with little waste */
4527                 d = o + (U8*) SvGROW(dest, min);
4528             }
4529
4530             /* Copy the newly lowercased letter to the output buffer we're
4531              * building */
4532             Copy(tmpbuf, d, ulen, U8);
4533             d += ulen;
4534             s += u;
4535         }   /* End of looping through the source string */
4536         SvUTF8_on(dest);
4537         *d = '\0';
4538         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4539     } else {    /* 'source' not utf8 */
4540         if (len) {
4541             const U8 *const send = s + len;
4542
4543             /* Use locale casing if in locale; regular style if not treating
4544              * latin1 as having case; otherwise the latin1 casing.  Do the
4545              * whole thing in a tight loop, for speed, */
4546 #ifdef USE_LOCALE_CTYPE
4547             if (IN_LC_RUNTIME(LC_CTYPE)) {
4548                 if (LIKELY( ! has_turkic_I)) {
4549                     for (; s < send; d++, s++)
4550                         *d = toLOWER_LC(*s);
4551                 }
4552                 else {  /* This is the only case where lc() converts 'dest'
4553                            into UTF-8 from a non-UTF-8 'source' */
4554                     for (; s < send; s++) {
4555                         if (*s == 'I') {
4556                             *d++ = UTF8_TWO_BYTE_HI(LATIN_SMALL_LETTER_DOTLESS_I);
4557                             *d++ = UTF8_TWO_BYTE_LO(LATIN_SMALL_LETTER_DOTLESS_I);
4558                         }
4559                         else {
4560                             append_utf8_from_native_byte(toLOWER_LATIN1(*s), &d);
4561                         }
4562                     }
4563                 }
4564             }
4565             else
4566 #endif
4567             if (! IN_UNI_8_BIT) {
4568                 for (; s < send; d++, s++) {
4569                     *d = toLOWER(*s);
4570                 }
4571             }
4572             else {
4573                 for (; s < send; d++, s++) {
4574                     *d = toLOWER_LATIN1(*s);
4575                 }
4576             }
4577         }
4578         if (source != dest) {
4579             *d = '\0';
4580             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4581         }
4582     }
4583 #ifdef USE_LOCALE_CTYPE
4584     if (IN_LC_RUNTIME(LC_CTYPE)) {
4585         TAINT;
4586         SvTAINTED_on(dest);
4587     }
4588 #endif
4589     if (dest != source && SvTAINTED(source))
4590         SvTAINT(dest);
4591     SvSETMAGIC(dest);
4592     return NORMAL;
4593 }
4594
4595 PP(pp_quotemeta)
4596 {
4597     dSP; dTARGET;
4598     SV * const sv = TOPs;
4599     STRLEN len;
4600     const char *s = SvPV_const(sv,len);
4601
4602     SvUTF8_off(TARG);                           /* decontaminate */
4603     if (len) {
4604         char *d;
4605         SvUPGRADE(TARG, SVt_PV);
4606         SvGROW(TARG, (len * 2) + 1);
4607         d = SvPVX(TARG);
4608         if (DO_UTF8(sv)) {
4609             while (len) {
4610                 STRLEN ulen = UTF8SKIP(s);
4611                 bool to_quote = FALSE;
4612
4613                 if (UTF8_IS_INVARIANT(*s)) {
4614                     if (_isQUOTEMETA(*s)) {
4615                         to_quote = TRUE;
4616                     }
4617                 }
4618                 else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(s, s + len)) {
4619                     if (
4620 #ifdef USE_LOCALE_CTYPE
4621                     /* In locale, we quote all non-ASCII Latin1 chars.
4622                      * Otherwise use the quoting rules */
4623
4624                     IN_LC_RUNTIME(LC_CTYPE)
4625                         ||
4626 #endif
4627                         _isQUOTEMETA(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s + 1))))
4628                     {
4629                         to_quote = TRUE;
4630                     }
4631                 }
4632                 else if (is_QUOTEMETA_high(s)) {
4633                     to_quote = TRUE;
4634                 }
4635
4636                 if (to_quote) {
4637                     *d++ = '\\';
4638                 }
4639                 if (ulen > len)
4640                     ulen = len;
4641                 len -= ulen;
4642                 while (ulen--)
4643                     *d++ = *s++;
4644             }
4645             SvUTF8_on(TARG);
4646         }
4647         else if (IN_UNI_8_BIT) {
4648             while (len--) {
4649                 if (_isQUOTEMETA(*s))
4650                     *d++ = '\\';
4651                 *d++ = *s++;
4652             }
4653         }
4654         else {
4655             /* For non UNI_8_BIT (and hence in locale) just quote all \W
4656              * including everything above ASCII */
4657             while (len--) {
4658                 if (!isWORDCHAR_A(*s))
4659                     *d++ = '\\';
4660                 *d++ = *s++;
4661             }
4662         }
4663         *d = '\0';
4664         SvCUR_set(TARG, d - SvPVX_const(TARG));
4665         (void)SvPOK_only_UTF8(TARG);
4666     }
4667     else
4668         sv_setpvn(TARG, s, len);
4669     SETTARG;
4670     return NORMAL;
4671 }
4672
4673 PP(pp_fc)
4674 {
4675     dTARGET;
4676     dSP;
4677     SV *source = TOPs;
4678     STRLEN len;
4679     STRLEN min;
4680     SV *dest;
4681     const U8 *s;
4682     const U8 *send;
4683     U8 *d;
4684     U8 tmpbuf[UTF8_MAXBYTES_CASE + 1];
4685 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
4686    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
4687                                       || UNICODE_DOT_DOT_VERSION > 0)
4688     const bool full_folding = TRUE; /* This variable is here so we can easily
4689                                        move to more generality later */
4690 #else
4691     const bool full_folding = FALSE;
4692 #endif
4693     const U8 flags = ( full_folding      ? FOLD_FLAGS_FULL   : 0 )
4694 #ifdef USE_LOCALE_CTYPE
4695                    | ( IN_LC_RUNTIME(LC_CTYPE) ? FOLD_FLAGS_LOCALE : 0 )
4696 #endif
4697     ;
4698
4699     /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4700      * You are welcome(?) -Hugmeir
4701      */
4702
4703     SvGETMAGIC(source);
4704
4705     dest = TARG;
4706
4707     if (SvOK(source)) {
4708         s = (const U8*)SvPV_nomg_const(source, len);
4709     } else {
4710         if (ckWARN(WARN_UNINITIALIZED))
4711             report_uninit(source);
4712         s = (const U8*)"";
4713         len = 0;
4714     }
4715
4716     min = len + 1;
4717
4718     SvUPGRADE(dest, SVt_PV);
4719     d = (U8*)SvGROW(dest, min);
4720     (void)SvPOK_only(dest);
4721
4722     SETs(dest);
4723
4724     send = s + len;
4725
4726 #ifdef USE_LOCALE_CTYPE
4727
4728     if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
4729         _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4730     }
4731
4732 #endif
4733
4734     if (DO_UTF8(source)) { /* UTF-8 flagged string. */
4735         while (s < send) {
4736             const STRLEN u = UTF8SKIP(s);
4737             STRLEN ulen;
4738
4739             _toFOLD_utf8_flags(s, send, tmpbuf, &ulen, flags);
4740
4741             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4742                 const UV o = d - (U8*)SvPVX_const(dest);
4743                 d = o + (U8*) SvGROW(dest, min);
4744             }
4745
4746             Copy(tmpbuf, d, ulen, U8);
4747             d += ulen;
4748             s += u;
4749         }
4750         SvUTF8_on(dest);
4751     } /* Unflagged string */
4752     else if (len) {
4753 #ifdef USE_LOCALE_CTYPE
4754         if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
4755             if (IN_UTF8_CTYPE_LOCALE) {
4756                 goto do_uni_folding;
4757             }
4758             for (; s < send; d++, s++)
4759                 *d = (U8) toFOLD_LC(*s);
4760         }
4761         else
4762 #endif
4763         if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
4764             for (; s < send; d++, s++)
4765                 *d = toFOLD(*s);
4766         }
4767         else {
4768 #ifdef USE_LOCALE_CTYPE
4769       do_uni_folding:
4770 #endif
4771             /* For ASCII and the Latin-1 range, there's potentially three
4772              * troublesome folds:
4773              *      \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
4774              *             casefolding becomes 'ss';
4775              *      \x{B5} (\N{MICRO SIGN}), which under any fold becomes
4776              *             \x{3BC} (\N{GREEK SMALL LETTER MU})
4777              *      I      only in Turkic locales, this folds to \x{131}
4778              *             \N{LATIN SMALL LETTER DOTLESS I}
4779              * For the rest, the casefold is their lowercase.  */
4780             for (; s < send; d++, s++) {
4781                 if (    UNLIKELY(*s == MICRO_SIGN)
4782 #ifdef USE_LOCALE_CTYPE
4783                     || (   UNLIKELY(PL_in_utf8_turkic_locale)
4784                         && UNLIKELY(IN_LC_RUNTIME(LC_CTYPE))
4785                         && UNLIKELY(*s == 'I'))
4786 #endif
4787                 ) {
4788                     Size_t extra = send - s
4789                                  + variant_under_utf8_count(s, send);
4790
4791                     /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
4792                      * and 'I' in Turkic locales is \N{LATIN SMALL LETTER
4793                      * DOTLESS I} both of which are outside of the latin-1
4794                      * range. There's a couple of ways to deal with this -- khw
4795                      * discusses them in pp_lc/uc, so go there :) What we do
4796                      * here is upgrade what we had already casefolded, then
4797                      * enter an inner loop that appends the rest of the
4798                      * characters as UTF-8.
4799                      *
4800                      * First we calculate the needed size of the upgraded dest
4801                      * beyond what's been processed already (the upgrade
4802                      * function figures that out).  Except for the 'I' in
4803                      * Turkic locales, in UTF-8 strings, the fold case of a
4804                      * character below 256 occupies the same number of bytes as
4805                      * the original (even the Sharp S).  Therefore, the space
4806                      * needed is the number of bytes remaining plus the number
4807                      * of characters that become two bytes when converted to
4808                      * UTF-8 plus, in turkish locales, the number of 'I's */
4809
4810                     if (UNLIKELY(*s == 'I')) {
4811                         const U8 * s_peek = s;
4812
4813                         do {
4814                             extra++;
4815
4816                             s_peek = (U8 *) memchr(s_peek + 1, 'i',
4817                                                    send - (s_peek + 1));
4818                         } while (s_peek != NULL);
4819                     }
4820
4821                     /* Growing may move things, so have to save and recalculate
4822                      * 'd' */
4823                     len = d - (U8*)SvPVX_const(dest);
4824                     SvCUR_set(dest, len);
4825                     len = sv_utf8_upgrade_flags_grow(dest,
4826                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4827                                                 extra
4828                                               + 1 /* Trailing NUL */ );
4829                     d = (U8*)SvPVX(dest) + len;
4830
4831                     *d++ = UTF8_TWO_BYTE_HI(GREEK_SMALL_LETTER_MU);
4832                     *d++ = UTF8_TWO_BYTE_LO(GREEK_SMALL_LETTER_MU);
4833                     s++;
4834
4835                     for (; s < send; s++) {
4836                         STRLEN ulen;
4837                         _to_uni_fold_flags(*s, d, &ulen, flags);
4838                         d += ulen;
4839                     }
4840                     break;
4841                 }
4842                 else if (   UNLIKELY(*s == LATIN_SMALL_LETTER_SHARP_S)
4843                          && full_folding)
4844                 {
4845                     /* Under full casefolding, LATIN SMALL LETTER SHARP S
4846                      * becomes "ss", which may require growing the SV. */
4847                     if (SvLEN(dest) < ++min) {
4848                         const UV o = d - (U8*)SvPVX_const(dest);
4849                         d = o + (U8*) SvGROW(dest, min);
4850                      }
4851                     *(d)++ = 's';
4852                     *d = 's';
4853                 }
4854                 else { /* Else, the fold is the lower case */
4855                     *d = toLOWER_LATIN1(*s);
4856                 }
4857              }
4858         }
4859     }
4860     *d = '\0';
4861     SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4862
4863 #ifdef USE_LOCALE_CTYPE
4864     if (IN_LC_RUNTIME(LC_CTYPE)) {
4865         TAINT;
4866         SvTAINTED_on(dest);
4867     }
4868 #endif
4869     if (SvTAINTED(source))
4870         SvTAINT(dest);
4871     SvSETMAGIC(dest);
4872     RETURN;
4873 }
4874
4875 /* Arrays. */
4876
4877 PP(pp_aslice)
4878 {
4879     dSP; dMARK; dORIGMARK;
4880     AV *const av = MUTABLE_AV(POPs);
4881     const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4882
4883     if (SvTYPE(av) == SVt_PVAV) {
4884         const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4885         bool can_preserve = FALSE;
4886
4887         if (localizing) {
4888             MAGIC *mg;
4889             HV *stash;
4890
4891             can_preserve = SvCANEXISTDELETE(av);
4892         }
4893
4894         if (lval && localizing) {
4895             SV **svp;
4896             SSize_t max = -1;
4897             for (svp = MARK + 1; svp <= SP; svp++) {
4898                 const SSize_t elem = SvIV(*svp);
4899                 if (elem > max)
4900                     max = elem;
4901             }
4902             if (max > AvMAX(av))
4903                 av_extend(av, max);
4904         }
4905
4906         while (++MARK <= SP) {
4907             SV **svp;
4908             SSize_t elem = SvIV(*MARK);
4909             bool preeminent = TRUE;
4910
4911             if (localizing && can_preserve) {
4912                 /* If we can determine whether the element exist,
4913                  * Try to preserve the existenceness of a tied array
4914                  * element by using EXISTS and DELETE if possible.
4915                  * Fallback to FETCH and STORE otherwise. */
4916                 preeminent = av_exists(av, elem);
4917             }
4918
4919             svp = av_fetch(av, elem, lval);
4920             if (lval) {
4921                 if (!svp || !*svp)
4922                     DIE(aTHX_ PL_no_aelem, elem);
4923                 if (localizing) {
4924                     if (preeminent)
4925                         save_aelem(av, elem, svp);
4926                     else
4927                         SAVEADELETE(av, elem);
4928                 }
4929             }
4930             *MARK = svp ? *svp : &PL_sv_undef;
4931         }
4932     }
4933     if (GIMME_V != G_ARRAY) {
4934         MARK = ORIGMARK;
4935         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4936         SP = MARK;
4937     }
4938     RETURN;
4939 }
4940
4941 PP(pp_kvaslice)
4942 {
4943     dSP; dMARK;
4944     AV *const av = MUTABLE_AV(POPs);
4945     I32 lval = (PL_op->op_flags & OPf_MOD);
4946     SSize_t items = SP - MARK;
4947
4948     if (PL_op->op_private & OPpMAYBE_LVSUB) {
4949        const I32 flags = is_lvalue_sub();
4950        if (flags) {
4951            if (!(flags & OPpENTERSUB_INARGS))
4952                /* diag_listed_as: Can't modify %s in %s */
4953                Perl_croak(aTHX_ "Can't modify index/value array slice in list assignment");
4954            lval = flags;
4955        }
4956     }
4957
4958     MEXTEND(SP,items);
4959     while (items > 1) {
4960         *(MARK+items*2-1) = *(MARK+items);
4961         items--;
4962     }
4963     items = SP-MARK;
4964     SP += items;
4965
4966     while (++MARK <= SP) {
4967         SV **svp;
4968
4969         svp = av_fetch(av, SvIV(*MARK), lval);
4970         if (lval) {
4971             if (!svp || !*svp || *svp == &PL_sv_undef) {
4972                 DIE(aTHX_ PL_no_aelem, SvIV(*MARK));
4973             }
4974             *MARK = sv_mortalcopy(*MARK);
4975         }
4976         *++MARK = svp ? *svp : &PL_sv_undef;
4977     }
4978     if (GIMME_V != G_ARRAY) {
4979         MARK = SP - items*2;
4980         *++MARK = items > 0 ? *SP : &PL_sv_undef;
4981         SP = MARK;
4982     }
4983     RETURN;
4984 }
4985
4986
4987 PP(pp_aeach)
4988 {
4989     dSP;
4990     AV *array = MUTABLE_AV(POPs);
4991     const U8 gimme = GIMME_V;
4992     IV *iterp = Perl_av_iter_p(aTHX_ array);
4993     const IV current = (*iterp)++;
4994
4995     if (current > av_top_index(array)) {
4996         *iterp = 0;
4997         if (gimme == G_SCALAR)
4998             RETPUSHUNDEF;
4999         else
5000             RETURN;
5001     }
5002
5003     EXTEND(SP, 2);
5004     mPUSHi(current);
5005     if (gimme == G_ARRAY) {
5006         SV **const element = av_fetch(array, current, 0);
5007         PUSHs(element ? *element : &PL_sv_undef);
5008     }
5009     RETURN;
5010 }
5011
5012 /* also used for: pp_avalues()*/
5013 PP(pp_akeys)
5014 {
5015     dSP;
5016     AV *array = MUTABLE_AV(POPs);
5017     const U8 gimme = GIMME_V;
5018
5019     *Perl_av_iter_p(aTHX_ array) = 0;
5020
5021     if (gimme == G_SCALAR) {
5022         dTARGET;
5023         PUSHi(av_count(array));
5024     }
5025     else if (gimme == G_ARRAY) {
5026       if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
5027         const I32 flags = is_lvalue_sub();
5028         if (flags && !(flags & OPpENTERSUB_INARGS))
5029             /* diag_listed_as: Can't modify %s in %s */
5030             Perl_croak(aTHX_
5031                       "Can't modify keys on array in list assignment");
5032       }
5033       {
5034         IV n = av_top_index(array);
5035         IV i;
5036
5037         EXTEND(SP, n + 1);
5038
5039         if (  PL_op->op_type == OP_AKEYS
5040            || (  PL_op->op_type == OP_AVHVSWITCH
5041               && (PL_op->op_private & 3) + OP_AEACH == OP_AKEYS  ))
5042         {
5043             for (i = 0;  i <= n;  i++) {
5044                 mPUSHi(i);
5045             }
5046         }
5047         else {
5048             for (i = 0;  i <= n;  i++) {
5049                 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
5050                 PUSHs(elem ? *elem : &PL_sv_undef);
5051             }
5052         }
5053       }
5054     }
5055     RETURN;
5056 }
5057
5058 /* Associative arrays. */
5059
5060 PP(pp_each)
5061 {
5062     dSP;
5063     HV * hash = MUTABLE_HV(POPs);
5064     HE *entry;
5065     const U8 gimme = GIMME_V;
5066
5067     entry = hv_iternext(hash);
5068
5069     EXTEND(SP, 2);
5070     if (entry) {
5071         SV* const sv = hv_iterkeysv(entry);
5072         PUSHs(sv);
5073         if (gimme == G_ARRAY) {
5074             SV *val;
5075             val = hv_iterval(hash, entry);
5076             PUSHs(val);
5077         }
5078     }
5079     else if (gimme == G_SCALAR)
5080         RETPUSHUNDEF;
5081
5082     RETURN;
5083 }
5084
5085 STATIC OP *
5086 S_do_delete_local(pTHX)
5087 {
5088     dSP;
5089     const U8 gimme = GIMME_V;
5090     const MAGIC *mg;
5091     HV *stash;
5092     const bool sliced = !!(PL_op->op_private & OPpSLICE);
5093     SV **unsliced_keysv = sliced ? NULL : sp--;
5094     SV * const osv = POPs;
5095     SV **mark = sliced ? PL_stack_base + POPMARK : unsliced_keysv-1;
5096     dORIGMARK;
5097     const bool tied = SvRMAGICAL(osv)
5098                             && mg_find((const SV *)osv, PERL_MAGIC_tied);
5099     const bool can_preserve = SvCANEXISTDELETE(osv);
5100     const U32 type = SvTYPE(osv);
5101     SV ** const end = sliced ? SP : unsliced_keysv;
5102
5103     if (type == SVt_PVHV) {                     /* hash element */
5104             HV * const hv = MUTABLE_HV(osv);
5105             while (++MARK <= end) {
5106                 SV * const keysv = *MARK;
5107                 SV *sv = NULL;
5108                 bool preeminent = TRUE;
5109                 if (can_preserve)
5110                     preeminent = hv_exists_ent(hv, keysv, 0);
5111                 if (tied) {
5112                     HE *he = hv_fetch_ent(hv, keysv, 1, 0);
5113                     if (he)
5114                         sv = HeVAL(he);
5115                     else
5116                         preeminent = FALSE;
5117                 }
5118                 else {
5119                     sv = hv_delete_ent(hv, keysv, 0, 0);
5120                     if (preeminent)
5121                         SvREFCNT_inc_simple_void(sv); /* De-mortalize */
5122                 }
5123                 if (preeminent) {
5124                     if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5125                     save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
5126                     if (tied) {
5127                         *MARK = sv_mortalcopy(sv);
5128                         mg_clear(sv);
5129                     } else
5130                         *MARK = sv;
5131                 }
5132                 else {
5133                     SAVEHDELETE(hv, keysv);
5134                     *MARK = &PL_sv_undef;
5135                 }
5136             }
5137     }
5138     else if (type == SVt_PVAV) {                  /* array element */
5139             if (PL_op->op_flags & OPf_SPECIAL) {
5140                 AV * const av = MUTABLE_AV(osv);
5141                 while (++MARK <= end) {
5142                     SSize_t idx = SvIV(*MARK);
5143                     SV *sv = NULL;
5144                     bool preeminent = TRUE;
5145                     if (can_preserve)
5146                         preeminent = av_exists(av, idx);
5147                     if (tied) {
5148                         SV **svp = av_fetch(av, idx, 1);
5149                         if (svp)
5150                             sv = *svp;
5151                         else
5152                             preeminent = FALSE;
5153                     }
5154                     else {
5155                         sv = av_delete(av, idx, 0);
5156                         if (preeminent)
5157                            SvREFCNT_inc_simple_void(sv); /* De-mortalize */
5158                     }
5159                     if (preeminent) {
5160                         save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
5161                         if (tied) {
5162                             *MARK = sv_mortalcopy(sv);
5163                             mg_clear(sv);
5164                         } else
5165                             *MARK = sv;
5166                     }
5167                     else {
5168                         SAVEADELETE(av, idx);
5169                         *MARK = &PL_sv_undef;
5170                     }
5171                 }
5172             }
5173             else
5174                 DIE(aTHX_ "panic: avhv_delete no longer supported");
5175     }
5176     else
5177             DIE(aTHX_ "Not a HASH reference");
5178     if (sliced) {
5179         if (gimme == G_VOID)
5180             SP = ORIGMARK;
5181         else if (gimme == G_SCALAR) {
5182             MARK = ORIGMARK;
5183             if (SP > MARK)
5184                 *++MARK = *SP;
5185             else
5186                 *++MARK = &PL_sv_undef;
5187             SP = MARK;
5188         }
5189     }
5190     else if (gimme != G_VOID)
5191         PUSHs(*unsliced_keysv);
5192
5193     RETURN;
5194 }
5195
5196 PP(pp_delete)
5197 {
5198     dSP;
5199     U8 gimme;
5200     I32 discard;
5201
5202     if (PL_op->op_private & OPpLVAL_INTRO)
5203         return do_delete_local();
5204
5205     gimme = GIMME_V;
5206     discard = (gimme == G_VOID) ? G_DISCARD : 0;
5207
5208     if (PL_op->op_private & (OPpSLICE|OPpKVSLICE)) {
5209         dMARK; dORIGMARK;
5210         HV * const hv = MUTABLE_HV(POPs);
5211         const U32 hvtype = SvTYPE(hv);
5212         int skip = 0;
5213         if (PL_op->op_private & OPpKVSLICE) {
5214             SSize_t items = SP - MARK;
5215
5216             MEXTEND(SP,items);
5217             while (items > 1) {
5218                 *(MARK+items*2-1) = *(MARK+items);
5219                 items--;
5220             }
5221             items = SP - MARK;
5222             SP += items;
5223             skip = 1;
5224         }
5225         if (hvtype == SVt_PVHV) {                       /* hash element */
5226             while ((MARK += (1+skip)) <= SP) {
5227                 SV * const sv = hv_delete_ent(hv, *(MARK-skip), discard, 0);
5228                 *MARK = sv ? sv : &PL_sv_undef;
5229             }
5230         }
5231         else if (hvtype == SVt_PVAV) {                  /* array element */
5232             if (PL_op->op_flags & OPf_SPECIAL) {
5233                 while ((MARK += (1+skip)) <= SP) {
5234                     SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*(MARK-skip)), discard);
5235                     *MARK = sv ? sv : &PL_sv_undef;
5236                 }
5237             }
5238         }
5239         else
5240             DIE(aTHX_ "Not a HASH reference");
5241         if (discard)
5242             SP = ORIGMARK;
5243         else if (gimme == G_SCALAR) {
5244             MARK = ORIGMARK;
5245             if (SP > MARK)
5246                 *++MARK = *SP;
5247             else
5248                 *++MARK = &PL_sv_undef;
5249             SP = MARK;
5250         }
5251     }
5252     else {
5253         SV *keysv = POPs;
5254         HV * const hv = MUTABLE_HV(POPs);
5255         SV *sv = NULL;
5256         if (SvTYPE(hv) == SVt_PVHV)
5257             sv = hv_delete_ent(hv, keysv, discard, 0);
5258         else if (SvTYPE(hv) == SVt_PVAV) {
5259             if (PL_op->op_flags & OPf_SPECIAL)
5260                 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
5261             else
5262                 DIE(aTHX_ "panic: avhv_delete no longer supported");
5263         }
5264         else
5265             DIE(aTHX_ "Not a HASH reference");
5266         if (!sv)
5267             sv = &PL_sv_undef;
5268         if (!discard)
5269             PUSHs(sv);
5270     }
5271     RETURN;
5272 }
5273
5274 PP(pp_exists)
5275 {
5276     dSP;
5277     SV *tmpsv;
5278     HV *hv;
5279
5280     if (UNLIKELY( PL_op->op_private & OPpEXISTS_SUB )) {
5281         GV *gv;
5282         SV * const sv = POPs;
5283         CV * const cv = sv_2cv(sv, &hv, &gv, 0);
5284         if (cv)
5285             RETPUSHYES;
5286         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
5287             RETPUSHYES;
5288         RETPUSHNO;
5289     }
5290     tmpsv = POPs;
5291     hv = MUTABLE_HV(POPs);
5292     if (LIKELY( SvTYPE(hv) == SVt_PVHV )) {
5293         if (hv_exists_ent(hv, tmpsv, 0))
5294             RETPUSHYES;
5295     }
5296     else if (SvTYPE(hv) == SVt_PVAV) {
5297         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
5298             if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
5299                 RETPUSHYES;
5300         }
5301     }
5302     else {
5303         DIE(aTHX_ "Not a HASH reference");
5304     }
5305     RETPUSHNO;
5306 }
5307
5308 PP(pp_hslice)
5309 {
5310     dSP; dMARK; dORIGMARK;
5311     HV * const hv = MUTABLE_HV(POPs);
5312     const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
5313     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
5314     bool can_preserve = FALSE;
5315
5316     if (localizing) {
5317         MAGIC *mg;
5318         HV *stash;
5319
5320         if (SvCANEXISTDELETE(hv))
5321             can_preserve = TRUE;
5322     }
5323
5324     while (++MARK <= SP) {
5325         SV * const keysv = *MARK;
5326         SV **svp;
5327         HE *he;
5328         bool preeminent = TRUE;
5329
5330         if (localizing && can_preserve) {
5331             /* If we can determine whether the element exist,
5332              * try to preserve the existenceness of a tied hash
5333              * element by using EXISTS and DELETE if possible.
5334              * Fallback to FETCH and STORE otherwise. */
5335             preeminent = hv_exists_ent(hv, keysv, 0);
5336         }
5337
5338         he = hv_fetch_ent(hv, keysv, lval, 0);
5339         svp = he ? &HeVAL(he) : NULL;
5340
5341         if (lval) {
5342             if (!svp || !*svp || *svp == &PL_sv_undef) {
5343                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5344             }
5345             if (localizing) {
5346                 if (HvNAME_get(hv) && isGV_or_RVCV(*svp))
5347                     save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
5348                 else if (preeminent)
5349                     save_helem_flags(hv, keysv, svp,
5350                          (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
5351                 else
5352                     SAVEHDELETE(hv, keysv);
5353             }
5354         }
5355         *MARK = svp && *svp ? *svp : &PL_sv_undef;
5356     }
5357     if (GIMME_V != G_ARRAY) {
5358         MARK = ORIGMARK;
5359         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
5360         SP = MARK;
5361     }
5362     RETURN;
5363 }
5364
5365 PP(pp_kvhslice)
5366 {
5367     dSP; dMARK;
5368     HV * const hv = MUTABLE_HV(POPs);
5369     I32 lval = (PL_op->op_flags & OPf_MOD);
5370     SSize_t items = SP - MARK;
5371
5372     if (PL_op->op_private & OPpMAYBE_LVSUB) {
5373        const I32 flags = is_lvalue_sub();
5374        if (flags) {
5375            if (!(flags & OPpENTERSUB_INARGS))
5376                /* diag_listed_as: Can't modify %s in %s */
5377                Perl_croak(aTHX_ "Can't modify key/value hash slice in %s assignment",
5378                                  GIMME_V == G_ARRAY ? "list" : "scalar");
5379            lval = flags;
5380        }
5381     }
5382
5383     MEXTEND(SP,items);
5384     while (items > 1) {
5385         *(MARK+items*2-1) = *(MARK+items);
5386         items--;
5387     }
5388     items = SP-MARK;
5389     SP += items;
5390
5391     while (++MARK <= SP) {
5392         SV * const keysv = *MARK;
5393         SV **svp;
5394         HE *he;
5395
5396         he = hv_fetch_ent(hv, keysv, lval, 0);
5397         svp = he ? &HeVAL(he) : NULL;
5398
5399         if (lval) {
5400             if (!svp || !*svp || *svp == &PL_sv_undef) {
5401                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5402             }
5403             *MARK = sv_mortalcopy(*MARK);
5404         }
5405         *++MARK = svp && *svp ? *svp : &PL_sv_undef;
5406     }
5407     if (GIMME_V != G_ARRAY) {
5408         MARK = SP - items*2;
5409         *++MARK = items > 0 ? *SP : &PL_sv_undef;
5410         SP = MARK;
5411     }
5412     RETURN;
5413 }
5414
5415 /* List operators. */
5416
5417 PP(pp_list)
5418 {
5419     I32 markidx = POPMARK;
5420     if (GIMME_V != G_ARRAY) {
5421         /* don't initialize mark here, EXTEND() may move the stack */
5422         SV **mark;
5423         dSP;
5424         EXTEND(SP, 1);          /* in case no arguments, as in @empty */
5425         mark = PL_stack_base + markidx;
5426         if (++MARK <= SP)
5427             *MARK = *SP;                /* unwanted list, return last item */
5428         else
5429             *MARK = &PL_sv_undef;
5430         SP = MARK;
5431         PUTBACK;
5432     }
5433     return NORMAL;
5434 }
5435
5436 PP(pp_lslice)
5437 {
5438     dSP;
5439     SV ** const lastrelem = PL_stack_sp;
5440     SV ** const lastlelem = PL_stack_base + POPMARK;
5441     SV ** const firstlelem = PL_stack_base + POPMARK + 1;
5442     SV ** const firstrelem = lastlelem + 1;
5443     const U8 mod = PL_op->op_flags & OPf_MOD;
5444
5445     const I32 max = lastrelem - lastlelem;
5446     SV **lelem;
5447
5448     if (GIMME_V != G_ARRAY) {
5449         if (lastlelem < firstlelem) {
5450             EXTEND(SP, 1);
5451             *firstlelem = &PL_sv_undef;
5452         }
5453         else {
5454             I32 ix = SvIV(*lastlelem);
5455             if (ix < 0)
5456                 ix += max;
5457             if (ix < 0 || ix >= max)
5458                 *firstlelem = &PL_sv_undef;
5459             else
5460                 *firstlelem = firstrelem[ix];
5461         }
5462         SP = firstlelem;
5463         RETURN;
5464     }
5465
5466     if (max == 0) {
5467         SP = firstlelem - 1;
5468         RETURN;
5469     }
5470
5471     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
5472         I32 ix = SvIV(*lelem);
5473         if (ix < 0)
5474             ix += max;
5475         if (ix < 0 || ix >= max)
5476             *lelem = &PL_sv_undef;
5477         else {
5478             if (!(*lelem = firstrelem[ix]))
5479                 *lelem = &PL_sv_undef;
5480             else if (mod && SvPADTMP(*lelem)) {
5481                 *lelem = firstrelem[ix] = sv_mortalcopy(*lelem);
5482             }
5483         }
5484     }
5485     SP = lastlelem;
5486     RETURN;
5487 }
5488
5489 PP(pp_anonlist)
5490 {
5491     dSP; dMARK;
5492     const I32 items = SP - MARK;
5493     SV * const av = MUTABLE_SV(av_make(items, MARK+1));
5494     SP = MARK;
5495     mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5496             ? newRV_noinc(av) : av);
5497     RETURN;
5498 }
5499
5500 PP(pp_anonhash)
5501 {
5502     dSP; dMARK; dORIGMARK;
5503     HV* const hv = newHV();
5504     SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL
5505                                     ? newRV_noinc(MUTABLE_SV(hv))
5506                                     : MUTABLE_SV(hv) );
5507
5508     while (MARK < SP) {
5509         SV * const key =
5510             (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK);
5511         SV *val;
5512         if (MARK < SP)
5513         {
5514             MARK++;
5515             SvGETMAGIC(*MARK);
5516             val = newSV(0);
5517             sv_setsv_nomg(val, *MARK);
5518         }
5519         else
5520         {
5521             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
5522             val = newSV(0);
5523         }
5524         (void)hv_store_ent(hv,key,val,0);
5525     }
5526     SP = ORIGMARK;
5527     XPUSHs(retval);
5528     RETURN;
5529 }
5530
5531 PP(pp_splice)
5532 {
5533     dSP; dMARK; dORIGMARK;
5534     int num_args = (SP - MARK);
5535     AV *ary = MUTABLE_AV(*++MARK);
5536     SV **src;
5537     SV **dst;
5538     SSize_t i;
5539     SSize_t offset;
5540     SSize_t length;
5541     SSize_t newlen;
5542     SSize_t after;
5543     SSize_t diff;
5544     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5545
5546     if (mg) {
5547         return Perl_tied_method(aTHX_ SV_CONST(SPLICE), mark - 1, MUTABLE_SV(ary), mg,
5548                                     GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
5549                                     sp - mark);
5550     }
5551
5552     if (SvREADONLY(ary))
5553         Perl_croak_no_modify();
5554
5555     SP++;
5556
5557     if (++MARK < SP) {
5558         offset = i = SvIV(*MARK);
5559         if (offset < 0)
5560             offset += AvFILLp(ary) + 1;
5561         if (offset < 0)
5562             DIE(aTHX_ PL_no_aelem, i);
5563         if (++MARK < SP) {
5564             length = SvIVx(*MARK++);
5565             if (length < 0) {
5566                 length += AvFILLp(ary) - offset + 1;
5567                 if (length < 0)
5568                     length = 0;
5569             }
5570         }
5571         else
5572             length = AvMAX(ary) + 1;            /* close enough to infinity */
5573     }
5574     else {
5575         offset = 0;
5576         length = AvMAX(ary) + 1;
5577     }
5578     if (offset > AvFILLp(ary) + 1) {
5579         if (num_args > 2)
5580             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
5581         offset = AvFILLp(ary) + 1;
5582     }
5583     after = AvFILLp(ary) + 1 - (offset + length);
5584     if (after < 0) {                            /* not that much array */
5585         length += after;                        /* offset+length now in array */
5586         after = 0;
5587         if (!AvALLOC(ary))
5588             av_extend(ary, 0);
5589     }
5590
5591     /* At this point, MARK .. SP-1 is our new LIST */
5592
5593     newlen = SP - MARK;
5594     diff = newlen - length;
5595     if (newlen && !AvREAL(ary) && AvREIFY(ary))
5596         av_reify(ary);
5597
5598     /* make new elements SVs now: avoid problems if they're from the array */
5599     for (dst = MARK, i = newlen; i; i--) {
5600         SV * const h = *dst;
5601         *dst++ = newSVsv(h);
5602     }
5603
5604     if (diff < 0) {                             /* shrinking the area */
5605         SV **tmparyval = NULL;
5606         if (newlen) {
5607             Newx(tmparyval, newlen, SV*);       /* so remember insertion */
5608             Copy(MARK, tmparyval, newlen, SV*);
5609         }
5610
5611         MARK = ORIGMARK + 1;
5612         if (GIMME_V == G_ARRAY) {               /* copy return vals to stack */
5613             const bool real = cBOOL(AvREAL(ary));
5614             MEXTEND(MARK, length);
5615             if (real)
5616                 EXTEND_MORTAL(length);
5617             for (i = 0, dst = MARK; i < length; i++) {
5618                 if ((*dst = AvARRAY(ary)[i+offset])) {
5619                   if (real)
5620                     sv_2mortal(*dst);   /* free them eventually */
5621                 }
5622                 else
5623                     *dst = &PL_sv_undef;
5624                 dst++;
5625             }
5626             MARK += length - 1;
5627         }
5628         else {
5629             *MARK = AvARRAY(ary)[offset+length-1];
5630             if (AvREAL(ary)) {
5631                 sv_2mortal(*MARK);
5632                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5633                     SvREFCNT_dec(*dst++);       /* free them now */
5634             }
5635             if (!*MARK)
5636                 *MARK = &PL_sv_undef;
5637         }
5638         AvFILLp(ary) += diff;
5639
5640         /* pull up or down? */
5641
5642         if (offset < after) {                   /* easier to pull up */
5643             if (offset) {                       /* esp. if nothing to pull */
5644                 src = &AvARRAY(ary)[offset-1];
5645                 dst = src - diff;               /* diff is negative */
5646                 for (i = offset; i > 0; i--)    /* can't trust Copy */
5647                     *dst-- = *src--;
5648             }
5649             dst = AvARRAY(ary);
5650             AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5651             AvMAX(ary) += diff;
5652         }
5653         else {
5654             if (after) {                        /* anything to pull down? */
5655                 src = AvARRAY(ary) + offset + length;
5656                 dst = src + diff;               /* diff is negative */
5657                 Move(src, dst, after, SV*);
5658             }
5659             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5660                                                 /* avoid later double free */
5661         }
5662         i = -diff;
5663         while (i)
5664             dst[--i] = NULL;
5665
5666         if (newlen) {
5667             Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5668             Safefree(tmparyval);
5669         }
5670     }
5671     else {                                      /* no, expanding (or same) */
5672         SV** tmparyval = NULL;
5673         if (length) {
5674             Newx(tmparyval, length, SV*);       /* so remember deletion */
5675             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5676         }
5677
5678         if (diff > 0) {                         /* expanding */
5679             /* push up or down? */
5680             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5681                 if (offset) {
5682                     src = AvARRAY(ary);
5683                     dst = src - diff;
5684                     Move(src, dst, offset, SV*);
5685                 }
5686                 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5687                 AvMAX(ary) += diff;
5688                 AvFILLp(ary) += diff;
5689             }
5690             else {
5691                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
5692                     av_extend(ary, AvFILLp(ary) + diff);
5693                 AvFILLp(ary) += diff;
5694
5695                 if (after) {
5696                     dst = AvARRAY(ary) + AvFILLp(ary);
5697                     src = dst - diff;
5698                     for (i = after; i; i--) {
5699                         *dst-- = *src--;
5700                     }
5701                 }
5702             }
5703         }
5704
5705         if (newlen) {
5706             Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5707         }
5708
5709         MARK = ORIGMARK + 1;
5710         if (GIMME_V == G_ARRAY) {               /* copy return vals to stack */
5711             if (length) {
5712                 const bool real = cBOOL(AvREAL(ary));
5713                 if (real)
5714                     EXTEND_MORTAL(length);
5715                 for (i = 0, dst = MARK; i < length; i++) {
5716                     if ((*dst = tmparyval[i])) {
5717                       if (real)
5718                         sv_2mortal(*dst);       /* free them eventually */
5719                     }
5720                     else *dst = &PL_sv_undef;
5721                     dst++;
5722                 }
5723             }
5724             MARK += length - 1;
5725         }
5726         else if (length--) {
5727             *MARK = tmparyval[length];
5728             if (AvREAL(ary)) {
5729                 sv_2mortal(*MARK);
5730                 while (length-- > 0)
5731                     SvREFCNT_dec(tmparyval[length]);
5732             }
5733             if (!*MARK)
5734                 *MARK = &PL_sv_undef;
5735         }
5736         else
5737             *MARK = &PL_sv_undef;
5738         Safefree(tmparyval);
5739     }
5740
5741     if (SvMAGICAL(ary))
5742         mg_set(MUTABLE_SV(ary));
5743
5744     SP = MARK;
5745     RETURN;
5746 }
5747
5748 PP(pp_push)
5749 {
5750     dSP; dMARK; dORIGMARK; dTARGET;
5751     AV * const ary = MUTABLE_AV(*++MARK);
5752     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5753
5754     if (mg) {
5755         *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5756         PUSHMARK(MARK);
5757         PUTBACK;
5758         ENTER_with_name("call_PUSH");
5759         call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5760         LEAVE_with_name("call_PUSH");
5761         /* SPAGAIN; not needed: SP is assigned to immediately below */
5762     }
5763     else {
5764         /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
5765          * only need to save locally, not on the save stack */
5766         U16 old_delaymagic = PL_delaymagic;
5767
5768         if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify();
5769         PL_delaymagic = DM_DELAY;
5770         for (++MARK; MARK <= SP; MARK++) {
5771             SV *sv;
5772             if (*MARK) SvGETMAGIC(*MARK);
5773             sv = newSV(0);
5774             if (*MARK)
5775                 sv_setsv_nomg(sv, *MARK);
5776             av_store(ary, AvFILLp(ary)+1, sv);
5777         }
5778         if (PL_delaymagic & DM_ARRAY_ISA)
5779             mg_set(MUTABLE_SV(ary));
5780         PL_delaymagic = old_delaymagic;
5781     }
5782     SP = ORIGMARK;
5783     if (OP_GIMME(PL_op, 0) != G_VOID) {
5784         PUSHi( AvFILL(ary) + 1 );
5785     }
5786     RETURN;
5787 }
5788
5789 /* also used for: pp_pop()*/
5790 PP(pp_shift)
5791 {
5792     dSP;
5793     AV * const av = PL_op->op_flags & OPf_SPECIAL
5794         ? MUTABLE_AV(GvAVn(PL_defgv)) : MUTABLE_AV(POPs);
5795     SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5796     EXTEND(SP, 1);
5797     assert (sv);
5798     if (AvREAL(av))
5799         (void)sv_2mortal(sv);
5800     PUSHs(sv);
5801     RETURN;
5802 }
5803
5804 PP(pp_unshift)
5805 {
5806     dSP; dMARK; dORIGMARK; dTARGET;
5807     AV *ary = MUTABLE_AV(*++MARK);
5808     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5809
5810     if (mg) {
5811         *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5812         PUSHMARK(MARK);
5813         PUTBACK;
5814         ENTER_with_name("call_UNSHIFT");
5815         call_sv(SV_CONST(UNSHIFT),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5816         LEAVE_with_name("call_UNSHIFT");
5817         /* SPAGAIN; not needed: SP is assigned to immediately below */
5818     }
5819     else {
5820         /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
5821          * only need to save locally, not on the save stack */
5822         U16 old_delaymagic = PL_delaymagic;
5823         SSize_t i = 0;
5824
5825         av_unshift(ary, SP - MARK);
5826         PL_delaymagic = DM_DELAY;
5827         while (MARK < SP) {
5828             SV * const sv = newSVsv(*++MARK);
5829             (void)av_store(ary, i++, sv);
5830         }
5831         if (PL_delaymagic & DM_ARRAY_ISA)
5832             mg_set(MUTABLE_SV(ary));
5833         PL_delaymagic = old_delaymagic;
5834     }
5835     SP = ORIGMARK;
5836     if (OP_GIMME(PL_op, 0) != G_VOID) {
5837         PUSHi( AvFILL(ary) + 1 );
5838     }
5839     RETURN;
5840 }
5841
5842 PP(pp_reverse)
5843 {
5844     dSP; dMARK;
5845
5846     if (GIMME_V == G_ARRAY) {
5847         if (PL_op->op_private & OPpREVERSE_INPLACE) {
5848             AV *av;
5849
5850             /* See pp_sort() */
5851             assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5852             (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5853             av = MUTABLE_AV((*SP));
5854             /* In-place reversing only happens in void context for the array
5855              * assignment. We don't need to push anything on the stack. */
5856             SP = MARK;
5857
5858             if (SvMAGICAL(av)) {
5859                 SSize_t i, j;
5860                 SV *tmp = sv_newmortal();
5861                 /* For SvCANEXISTDELETE */
5862                 HV *stash;
5863                 const MAGIC *mg;
5864                 bool can_preserve = SvCANEXISTDELETE(av);
5865
5866                 for (i = 0, j = av_top_index(av); i < j; ++i, --j) {
5867                     SV *begin, *end;
5868
5869                     if (can_preserve) {
5870                         if (!av_exists(av, i)) {
5871                             if (av_exists(av, j)) {
5872                                 SV *sv = av_delete(av, j, 0);
5873                                 begin = *av_fetch(av, i, TRUE);
5874                                 sv_setsv_mg(begin, sv);
5875                             }
5876                             continue;
5877                         }
5878                         else if (!av_exists(av, j)) {
5879                             SV *sv = av_delete(av, i, 0);
5880                             end = *av_fetch(av, j, TRUE);
5881                             sv_setsv_mg(end, sv);
5882                             continue;
5883                         }
5884                     }
5885
5886                     begin = *av_fetch(av, i, TRUE);
5887                     end   = *av_fetch(av, j, TRUE);
5888                     sv_setsv(tmp,      begin);
5889                     sv_setsv_mg(begin, end);
5890                     sv_setsv_mg(end,   tmp);
5891                 }
5892             }
5893             else {
5894                 SV **begin = AvARRAY(av);
5895
5896                 if (begin) {
5897                     SV **end   = begin + AvFILLp(av);
5898
5899                     while (begin < end) {
5900                         SV * const tmp = *begin;
5901                         *begin++ = *end;
5902                         *end--   = tmp;
5903                     }
5904                 }
5905             }
5906         }
5907         else {
5908             SV **oldsp = SP;
5909             MARK++;
5910             while (MARK < SP) {
5911                 SV * const tmp = *MARK;
5912                 *MARK++ = *SP;
5913                 *SP--   = tmp;
5914             }
5915             /* safe as long as stack cannot get extended in the above */
5916             SP = oldsp;
5917         }
5918     }
5919     else {
5920         char *up;
5921         dTARGET;
5922         STRLEN len;
5923
5924         SvUTF8_off(TARG);                               /* decontaminate */
5925         if (SP - MARK > 1) {
5926             do_join(TARG, &PL_sv_no, MARK, SP);
5927             SP = MARK + 1;
5928             SETs(TARG);
5929         } else if (SP > MARK) {
5930             sv_setsv(TARG, *SP);
5931             SETs(TARG);
5932         } else {
5933             sv_setsv(TARG, DEFSV);
5934             XPUSHs(TARG);
5935         }
5936         SvSETMAGIC(TARG); /* remove any utf8 length magic */
5937
5938         up = SvPV_force(TARG, len);
5939         if (len > 1) {
5940             char *down;
5941             if (DO_UTF8(TARG)) {        /* first reverse each character */
5942                 U8* s = (U8*)SvPVX(TARG);
5943                 const U8* send = (U8*)(s + len);
5944                 while (s < send) {
5945                     if (UTF8_IS_INVARIANT(*s)) {
5946                         s++;
5947                         continue;
5948                     }
5949                     else {
5950                         if (!utf8_to_uvchr_buf(s, send, 0))
5951                             break;
5952                         up = (char*)s;
5953                         s += UTF8SKIP(s);
5954                         down = (char*)(s - 1);
5955                         /* reverse this character */
5956                         while (down > up) {
5957                             const char tmp = *up;
5958                             *up++ = *down;
5959                             *down-- = tmp;
5960                         }
5961                     }
5962                 }
5963                 up = SvPVX(TARG);
5964             }
5965             down = SvPVX(TARG) + len - 1;
5966             while (down > up) {
5967                 const char tmp = *up;
5968                 *up++ = *down;
5969                 *down-- = tmp;
5970             }
5971             (void)SvPOK_only_UTF8(TARG);
5972         }
5973     }
5974     RETURN;
5975 }
5976
5977 PP(pp_split)
5978 {
5979     dSP; dTARG;
5980     AV *ary = (   (PL_op->op_private & OPpSPLIT_ASSIGN) /* @a = split */
5981                && (PL_op->op_flags & OPf_STACKED))      /* @{expr} = split */
5982                ? (AV *)POPs : NULL;
5983     IV limit = POPi;                    /* note, negative is forever */
5984     SV * const sv = POPs;
5985     STRLEN len;
5986     const char *s = SvPV_const(sv, len);
5987     const bool do_utf8 = DO_UTF8(sv);
5988     const bool in_uni_8_bit = IN_UNI_8_BIT;
5989     const char *strend = s + len;
5990     PMOP *pm = cPMOPx(PL_op);
5991     REGEXP *rx;
5992     SV *dstr;
5993     const char *m;
5994     SSize_t iters = 0;
5995     const STRLEN slen = do_utf8
5996                         ? utf8_length((U8*)s, (U8*)strend)
5997                         : (STRLEN)(strend - s);
5998     SSize_t maxiters = slen + 10;
5999     I32 trailing_empty = 0;
6000     const char *orig;
6001     const IV origlimit = limit;
6002     I32 realarray = 0;
6003     I32 base;
6004     const U8 gimme = GIMME_V;
6005     bool gimme_scalar;
6006     I32 oldsave = PL_savestack_ix;
6007     U32 make_mortal = SVs_TEMP;
6008     bool multiline = 0;
6009     MAGIC *mg = NULL;
6010
6011     rx = PM_GETRE(pm);
6012
6013     TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
6014              (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
6015
6016     /* handle @ary = split(...) optimisation */
6017     if (PL_op->op_private & OPpSPLIT_ASSIGN) {
6018         realarray = 1;
6019         if (!(PL_op->op_flags & OPf_STACKED)) {
6020             if (PL_op->op_private & OPpSPLIT_LEX) {
6021                 if (PL_op->op_private & OPpLVAL_INTRO)
6022                     SAVECLEARSV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff));
6023                 ary = (AV *)PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff);
6024             }
6025             else {
6026                 GV *gv =
6027 #ifdef USE_ITHREADS
6028                         MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff));
6029 #else
6030                         pm->op_pmreplrootu.op_pmtargetgv;
6031 #endif
6032                 if (PL_op->op_private & OPpLVAL_INTRO)
6033                     ary = save_ary(gv);
6034                 else
6035                     ary = GvAVn(gv);
6036             }
6037             /* skip anything pushed by OPpLVAL_INTRO above */
6038             oldsave = PL_savestack_ix;
6039         }
6040
6041         /* Some defence against stack-not-refcounted bugs */
6042         (void)sv_2mortal(SvREFCNT_inc_simple_NN(ary));
6043
6044         if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
6045             PUSHMARK(SP);
6046             XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
6047         } else {
6048             make_mortal = 0;
6049         }
6050     }
6051
6052     base = SP - PL_stack_base;
6053     orig = s;
6054     if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
6055         if (do_utf8) {
6056             while (s < strend && isSPACE_utf8_safe(s, strend))
6057                 s += UTF8SKIP(s);
6058         }
6059         else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
6060             while (s < strend && isSPACE_LC(*s))
6061                 s++;
6062         }
6063         else if (in_uni_8_bit) {
6064             while (s < strend && isSPACE_L1(*s))
6065                 s++;
6066         }
6067         else {
6068             while (s < strend && isSPACE(*s))
6069                 s++;
6070         }
6071     }
6072     if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
6073         multiline = 1;
6074     }
6075
6076     gimme_scalar = gimme == G_SCALAR && !ary;
6077
6078     if (!limit)
6079         limit = maxiters + 2;
6080     if (RX_EXTFLAGS(rx) & RXf_WHITE) {
6081         while (--limit) {
6082             m = s;
6083             /* this one uses 'm' and is a negative test */
6084             if (do_utf8) {
6085                 while (m < strend && ! isSPACE_utf8_safe(m, strend) ) {
6086                     const int t = UTF8SKIP(m);
6087                     /* isSPACE_utf8_safe returns FALSE for malform utf8 */
6088                     if (strend - m < t)
6089                         m = strend;
6090                     else
6091                         m += t;
6092                 }
6093             }
6094             else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
6095             {
6096                 while (m < strend && !isSPACE_LC(*m))
6097                     ++m;
6098             }
6099             else if (in_uni_8_bit) {
6100                 while (m < strend && !isSPACE_L1(*m))
6101                     ++m;
6102             } else {
6103                 while (m < strend && !isSPACE(*m))
6104                     ++m;
6105             }
6106             if (m >= strend)
6107                 break;
6108
6109             if (gimme_scalar) {
6110                 iters++;
6111                 if (m-s == 0)
6112                     trailing_empty++;
6113                 else
6114                     trailing_empty = 0;
6115             } else {
6116                 dstr = newSVpvn_flags(s, m-s,
6117                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6118                 XPUSHs(dstr);
6119             }
6120
6121             /* skip the whitespace found last */
6122             if (do_utf8)
6123                 s = m + UTF8SKIP(m);
6124             else
6125                 s = m + 1;
6126
6127             /* this one uses 's' and is a positive test */
6128             if (do_utf8) {
6129                 while (s < strend && isSPACE_utf8_safe(s, strend) )
6130                     s +=  UTF8SKIP(s);
6131             }
6132             else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
6133             {
6134                 while (s < strend && isSPACE_LC(*s))
6135                     ++s;
6136             }
6137             else if (in_uni_8_bit) {
6138                 while (s < strend && isSPACE_L1(*s))
6139                     ++s;
6140             } else {
6141                 while (s < strend && isSPACE(*s))
6142                     ++s;
6143             }
6144         }
6145     }
6146     else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
6147         while (--limit) {
6148             for (m = s; m < strend && *m != '\n'; m++)
6149                 ;
6150             m++;
6151             if (m >= strend)
6152                 break;
6153
6154             if (gimme_scalar) {
6155                 iters++;
6156                 if (m-s == 0)
6157                     trailing_empty++;
6158                 else
6159                     trailing_empty = 0;
6160             } else {
6161                 dstr = newSVpvn_flags(s, m-s,
6162                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6163                 XPUSHs(dstr);
6164             }
6165             s = m;
6166         }
6167     }
6168     else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
6169         /* This case boils down to deciding which is the smaller of:
6170          * limit - effectively a number of characters
6171          * slen - which already contains the number of characters in s
6172          *
6173          * The resulting number is the number of iters (for gimme_scalar)
6174          * or the number of SVs to create (!gimme_scalar). */
6175
6176         /* setting it to -1 will trigger a panic in EXTEND() */
6177         const SSize_t sslen = slen > SSize_t_MAX ?  -1 : (SSize_t)slen;
6178         const IV items = limit - 1;
6179         if (sslen < items || items < 0) {
6180             iters = slen -1;
6181             limit = slen + 1;
6182             /* Note: The same result is returned if the following block
6183              * is removed, because of the "keep field after final delim?"
6184              * adjustment, but having the following makes the "correct"
6185              * behaviour more apparent. */
6186             if (gimme_scalar) {
6187                 s = strend;
6188                 iters++;
6189             }
6190         } else {
6191             iters = items;
6192         }
6193         if (!gimme_scalar) {
6194             /*
6195               Pre-extend the stack, either the number of bytes or
6196               characters in the string or a limited amount, triggered by:
6197               my ($x, $y) = split //, $str;
6198                 or
6199               split //, $str, $i;
6200             */
6201             EXTEND(SP, limit);
6202             if (do_utf8) {
6203                 while (--limit) {
6204                     m = s;
6205                     s += UTF8SKIP(s);
6206                     dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
6207                     PUSHs(dstr);
6208                 }
6209             } else {
6210                 while (--limit) {
6211                     dstr = newSVpvn_flags(s, 1, make_mortal);
6212                     PUSHs(dstr);
6213                     s++;
6214                 }
6215             }
6216         }
6217     }
6218     else if (do_utf8 == (RX_UTF8(rx) != 0) &&
6219              (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
6220              && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
6221              && !(RX_EXTFLAGS(rx) & RXf_IS_ANCHORED)) {
6222         const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
6223         SV * const csv = CALLREG_INTUIT_STRING(rx);
6224
6225         len = RX_MINLENRET(rx);
6226         if (len == 1 && !RX_UTF8(rx) && !tail) {
6227             const char c = *SvPV_nolen_const(csv);
6228             while (--limit) {
6229                 for (m = s; m < strend && *m != c; m++)
6230                     ;
6231                 if (m >= strend)
6232                     break;
6233                 if (gimme_scalar) {
6234                     iters++;
6235                     if (m-s == 0)
6236                         trailing_empty++;
6237                     else
6238                         trailing_empty = 0;
6239                 } else {
6240                     dstr = newSVpvn_flags(s, m-s,
6241                                          (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6242                     XPUSHs(dstr);
6243                 }
6244                 /* The rx->minlen is in characters but we want to step
6245                  * s ahead by bytes. */
6246                 if (do_utf8)
6247                     s = (char*)utf8_hop_forward((U8*) m, len, (U8*) strend);
6248                 else
6249                     s = m + len; /* Fake \n at the end */
6250             }
6251         }
6252         else {
6253             while (s < strend && --limit &&
6254               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
6255                              csv, multiline ? FBMrf_MULTILINE : 0)) )
6256             {
6257                 if (gimme_scalar) {
6258                     iters++;
6259                     if (m-s == 0)
6260                         trailing_empty++;
6261                     else
6262                         trailing_empty = 0;
6263                 } else {
6264                     dstr = newSVpvn_flags(s, m-s,
6265                                          (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6266                     XPUSHs(dstr);
6267                 }
6268                 /* The rx->minlen is in characters but we want to step
6269                  * s ahead by bytes. */
6270                 if (do_utf8)
6271                     s = (char*)utf8_hop_forward((U8*)m, len, (U8 *) strend);
6272                 else
6273                     s = m + len; /* Fake \n at the end */
6274             }
6275         }
6276     }
6277     else {
6278         maxiters += slen * RX_NPARENS(rx);
6279         while (s < strend && --limit)
6280         {
6281             I32 rex_return;
6282             PUTBACK;
6283             rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1,
6284                                      sv, NULL, 0);
6285             SPAGAIN;
6286             if (rex_return == 0)
6287                 break;
6288             TAINT_IF(RX_MATCH_TAINTED(rx));
6289             /* we never pass the REXEC_COPY_STR flag, so it should
6290              * never get copied */
6291             assert(!RX_MATCH_COPIED(rx));
6292             m = RX_OFFS(rx)[0].start + orig;
6293
6294             if (gimme_scalar) {
6295                 iters++;
6296                 if (m-s == 0)
6297                     trailing_empty++;
6298                 else
6299                     trailing_empty = 0;
6300             } else {
6301                 dstr = newSVpvn_flags(s, m-s,
6302                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6303                 XPUSHs(dstr);
6304             }
6305             if (RX_NPARENS(rx)) {
6306                 I32 i;
6307                 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
6308                     s = RX_OFFS(rx)[i].start + orig;
6309                     m = RX_OFFS(rx)[i].end + orig;
6310
6311                     /* japhy (07/27/01) -- the (m && s) test doesn't catch
6312                        parens that didn't match -- they should be set to
6313                        undef, not the empty string */
6314                     if (gimme_scalar) {
6315                         iters++;
6316                         if (m-s == 0)
6317                             trailing_empty++;
6318                         else
6319                             trailing_empty = 0;
6320                     } else {
6321                         if (m >= orig && s >= orig) {
6322                             dstr = newSVpvn_flags(s, m-s,
6323                                                  (do_utf8 ? SVf_UTF8 : 0)
6324                                                   | make_mortal);
6325                         }
6326                         else
6327                             dstr = &PL_sv_undef;  /* undef, not "" */
6328                         XPUSHs(dstr);
6329                     }
6330
6331                 }
6332             }
6333             s = RX_OFFS(rx)[0].end + orig;
6334         }
6335     }
6336
6337     if (!gimme_scalar) {
6338         iters = (SP - PL_stack_base) - base;
6339     }
6340     if (iters > maxiters)
6341         DIE(aTHX_ "Split loop");
6342
6343     /* keep field after final delim? */
6344     if (s < strend || (iters && origlimit)) {
6345         if (!gimme_scalar) {
6346             const STRLEN l = strend - s;
6347             dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6348             XPUSHs(dstr);
6349         }
6350         iters++;
6351     }
6352     else if (!origlimit) {
6353         if (gimme_scalar) {
6354             iters -= trailing_empty;
6355         } else {
6356             while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
6357                 if (TOPs && !make_mortal)
6358                     sv_2mortal(TOPs);
6359                 *SP-- = NULL;
6360                 iters--;
6361             }
6362         }
6363     }
6364
6365     PUTBACK;
6366     LEAVE_SCOPE(oldsave);
6367     SPAGAIN;
6368     if (realarray) {
6369         if (!mg) {
6370             PUTBACK;
6371             if(AvREAL(ary)) {
6372                 if (av_count(ary) > 0)
6373                     av_clear(ary);
6374             } else {
6375                 AvREAL_on(ary);
6376                 AvREIFY_off(ary);
6377
6378                 if (AvMAX(ary) > -1) {
6379                     /* don't free mere refs */
6380                     Zero(AvARRAY(ary), AvMAX(ary), SV*);
6381                 }
6382             }
6383             if(AvMAX(ary) < iters)
6384                 av_extend(ary,iters);
6385             SPAGAIN;
6386
6387             /* Need to copy the SV*s from the stack into ary */
6388             Copy(SP + 1 - iters, AvARRAY(ary), iters, SV*);
6389             AvFILLp(ary) = iters - 1;
6390
6391             if (SvSMAGICAL(ary)) {
6392                 PUTBACK;
6393                 mg_set(MUTABLE_SV(ary));
6394                 SPAGAIN;
6395             }
6396
6397             if (gimme != G_ARRAY) {
6398                 /* SP points to the final SV* pushed to the stack. But the SV*  */
6399                 /* are not going to be used from the stack. Point SP to below   */
6400                 /* the first of these SV*.                                      */
6401                 SP -= iters;
6402                 PUTBACK;
6403             }
6404         }
6405         else {
6406             PUTBACK;
6407             av_extend(ary,iters);
6408             av_clear(ary);
6409
6410             ENTER_with_name("call_PUSH");
6411             call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
6412             LEAVE_with_name("call_PUSH");
6413             SPAGAIN;
6414
6415             if (gimme == G_ARRAY) {
6416                 SSize_t i;
6417                 /* EXTEND should not be needed - we just popped them */
6418                 EXTEND_SKIP(SP, iters);
6419                 for (i=0; i < iters; i++) {
6420                     SV **svp = av_fetch(ary, i, FALSE);
6421                     PUSHs((svp) ? *svp : &PL_sv_undef);
6422                 }
6423                 RETURN;
6424             }
6425         }
6426     }
6427
6428     if (gimme != G_ARRAY) {
6429         GETTARGET;
6430         XPUSHi(iters);
6431      }
6432
6433     RETURN;
6434 }
6435
6436 PP(pp_once)
6437 {
6438     dSP;
6439     SV *const sv = PAD_SVl(PL_op->op_targ);
6440
6441     if (SvPADSTALE(sv)) {
6442         /* First time. */
6443         SvPADSTALE_off(sv);
6444         RETURNOP(cLOGOP->op_other);
6445     }
6446     RETURNOP(cLOGOP->op_next);
6447 }
6448
6449 PP(pp_lock)
6450 {
6451     dSP;
6452     dTOPss;
6453     SV *retsv = sv;
6454     SvLOCK(sv);
6455     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6456      || SvTYPE(retsv) == SVt_PVCV) {
6457         retsv = refto(retsv);
6458     }
6459     SETs(retsv);
6460     RETURN;
6461 }
6462
6463
6464 /* used for: pp_padany(), pp_custom(); plus any system ops
6465  * that aren't implemented on a particular platform */
6466
6467 PP(unimplemented_op)
6468 {
6469     const Optype op_type = PL_op->op_type;
6470     /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
6471        with out of range op numbers - it only "special" cases op_custom.
6472        Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
6473        if we get here for a custom op then that means that the custom op didn't
6474        have an implementation. Given that OP_NAME() looks up the custom op
6475        by its op_ppaddr, likely it will return NULL, unless someone (unhelpfully)
6476        registers &Perl_unimplemented_op as the address of their custom op.
6477        NULL doesn't generate a useful error message. "custom" does. */
6478     const char *const name = op_type >= OP_max
6479         ? "[out of range]" : PL_op_name[op_type];
6480     if(OP_IS_SOCKET(op_type))
6481         DIE(aTHX_ PL_no_sock_func, name);
6482     DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name,  op_type);
6483 }
6484
6485 static void
6486 S_maybe_unwind_defav(pTHX)
6487 {
6488     if (CX_CUR()->cx_type & CXp_HASARGS) {
6489         PERL_CONTEXT *cx = CX_CUR();
6490
6491         assert(CxHASARGS(cx));
6492         cx_popsub_args(cx);
6493         cx->cx_type &= ~CXp_HASARGS;
6494     }
6495 }
6496
6497 /* For sorting out arguments passed to a &CORE:: subroutine */
6498 PP(pp_coreargs)
6499 {
6500     dSP;
6501     int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
6502     int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0;
6503     AV * const at_ = GvAV(PL_defgv);
6504     SV **svp = at_ ? AvARRAY(at_) : NULL;
6505     I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
6506     I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
6507     bool seen_question = 0;
6508     const char *err = NULL;
6509     const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
6510
6511     /* Count how many args there are first, to get some idea how far to
6512        extend the stack. */
6513     while (oa) {
6514         if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
6515         maxargs++;
6516         if (oa & OA_OPTIONAL) seen_question = 1;
6517         if (!seen_question) minargs++;
6518         oa >>= 4;
6519     }
6520
6521     if(numargs < minargs) err = "Not enough";
6522     else if(numargs > maxargs) err = "Too many";
6523     if (err)
6524         /* diag_listed_as: Too many arguments for %s */
6525         Perl_croak(aTHX_
6526           "%s arguments for %s", err,
6527            opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv)
6528         );
6529
6530     /* Reset the stack pointer.  Without this, we end up returning our own
6531        arguments in list context, in addition to the values we are supposed
6532        to return.  nextstate usually does this on sub entry, but we need
6533        to run the next op with the caller's hints, so we cannot have a
6534        nextstate. */
6535     SP = PL_stack_base + CX_CUR()->blk_oldsp;
6536
6537     if(!maxargs) RETURN;
6538
6539     /* We do this here, rather than with a separate pushmark op, as it has
6540        to come in between two things this function does (stack reset and
6541        arg pushing).  This seems the easiest way to do it. */
6542     if (pushmark) {
6543         PUTBACK;
6544         (void)Perl_pp_pushmark(aTHX);
6545     }
6546
6547     EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
6548     PUTBACK; /* The code below can die in various places. */
6549
6550     oa = PL_opargs[opnum] >> OASHIFT;
6551     for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
6552         whicharg++;
6553         switch (oa & 7) {
6554         case OA_SCALAR:
6555           try_defsv:
6556             if (!numargs && defgv && whicharg == minargs + 1) {
6557                 PUSHs(DEFSV);
6558             }
6559             else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
6560             break;
6561         case OA_LIST:
6562             while (numargs--) {
6563                 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
6564                 svp++;
6565             }
6566             RETURN;
6567         case OA_AVREF:
6568             if (!numargs) {
6569                 GV *gv;
6570                 if (CvUNIQUE(find_runcv_where(FIND_RUNCV_level_eq,1,NULL)))
6571                     gv = PL_argvgv;
6572                 else {
6573                     S_maybe_unwind_defav(aTHX);
6574                     gv = PL_defgv;
6575                 }
6576                 PUSHs((SV *)GvAVn(gv));
6577                 break;
6578             }
6579             if (!svp || !*svp || !SvROK(*svp)
6580              || SvTYPE(SvRV(*svp)) != SVt_PVAV)
6581                 DIE(aTHX_
6582                 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6583                  "Type of arg %d to &CORE::%s must be array reference",
6584                   whicharg, PL_op_desc[opnum]
6585                 );
6586             PUSHs(SvRV(*svp));
6587             break;
6588         case OA_HVREF:
6589             if (!svp || !*svp || !SvROK(*svp)
6590              || (  SvTYPE(SvRV(*svp)) != SVt_PVHV
6591                 && (  opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN
6592                    || SvTYPE(SvRV(*svp)) != SVt_PVAV  )))
6593                 DIE(aTHX_
6594                 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6595                  "Type of arg %d to &CORE::%s must be hash%s reference",
6596                   whicharg, PL_op_desc[opnum],
6597                   opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN
6598                      ? ""
6599                      : " or array"
6600                 );
6601             PUSHs(SvRV(*svp));
6602             break;
6603         case OA_FILEREF:
6604             if (!numargs) PUSHs(NULL);
6605             else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
6606                 /* no magic here, as the prototype will have added an extra
6607                    refgen and we just want what was there before that */
6608                 PUSHs(SvRV(*svp));
6609             else {
6610                 const bool constr = PL_op->op_private & whicharg;
6611                 PUSHs(S_rv2gv(aTHX_
6612                     svp && *svp ? *svp : &PL_sv_undef,
6613                     constr, cBOOL(CopHINTS_get(PL_curcop) & HINT_STRICT_REFS),
6614                     !constr
6615                 ));
6616             }
6617             break;
6618         case OA_SCALARREF:
6619           if (!numargs) goto try_defsv;
6620           else {
6621             const bool wantscalar =
6622                 PL_op->op_private & OPpCOREARGS_SCALARMOD;
6623             if (!svp || !*svp || !SvROK(*svp)
6624                 /* We have to permit globrefs even for the \$ proto, as
6625                    *foo is indistinguishable from ${\*foo}, and the proto-
6626                    type permits the latter. */
6627              || SvTYPE(SvRV(*svp)) > (
6628                      wantscalar       ? SVt_PVLV
6629                    : opnum == OP_LOCK || opnum == OP_UNDEF
6630                                       ? SVt_PVCV
6631                    :                    SVt_PVHV
6632                 )
6633                )
6634                 DIE(aTHX_
6635                  "Type of arg %d to &CORE::%s must be %s",
6636                   whicharg, PL_op_name[opnum],
6637                   wantscalar
6638                     ? "scalar reference"
6639                     : opnum == OP_LOCK || opnum == OP_UNDEF
6640                        ? "reference to one of [$@%&*]"
6641                        : "reference to one of [$@%*]"
6642                 );
6643             PUSHs(SvRV(*svp));
6644             if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv) {
6645                 /* Undo @_ localisation, so that sub exit does not undo
6646                    part of our undeffing. */
6647                 S_maybe_unwind_defav(aTHX);
6648             }
6649           }
6650           break;
6651         default:
6652             DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
6653         }
6654         oa = oa >> 4;
6655     }
6656
6657     RETURN;
6658 }
6659
6660 /* Implement CORE::keys(),values(),each().
6661  *
6662  * We won't know until run-time whether the arg is an array or hash,
6663  * so this op calls
6664  *
6665  *    pp_keys/pp_values/pp_each
6666  * or
6667  *    pp_akeys/pp_avalues/pp_aeach
6668  *
6669  * as appropriate (or whatever pp function actually implements the OP_FOO
6670  * functionality for each FOO).
6671  */
6672
6673 PP(pp_avhvswitch)
6674 {
6675     dSP;
6676     return PL_ppaddr[
6677                 (SvTYPE(TOPs) == SVt_PVAV ? OP_AEACH : OP_EACH)
6678                     + (PL_op->op_private & OPpAVHVSWITCH_MASK)
6679            ](aTHX);
6680 }
6681
6682 PP(pp_runcv)
6683 {
6684     dSP;
6685     CV *cv;
6686     if (PL_op->op_private & OPpOFFBYONE) {
6687         cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL);
6688     }
6689     else cv = find_runcv(NULL);
6690     XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
6691     RETURN;
6692 }
6693
6694 static void
6695 S_localise_aelem_lval(pTHX_ AV * const av, SV * const keysv,
6696                             const bool can_preserve)
6697 {
6698     const SSize_t ix = SvIV(keysv);
6699     if (can_preserve ? av_exists(av, ix) : TRUE) {
6700         SV ** const svp = av_fetch(av, ix, 1);
6701         if (!svp || !*svp)
6702             Perl_croak(aTHX_ PL_no_aelem, ix);
6703         save_aelem(av, ix, svp);
6704     }
6705     else
6706         SAVEADELETE(av, ix);
6707 }
6708
6709 static void
6710 S_localise_helem_lval(pTHX_ HV * const hv, SV * const keysv,
6711                             const bool can_preserve)
6712 {
6713     if (can_preserve ? hv_exists_ent(hv, keysv, 0) : TRUE) {
6714         HE * const he = hv_fetch_ent(hv, keysv, 1, 0);
6715         SV ** const svp = he ? &HeVAL(he) : NULL;
6716         if (!svp || !*svp)
6717             Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(keysv));
6718         save_helem_flags(hv, keysv, svp, 0);
6719     }
6720     else
6721         SAVEHDELETE(hv, keysv);
6722 }
6723
6724 static void
6725 S_localise_gv_slot(pTHX_ GV *gv, U8 type)
6726 {
6727     if (type == OPpLVREF_SV) {
6728         save_pushptrptr(gv, SvREFCNT_inc_simple(GvSV(gv)), SAVEt_GVSV);
6729         GvSV(gv) = 0;
6730     }
6731     else if (type == OPpLVREF_AV)
6732         /* XXX Inefficient, as it creates a new AV, which we are
6733                about to clobber.  */
6734         save_ary(gv);
6735     else {
6736         assert(type == OPpLVREF_HV);
6737         /* XXX Likewise inefficient.  */
6738         save_hash(gv);
6739     }
6740 }
6741
6742
6743 PP(pp_refassign)
6744 {
6745     dSP;
6746     SV * const key = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6747     SV * const left = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6748     dTOPss;
6749     const char *bad = NULL;
6750     const U8 type = PL_op->op_private & OPpLVREF_TYPE;
6751     if (!SvROK(sv)) DIE(aTHX_ "Assigned value is not a reference");
6752     switch (type) {
6753     case OPpLVREF_SV:
6754         if (SvTYPE(SvRV(sv)) > SVt_PVLV)
6755             bad = " SCALAR";
6756         break;
6757     case OPpLVREF_AV:
6758         if (SvTYPE(SvRV(sv)) != SVt_PVAV)
6759             bad = "n ARRAY";
6760         break;
6761     case OPpLVREF_HV:
6762         if (SvTYPE(SvRV(sv)) != SVt_PVHV)
6763             bad = " HASH";
6764         break;
6765     case OPpLVREF_CV:
6766         if (SvTYPE(SvRV(sv)) != SVt_PVCV)
6767             bad = " CODE";
6768     }
6769     if (bad)
6770         /* diag_listed_as: Assigned value is not %s reference */
6771         DIE(aTHX_ "Assigned value is not a%s reference", bad);
6772     {
6773     MAGIC *mg;
6774     HV *stash;
6775     switch (left ? SvTYPE(left) : 0) {
6776     case 0:
6777     {
6778         SV * const old = PAD_SV(ARGTARG);
6779         PAD_SETSV(ARGTARG, SvREFCNT_inc_NN(SvRV(sv)));
6780         SvREFCNT_dec(old);
6781         if ((PL_op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
6782                 == OPpLVAL_INTRO)
6783             SAVECLEARSV(PAD_SVl(ARGTARG));
6784         break;
6785     }
6786     case SVt_PVGV:
6787         if (PL_op->op_private & OPpLVAL_INTRO) {
6788             S_localise_gv_slot(aTHX_ (GV *)left, type);
6789         }
6790         gv_setref(left, sv);
6791         SvSETMAGIC(left);
6792         break;
6793     case SVt_PVAV:
6794         assert(key);
6795         if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6796             S_localise_aelem_lval(aTHX_ (AV *)left, key,
6797                                         SvCANEXISTDELETE(left));
6798         }
6799         av_store((AV *)left, SvIV(key), SvREFCNT_inc_simple_NN(SvRV(sv)));
6800         break;
6801     case SVt_PVHV:
6802         if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6803             assert(key);
6804             S_localise_helem_lval(aTHX_ (HV *)left, key,
6805                                         SvCANEXISTDELETE(left));
6806         }
6807         (void)hv_store_ent((HV *)left, key, SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
6808     }
6809     if (PL_op->op_flags & OPf_MOD)
6810         SETs(sv_2mortal(newSVsv(sv)));
6811     /* XXX else can weak references go stale before they are read, e.g.,
6812        in leavesub?  */
6813     RETURN;
6814     }
6815 }
6816
6817 PP(pp_lvref)
6818 {
6819     dSP;
6820     SV * const ret = sv_2mortal(newSV_type(SVt_PVMG));
6821     SV * const elem = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6822     SV * const arg = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6823     MAGIC * const mg = sv_magicext(ret, arg, PERL_MAGIC_lvref,
6824                                    &PL_vtbl_lvref, (char *)elem,
6825                                    elem ? HEf_SVKEY : (I32)ARGTARG);
6826     mg->mg_private = PL_op->op_private;
6827     if (PL_op->op_private & OPpLVREF_ITER)
6828         mg->mg_flags |= MGf_PERSIST;
6829     if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6830       if (elem) {
6831         MAGIC *mg;
6832         HV *stash;
6833         assert(arg);
6834         {
6835             const bool can_preserve = SvCANEXISTDELETE(arg);
6836             if (SvTYPE(arg) == SVt_PVAV)
6837               S_localise_aelem_lval(aTHX_ (AV *)arg, elem, can_preserve);
6838             else
6839               S_localise_helem_lval(aTHX_ (HV *)arg, elem, can_preserve);
6840         }
6841       }
6842       else if (arg) {
6843         S_localise_gv_slot(aTHX_ (GV *)arg,
6844                                  PL_op->op_private & OPpLVREF_TYPE);
6845       }
6846       else if (!(PL_op->op_private & OPpPAD_STATE))
6847         SAVECLEARSV(PAD_SVl(ARGTARG));
6848     }
6849     XPUSHs(ret);
6850     RETURN;
6851 }
6852
6853 PP(pp_lvrefslice)
6854 {
6855     dSP; dMARK;
6856     AV * const av = (AV *)POPs;
6857     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
6858     bool can_preserve = FALSE;
6859
6860     if (UNLIKELY(localizing)) {
6861         MAGIC *mg;
6862         HV *stash;
6863         SV **svp;
6864
6865         can_preserve = SvCANEXISTDELETE(av);
6866
6867         if (SvTYPE(av) == SVt_PVAV) {
6868             SSize_t max = -1;
6869
6870             for (svp = MARK + 1; svp <= SP; svp++) {
6871                 const SSize_t elem = SvIV(*svp);
6872                 if (elem > max)
6873                     max = elem;
6874             }
6875             if (max > AvMAX(av))
6876                 av_extend(av, max);
6877         }
6878     }
6879
6880     while (++MARK <= SP) {
6881         SV * const elemsv = *MARK;
6882         if (UNLIKELY(localizing)) {
6883             if (SvTYPE(av) == SVt_PVAV)
6884                 S_localise_aelem_lval(aTHX_ av, elemsv, can_preserve);
6885             else
6886                 S_localise_helem_lval(aTHX_ (HV *)av, elemsv, can_preserve);
6887         }
6888         *MARK = sv_2mortal(newSV_type(SVt_PVMG));
6889         sv_magic(*MARK,(SV *)av,PERL_MAGIC_lvref,(char *)elemsv,HEf_SVKEY);
6890     }
6891     RETURN;
6892 }
6893
6894 PP(pp_lvavref)
6895 {
6896     if (PL_op->op_flags & OPf_STACKED)
6897         Perl_pp_rv2av(aTHX);
6898     else
6899         Perl_pp_padav(aTHX);
6900     {
6901         dSP;
6902         dTOPss;
6903         SETs(0); /* special alias marker that aassign recognises */
6904         XPUSHs(sv);
6905         RETURN;
6906     }
6907 }
6908
6909 PP(pp_anonconst)
6910 {
6911     dSP;
6912     dTOPss;
6913     SETs(sv_2mortal((SV *)newCONSTSUB(SvTYPE(CopSTASH(PL_curcop))==SVt_PVHV
6914                                         ? CopSTASH(PL_curcop)
6915                                         : NULL,
6916                                       NULL, SvREFCNT_inc_simple_NN(sv))));
6917     RETURN;
6918 }
6919
6920
6921 /* process one subroutine argument - typically when the sub has a signature:
6922  * introduce PL_curpad[op_targ] and assign to it the value
6923  *  for $:   (OPf_STACKED ? *sp : $_[N])
6924  *  for @/%: @_[N..$#_]
6925  *
6926  * It's equivalent to
6927  *    my $foo = $_[N];
6928  * or
6929  *    my $foo = (value-on-stack)
6930  * or
6931  *    my @foo = @_[N..$#_]
6932  * etc
6933  */
6934
6935 PP(pp_argelem)
6936 {
6937     dTARG;
6938     SV *val;
6939     SV ** padentry;
6940     OP *o = PL_op;
6941     AV *defav = GvAV(PL_defgv); /* @_ */
6942     IV ix = PTR2IV(cUNOP_AUXo->op_aux);
6943     IV argc;
6944
6945     /* do 'my $var, @var or %var' action */
6946     padentry = &(PAD_SVl(o->op_targ));
6947     save_clearsv(padentry);
6948     targ = *padentry;
6949
6950     if ((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_SV) {
6951         if (o->op_flags & OPf_STACKED) {
6952             dSP;
6953             val = POPs;
6954             PUTBACK;
6955         }
6956         else {
6957             SV **svp;
6958             /* should already have been checked */
6959             assert(ix >= 0);
6960 #if IVSIZE > PTRSIZE
6961             assert(ix <= SSize_t_MAX);
6962 #endif
6963
6964             svp = av_fetch(defav, ix, FALSE);
6965             val = svp ? *svp : &PL_sv_undef;
6966         }
6967
6968         /* $var = $val */
6969
6970         /* cargo-culted from pp_sassign */
6971         assert(TAINTING_get || !TAINT_get);
6972         if (UNLIKELY(TAINT_get) && !SvTAINTED(val))
6973             TAINT_NOT;
6974
6975         SvSetMagicSV(targ, val);
6976         return o->op_next;
6977     }
6978
6979     /* must be AV or HV */
6980
6981     assert(!(o->op_flags & OPf_STACKED));
6982     argc = ((IV)AvFILL(defav) + 1) - ix;
6983
6984     /* This is a copy of the relevant parts of pp_aassign().
6985      */
6986     if ((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_AV) {
6987         IV i;
6988
6989         if (AvFILL((AV*)targ) > -1) {
6990             /* target should usually be empty. If we get get
6991              * here, someone's been doing some weird closure tricks.
6992              * Make a copy of all args before clearing the array,
6993              * to avoid the equivalent of @a = ($a[0]) prematurely freeing
6994              * elements. See similar code in pp_aassign.
6995              */
6996             for (i = 0; i < argc; i++) {
6997                 SV **svp = av_fetch(defav, ix + i, FALSE);
6998                 SV *newsv = newSV(0);
6999                 sv_setsv_flags(newsv,
7000                                 svp ? *svp : &PL_sv_undef,
7001                                 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
7002                 if (!av_store(defav, ix + i, newsv))
7003                     SvREFCNT_dec_NN(newsv);
7004             }
7005             av_clear((AV*)targ);
7006         }
7007
7008         if (argc <= 0)
7009             return o->op_next;
7010
7011         av_extend((AV*)targ, argc);
7012
7013         i = 0;
7014         while (argc--) {
7015             SV *tmpsv;
7016             SV **svp = av_fetch(defav, ix + i, FALSE);
7017             SV *val = svp ? *svp : &PL_sv_undef;
7018             tmpsv = newSV(0);
7019             sv_setsv(tmpsv, val);
7020             av_store((AV*)targ, i++, tmpsv);
7021             TAINT_NOT;
7022         }
7023
7024     }
7025     else {
7026         IV i;
7027
7028         assert((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_HV);
7029
7030         if (SvRMAGICAL(targ) || HvUSEDKEYS((HV*)targ)) {
7031             /* see "target should usually be empty" comment above */
7032             for (i = 0; i < argc; i++) {
7033                 SV **svp = av_fetch(defav, ix + i, FALSE);
7034                 SV *newsv = newSV(0);
7035                 sv_setsv_flags(newsv,
7036                                 svp ? *svp : &PL_sv_undef,
7037                                 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
7038                 if (!av_store(defav, ix + i, newsv))
7039                     SvREFCNT_dec_NN(newsv);
7040             }
7041             hv_clear((HV*)targ);
7042         }
7043
7044         if (argc <= 0)
7045             return o->op_next;
7046         assert(argc % 2 == 0);
7047
7048         i = 0;
7049         while (argc) {
7050             SV *tmpsv;
7051             SV **svp;
7052             SV *key;
7053             SV *val;
7054
7055             svp = av_fetch(defav, ix + i++, FALSE);
7056             key = svp ? *svp : &PL_sv_undef;
7057             svp = av_fetch(defav, ix + i++, FALSE);
7058             val = svp ? *svp : &PL_sv_undef;
7059
7060             argc -= 2;
7061             if (UNLIKELY(SvGMAGICAL(key)))
7062                 key = sv_mortalcopy(key);
7063             tmpsv = newSV(0);
7064             sv_setsv(tmpsv, val);
7065             hv_store_ent((HV*)targ, key, tmpsv, 0);
7066             TAINT_NOT;
7067         }
7068     }
7069
7070     return o->op_next;
7071 }
7072
7073 /* Handle a default value for one subroutine argument (typically as part
7074  * of a subroutine signature).
7075  * It's equivalent to
7076  *    @_ > op_targ ? $_[op_targ] : result_of(op_other)
7077  *
7078  * Intended to be used where op_next is an OP_ARGELEM
7079  *
7080  * We abuse the op_targ field slightly: it's an index into @_ rather than
7081  * into PL_curpad.
7082  */
7083
7084 PP(pp_argdefelem)
7085 {
7086     OP * const o = PL_op;
7087     AV *defav = GvAV(PL_defgv); /* @_ */
7088     IV ix = (IV)o->op_targ;
7089
7090     assert(ix >= 0);
7091 #if IVSIZE > PTRSIZE
7092     assert(ix <= SSize_t_MAX);
7093 #endif
7094
7095     if (AvFILL(defav) >= ix) {
7096         dSP;
7097         SV **svp = av_fetch(defav, ix, FALSE);
7098         SV  *val = svp ? *svp : &PL_sv_undef;
7099         XPUSHs(val);
7100         RETURN;
7101     }
7102     return cLOGOPo->op_other;
7103 }
7104
7105
7106 static SV *
7107 S_find_runcv_name(void)
7108 {
7109     dTHX;
7110     CV *cv;
7111     GV *gv;
7112     SV *sv;
7113
7114     cv = find_runcv(0);
7115     if (!cv)
7116         return &PL_sv_no;
7117
7118     gv = CvGV(cv);
7119     if (!gv)
7120         return &PL_sv_no;
7121
7122     sv = sv_2mortal(newSV(0));
7123     gv_fullname4(sv, gv, NULL, TRUE);
7124     return sv;
7125 }
7126
7127 /* Check a sub's arguments - i.e. that it has the correct number of args
7128  * (and anything else we might think of in future). Typically used with
7129  * signatured subs.
7130  */
7131
7132 PP(pp_argcheck)
7133 {
7134     OP * const o       = PL_op;
7135     struct op_argcheck_aux *aux = (struct op_argcheck_aux *)cUNOP_AUXo->op_aux;
7136     UV   params        = aux->params;
7137     UV   opt_params    = aux->opt_params;
7138     char slurpy        = aux->slurpy;
7139     AV  *defav         = GvAV(PL_defgv); /* @_ */
7140     UV   argc;
7141     bool too_few;
7142
7143     assert(!SvMAGICAL(defav));
7144     argc = (UV)(AvFILLp(defav) + 1);
7145     too_few = (argc < (params - opt_params));
7146
7147     if (UNLIKELY(too_few || (!slurpy && argc > params)))
7148         /* diag_listed_as: Too few arguments for subroutine '%s' */
7149         /* diag_listed_as: Too many arguments for subroutine '%s' */
7150         Perl_croak_caller("Too %s arguments for subroutine '%" SVf "'",
7151                           too_few ? "few" : "many", S_find_runcv_name());
7152
7153     if (UNLIKELY(slurpy == '%' && argc > params && (argc - params) % 2))
7154         /* diag_listed_as: Odd name/value argument for subroutine '%s' */
7155         Perl_croak_caller("Odd name/value argument for subroutine '%" SVf "'",
7156                           S_find_runcv_name());
7157
7158     return NORMAL;
7159 }
7160
7161 PP(pp_isa)
7162 {
7163     dSP;
7164     SV *left, *right;
7165
7166     right = POPs;
7167     left  = TOPs;
7168
7169     SETs(boolSV(sv_isa_sv(left, right)));
7170     RETURN;
7171 }
7172
7173 PP(pp_cmpchain_and)
7174 {
7175     dSP;
7176     SV *result = POPs;
7177     PUTBACK;
7178     if (SvTRUE_NN(result)) {
7179         return cLOGOP->op_other;
7180     } else {
7181         TOPs = result;
7182         return NORMAL;
7183     }
7184 }
7185
7186 PP(pp_cmpchain_dup)
7187 {
7188     dSP;
7189     SV *right = TOPs;
7190     SV *left = TOPm1s;
7191     TOPm1s = right;
7192     TOPs = left;
7193     XPUSHs(right);
7194     RETURN;
7195 }
7196
7197 /*
7198  * ex: set ts=8 sts=4 sw=4 et:
7199  */