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 /* Taking the right operand of bitwise shift operators, returns an int
1977  * indicating the shift amount clipped to the range [-IV_BITS, +IV_BITS].
1978  */
1979 static int
1980 S_shift_amount(pTHX_ SV *const svr)
1981 {
1982     const IV iv = SvIV_nomg(svr);
1983
1984     /* Note that [INT_MIN, INT_MAX] cannot be used as the clipping bound;
1985      * INT_MIN will cause overflow in "shift = -shift;" in S_{iv,uv}_shift.
1986      */
1987     if (SvIsUV(svr))
1988         return SvUVX(svr) > IV_BITS ? IV_BITS : (int)SvUVX(svr);
1989     return iv < -IV_BITS ? -IV_BITS : iv > IV_BITS ? IV_BITS : (int)iv;
1990 }
1991
1992 static UV S_uv_shift(UV uv, int shift, bool left)
1993 {
1994    if (shift < 0) {
1995        shift = -shift;
1996        left = !left;
1997    }
1998    if (UNLIKELY(shift >= IV_BITS)) {
1999        return 0;
2000    }
2001    return left ? uv << shift : uv >> shift;
2002 }
2003
2004 static IV S_iv_shift(IV iv, int shift, bool left)
2005 {
2006     if (shift < 0) {
2007         shift = -shift;
2008         left = !left;
2009     }
2010
2011     if (UNLIKELY(shift >= IV_BITS)) {
2012         return iv < 0 && !left ? -1 : 0;
2013     }
2014
2015     /* For left shifts, perl 5 has chosen to treat the value as unsigned for
2016      * the purposes of shifting, then cast back to signed.  This is very
2017      * different from Raku:
2018      *
2019      * $ raku -e 'say -2 +< 5'
2020      * -64
2021      *
2022      * $ ./perl -le 'print -2 << 5'
2023      * 18446744073709551552
2024      * */
2025     if (left) {
2026         return (IV) (((UV) iv) << shift);
2027     }
2028
2029     /* Here is right shift */
2030     return iv >> shift;
2031 }
2032
2033 #define UV_LEFT_SHIFT(uv, shift) S_uv_shift(uv, shift, TRUE)
2034 #define UV_RIGHT_SHIFT(uv, shift) S_uv_shift(uv, shift, FALSE)
2035 #define IV_LEFT_SHIFT(iv, shift) S_iv_shift(iv, shift, TRUE)
2036 #define IV_RIGHT_SHIFT(iv, shift) S_iv_shift(iv, shift, FALSE)
2037
2038 PP(pp_left_shift)
2039 {
2040     dSP; dATARGET; SV *svl, *svr;
2041     tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
2042     svr = POPs;
2043     svl = TOPs;
2044     {
2045       const int shift = S_shift_amount(aTHX_ svr);
2046       if (PL_op->op_private & HINT_INTEGER) {
2047           SETi(IV_LEFT_SHIFT(SvIV_nomg(svl), shift));
2048       }
2049       else {
2050           SETu(UV_LEFT_SHIFT(SvUV_nomg(svl), shift));
2051       }
2052       RETURN;
2053     }
2054 }
2055
2056 PP(pp_right_shift)
2057 {
2058     dSP; dATARGET; SV *svl, *svr;
2059     tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
2060     svr = POPs;
2061     svl = TOPs;
2062     {
2063       const int shift = S_shift_amount(aTHX_ svr);
2064       if (PL_op->op_private & HINT_INTEGER) {
2065           SETi(IV_RIGHT_SHIFT(SvIV_nomg(svl), shift));
2066       }
2067       else {
2068           SETu(UV_RIGHT_SHIFT(SvUV_nomg(svl), shift));
2069       }
2070       RETURN;
2071     }
2072 }
2073
2074 PP(pp_lt)
2075 {
2076     dSP;
2077     SV *left, *right;
2078     U32 flags_and, flags_or;
2079
2080     tryAMAGICbin_MG(lt_amg, AMGf_numeric);
2081     right = POPs;
2082     left  = TOPs;
2083     flags_and = SvFLAGS(left) & SvFLAGS(right);
2084     flags_or  = SvFLAGS(left) | SvFLAGS(right);
2085
2086     SETs(boolSV(
2087         ( (flags_and & SVf_IOK) && ((flags_or & SVf_IVisUV) ==0 ) )
2088         ?    (SvIVX(left) < SvIVX(right))
2089         : (flags_and & SVf_NOK)
2090         ?    (SvNVX(left) < SvNVX(right))
2091         : (do_ncmp(left, right) == -1)
2092     ));
2093     RETURN;
2094 }
2095
2096 PP(pp_gt)
2097 {
2098     dSP;
2099     SV *left, *right;
2100     U32 flags_and, flags_or;
2101
2102     tryAMAGICbin_MG(gt_amg, AMGf_numeric);
2103     right = POPs;
2104     left  = TOPs;
2105     flags_and = SvFLAGS(left) & SvFLAGS(right);
2106     flags_or  = SvFLAGS(left) | SvFLAGS(right);
2107
2108     SETs(boolSV(
2109         ( (flags_and & SVf_IOK) && ((flags_or & SVf_IVisUV) ==0 ) )
2110         ?    (SvIVX(left) > SvIVX(right))
2111         : (flags_and & SVf_NOK)
2112         ?    (SvNVX(left) > SvNVX(right))
2113         : (do_ncmp(left, right) == 1)
2114     ));
2115     RETURN;
2116 }
2117
2118 PP(pp_le)
2119 {
2120     dSP;
2121     SV *left, *right;
2122     U32 flags_and, flags_or;
2123
2124     tryAMAGICbin_MG(le_amg, AMGf_numeric);
2125     right = POPs;
2126     left  = TOPs;
2127     flags_and = SvFLAGS(left) & SvFLAGS(right);
2128     flags_or  = SvFLAGS(left) | SvFLAGS(right);
2129
2130     SETs(boolSV(
2131         ( (flags_and & SVf_IOK) && ((flags_or & SVf_IVisUV) ==0 ) )
2132         ?    (SvIVX(left) <= SvIVX(right))
2133         : (flags_and & SVf_NOK)
2134         ?    (SvNVX(left) <= SvNVX(right))
2135         : (do_ncmp(left, right) <= 0)
2136     ));
2137     RETURN;
2138 }
2139
2140 PP(pp_ge)
2141 {
2142     dSP;
2143     SV *left, *right;
2144     U32 flags_and, flags_or;
2145
2146     tryAMAGICbin_MG(ge_amg, AMGf_numeric);
2147     right = POPs;
2148     left  = TOPs;
2149     flags_and = SvFLAGS(left) & SvFLAGS(right);
2150     flags_or  = SvFLAGS(left) | SvFLAGS(right);
2151
2152     SETs(boolSV(
2153         ( (flags_and & SVf_IOK) && ((flags_or & SVf_IVisUV) ==0 ) )
2154         ?    (SvIVX(left) >= SvIVX(right))
2155         : (flags_and & SVf_NOK)
2156         ?    (SvNVX(left) >= SvNVX(right))
2157         : ( (do_ncmp(left, right) & 2) == 0)
2158     ));
2159     RETURN;
2160 }
2161
2162 PP(pp_ne)
2163 {
2164     dSP;
2165     SV *left, *right;
2166     U32 flags_and, flags_or;
2167
2168     tryAMAGICbin_MG(ne_amg, AMGf_numeric);
2169     right = POPs;
2170     left  = TOPs;
2171     flags_and = SvFLAGS(left) & SvFLAGS(right);
2172     flags_or  = SvFLAGS(left) | SvFLAGS(right);
2173
2174     SETs(boolSV(
2175         ( (flags_and & SVf_IOK) && ((flags_or & SVf_IVisUV) ==0 ) )
2176         ?    (SvIVX(left) != SvIVX(right))
2177         : (flags_and & SVf_NOK)
2178         ?    (SvNVX(left) != SvNVX(right))
2179         : (do_ncmp(left, right) != 0)
2180     ));
2181     RETURN;
2182 }
2183
2184 /* compare left and right SVs. Returns:
2185  * -1: <
2186  *  0: ==
2187  *  1: >
2188  *  2: left or right was a NaN
2189  */
2190 I32
2191 Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
2192 {
2193     PERL_ARGS_ASSERT_DO_NCMP;
2194 #ifdef PERL_PRESERVE_IVUV
2195     /* Fortunately it seems NaN isn't IOK */
2196     if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
2197             if (!SvUOK(left)) {
2198                 const IV leftiv = SvIVX(left);
2199                 if (!SvUOK(right)) {
2200                     /* ## IV <=> IV ## */
2201                     const IV rightiv = SvIVX(right);
2202                     return (leftiv > rightiv) - (leftiv < rightiv);
2203                 }
2204                 /* ## IV <=> UV ## */
2205                 if (leftiv < 0)
2206                     /* As (b) is a UV, it's >=0, so it must be < */
2207                     return -1;
2208                 {
2209                     const UV rightuv = SvUVX(right);
2210                     return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
2211                 }
2212             }
2213
2214             if (SvUOK(right)) {
2215                 /* ## UV <=> UV ## */
2216                 const UV leftuv = SvUVX(left);
2217                 const UV rightuv = SvUVX(right);
2218                 return (leftuv > rightuv) - (leftuv < rightuv);
2219             }
2220             /* ## UV <=> IV ## */
2221             {
2222                 const IV rightiv = SvIVX(right);
2223                 if (rightiv < 0)
2224                     /* As (a) is a UV, it's >=0, so it cannot be < */
2225                     return 1;
2226                 {
2227                     const UV leftuv = SvUVX(left);
2228                     return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
2229                 }
2230             }
2231             NOT_REACHED; /* NOTREACHED */
2232     }
2233 #endif
2234     {
2235       NV const rnv = SvNV_nomg(right);
2236       NV const lnv = SvNV_nomg(left);
2237
2238 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2239       if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2240           return 2;
2241        }
2242       return (lnv > rnv) - (lnv < rnv);
2243 #else
2244       if (lnv < rnv)
2245         return -1;
2246       if (lnv > rnv)
2247         return 1;
2248       if (lnv == rnv)
2249         return 0;
2250       return 2;
2251 #endif
2252     }
2253 }
2254
2255
2256 PP(pp_ncmp)
2257 {
2258     dSP;
2259     SV *left, *right;
2260     I32 value;
2261     tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
2262     right = POPs;
2263     left  = TOPs;
2264     value = do_ncmp(left, right);
2265     if (value == 2) {
2266         SETs(&PL_sv_undef);
2267     }
2268     else {
2269         dTARGET;
2270         SETi(value);
2271     }
2272     RETURN;
2273 }
2274
2275
2276 /* also used for: pp_sge() pp_sgt() pp_slt() */
2277
2278 PP(pp_sle)
2279 {
2280     dSP;
2281
2282     int amg_type = sle_amg;
2283     int multiplier = 1;
2284     int rhs = 1;
2285
2286     switch (PL_op->op_type) {
2287     case OP_SLT:
2288         amg_type = slt_amg;
2289         /* cmp < 0 */
2290         rhs = 0;
2291         break;
2292     case OP_SGT:
2293         amg_type = sgt_amg;
2294         /* cmp > 0 */
2295         multiplier = -1;
2296         rhs = 0;
2297         break;
2298     case OP_SGE:
2299         amg_type = sge_amg;
2300         /* cmp >= 0 */
2301         multiplier = -1;
2302         break;
2303     }
2304
2305     tryAMAGICbin_MG(amg_type, 0);
2306     {
2307       dPOPTOPssrl;
2308       const int cmp =
2309 #ifdef USE_LOCALE_COLLATE
2310                       (IN_LC_RUNTIME(LC_COLLATE))
2311                       ? sv_cmp_locale_flags(left, right, 0)
2312                       :
2313 #endif
2314                         sv_cmp_flags(left, right, 0);
2315       SETs(boolSV(cmp * multiplier < rhs));
2316       RETURN;
2317     }
2318 }
2319
2320 PP(pp_seq)
2321 {
2322     dSP;
2323     tryAMAGICbin_MG(seq_amg, 0);
2324     {
2325       dPOPTOPssrl;
2326       SETs(boolSV(sv_eq_flags(left, right, 0)));
2327       RETURN;
2328     }
2329 }
2330
2331 PP(pp_sne)
2332 {
2333     dSP;
2334     tryAMAGICbin_MG(sne_amg, 0);
2335     {
2336       dPOPTOPssrl;
2337       SETs(boolSV(!sv_eq_flags(left, right, 0)));
2338       RETURN;
2339     }
2340 }
2341
2342 PP(pp_scmp)
2343 {
2344     dSP; dTARGET;
2345     tryAMAGICbin_MG(scmp_amg, 0);
2346     {
2347       dPOPTOPssrl;
2348       const int cmp =
2349 #ifdef USE_LOCALE_COLLATE
2350                       (IN_LC_RUNTIME(LC_COLLATE))
2351                       ? sv_cmp_locale_flags(left, right, 0)
2352                       :
2353 #endif
2354                         sv_cmp_flags(left, right, 0);
2355       SETi( cmp );
2356       RETURN;
2357     }
2358 }
2359
2360 PP(pp_bit_and)
2361 {
2362     dSP; dATARGET;
2363     tryAMAGICbin_MG(band_amg, AMGf_assign);
2364     {
2365       dPOPTOPssrl;
2366       if (SvNIOKp(left) || SvNIOKp(right)) {
2367         const bool left_ro_nonnum  = !SvNIOKp(left) && SvREADONLY(left);
2368         const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2369         if (PL_op->op_private & HINT_INTEGER) {
2370           const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2371           SETi(i);
2372         }
2373         else {
2374           const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2375           SETu(u);
2376         }
2377         if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2378         if (right_ro_nonnum) SvNIOK_off(right);
2379       }
2380       else {
2381         do_vop(PL_op->op_type, TARG, left, right);
2382         SETTARG;
2383       }
2384       RETURN;
2385     }
2386 }
2387
2388 PP(pp_nbit_and)
2389 {
2390     dSP;
2391     tryAMAGICbin_MG(band_amg, AMGf_assign|AMGf_numarg);
2392     {
2393         dATARGET; dPOPTOPssrl;
2394         if (PL_op->op_private & HINT_INTEGER) {
2395           const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2396           SETi(i);
2397         }
2398         else {
2399           const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2400           SETu(u);
2401         }
2402     }
2403     RETURN;
2404 }
2405
2406 PP(pp_sbit_and)
2407 {
2408     dSP;
2409     tryAMAGICbin_MG(sband_amg, AMGf_assign);
2410     {
2411         dATARGET; dPOPTOPssrl;
2412         do_vop(OP_BIT_AND, TARG, left, right);
2413         RETSETTARG;
2414     }
2415 }
2416
2417 /* also used for: pp_bit_xor() */
2418
2419 PP(pp_bit_or)
2420 {
2421     dSP; dATARGET;
2422     const int op_type = PL_op->op_type;
2423
2424     tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2425     {
2426       dPOPTOPssrl;
2427       if (SvNIOKp(left) || SvNIOKp(right)) {
2428         const bool left_ro_nonnum  = !SvNIOKp(left) && SvREADONLY(left);
2429         const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2430         if (PL_op->op_private & HINT_INTEGER) {
2431           const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2432           const IV r = SvIV_nomg(right);
2433           const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2434           SETi(result);
2435         }
2436         else {
2437           const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2438           const UV r = SvUV_nomg(right);
2439           const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2440           SETu(result);
2441         }
2442         if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2443         if (right_ro_nonnum) SvNIOK_off(right);
2444       }
2445       else {
2446         do_vop(op_type, TARG, left, right);
2447         SETTARG;
2448       }
2449       RETURN;
2450     }
2451 }
2452
2453 /* also used for: pp_nbit_xor() */
2454
2455 PP(pp_nbit_or)
2456 {
2457     dSP;
2458     const int op_type = PL_op->op_type;
2459
2460     tryAMAGICbin_MG((op_type == OP_NBIT_OR ? bor_amg : bxor_amg),
2461                     AMGf_assign|AMGf_numarg);
2462     {
2463         dATARGET; dPOPTOPssrl;
2464         if (PL_op->op_private & HINT_INTEGER) {
2465           const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2466           const IV r = SvIV_nomg(right);
2467           const IV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2468           SETi(result);
2469         }
2470         else {
2471           const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2472           const UV r = SvUV_nomg(right);
2473           const UV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2474           SETu(result);
2475         }
2476     }
2477     RETURN;
2478 }
2479
2480 /* also used for: pp_sbit_xor() */
2481
2482 PP(pp_sbit_or)
2483 {
2484     dSP;
2485     const int op_type = PL_op->op_type;
2486
2487     tryAMAGICbin_MG((op_type == OP_SBIT_OR ? sbor_amg : sbxor_amg),
2488                     AMGf_assign);
2489     {
2490         dATARGET; dPOPTOPssrl;
2491         do_vop(op_type == OP_SBIT_OR ? OP_BIT_OR : OP_BIT_XOR, TARG, left,
2492                right);
2493         RETSETTARG;
2494     }
2495 }
2496
2497 PERL_STATIC_INLINE bool
2498 S_negate_string(pTHX)
2499 {
2500     dTARGET; dSP;
2501     STRLEN len;
2502     const char *s;
2503     SV * const sv = TOPs;
2504     if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2505         return FALSE;
2506     s = SvPV_nomg_const(sv, len);
2507     if (isIDFIRST(*s)) {
2508         sv_setpvs(TARG, "-");
2509         sv_catsv(TARG, sv);
2510     }
2511     else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2512         sv_setsv_nomg(TARG, sv);
2513         *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2514     }
2515     else return FALSE;
2516     SETTARG;
2517     return TRUE;
2518 }
2519
2520 PP(pp_negate)
2521 {
2522     dSP; dTARGET;
2523     tryAMAGICun_MG(neg_amg, AMGf_numeric);
2524     if (S_negate_string(aTHX)) return NORMAL;
2525     {
2526         SV * const sv = TOPs;
2527
2528         if (SvIOK(sv)) {
2529             /* It's publicly an integer */
2530         oops_its_an_int:
2531             if (SvIsUV(sv)) {
2532                 if (SvIVX(sv) == IV_MIN) {
2533                     /* 2s complement assumption. */
2534                     SETi(SvIVX(sv));    /* special case: -((UV)IV_MAX+1) ==
2535                                            IV_MIN */
2536                     return NORMAL;
2537                 }
2538                 else if (SvUVX(sv) <= IV_MAX) {
2539                     SETi(-SvIVX(sv));
2540                     return NORMAL;
2541                 }
2542             }
2543             else if (SvIVX(sv) != IV_MIN) {
2544                 SETi(-SvIVX(sv));
2545                 return NORMAL;
2546             }
2547 #ifdef PERL_PRESERVE_IVUV
2548             else {
2549                 SETu((UV)IV_MIN);
2550                 return NORMAL;
2551             }
2552 #endif
2553         }
2554         if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
2555             SETn(-SvNV_nomg(sv));
2556         else if (SvPOKp(sv) && SvIV_please_nomg(sv))
2557                   goto oops_its_an_int;
2558         else
2559             SETn(-SvNV_nomg(sv));
2560     }
2561     return NORMAL;
2562 }
2563
2564 PP(pp_not)
2565 {
2566     dSP;
2567     SV *sv;
2568
2569     tryAMAGICun_MG(not_amg, 0);
2570     sv = *PL_stack_sp;
2571     *PL_stack_sp = boolSV(!SvTRUE_nomg_NN(sv));
2572     return NORMAL;
2573 }
2574
2575 static void
2576 S_scomplement(pTHX_ SV *targ, SV *sv)
2577 {
2578         U8 *tmps;
2579         I32 anum;
2580         STRLEN len;
2581
2582         sv_copypv_nomg(TARG, sv);
2583         tmps = (U8*)SvPV_nomg(TARG, len);
2584
2585         if (SvUTF8(TARG)) {
2586             if (len && ! utf8_to_bytes(tmps, &len)) {
2587                 Perl_croak(aTHX_ FATAL_ABOVE_FF_MSG, PL_op_desc[PL_op->op_type]);
2588             }
2589             SvCUR_set(TARG, len);
2590             SvUTF8_off(TARG);
2591         }
2592
2593         anum = len;
2594
2595         {
2596             long *tmpl;
2597             for ( ; anum && PTR2nat(tmps) % sizeof(long); anum--, tmps++)
2598                 *tmps = ~*tmps;
2599             tmpl = (long*)tmps;
2600             for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2601                 *tmpl = ~*tmpl;
2602             tmps = (U8*)tmpl;
2603         }
2604
2605         for ( ; anum > 0; anum--, tmps++)
2606             *tmps = ~*tmps;
2607 }
2608
2609 PP(pp_complement)
2610 {
2611     dSP; dTARGET;
2612     tryAMAGICun_MG(compl_amg, AMGf_numeric);
2613     {
2614       dTOPss;
2615       if (SvNIOKp(sv)) {
2616         if (PL_op->op_private & HINT_INTEGER) {
2617           const IV i = ~SvIV_nomg(sv);
2618           SETi(i);
2619         }
2620         else {
2621           const UV u = ~SvUV_nomg(sv);
2622           SETu(u);
2623         }
2624       }
2625       else {
2626         S_scomplement(aTHX_ TARG, sv);
2627         SETTARG;
2628       }
2629       return NORMAL;
2630     }
2631 }
2632
2633 PP(pp_ncomplement)
2634 {
2635     dSP;
2636     tryAMAGICun_MG(compl_amg, AMGf_numeric|AMGf_numarg);
2637     {
2638         dTARGET; dTOPss;
2639         if (PL_op->op_private & HINT_INTEGER) {
2640           const IV i = ~SvIV_nomg(sv);
2641           SETi(i);
2642         }
2643         else {
2644           const UV u = ~SvUV_nomg(sv);
2645           SETu(u);
2646         }
2647     }
2648     return NORMAL;
2649 }
2650
2651 PP(pp_scomplement)
2652 {
2653     dSP;
2654     tryAMAGICun_MG(scompl_amg, AMGf_numeric);
2655     {
2656         dTARGET; dTOPss;
2657         S_scomplement(aTHX_ TARG, sv);
2658         SETTARG;
2659         return NORMAL;
2660     }
2661 }
2662
2663 /* integer versions of some of the above */
2664
2665 PP(pp_i_multiply)
2666 {
2667     dSP; dATARGET;
2668     tryAMAGICbin_MG(mult_amg, AMGf_assign);
2669     {
2670       dPOPTOPiirl_nomg;
2671       SETi( left * right );
2672       RETURN;
2673     }
2674 }
2675
2676 PP(pp_i_divide)
2677 {
2678     IV num;
2679     dSP; dATARGET;
2680     tryAMAGICbin_MG(div_amg, AMGf_assign);
2681     {
2682       dPOPTOPssrl;
2683       IV value = SvIV_nomg(right);
2684       if (value == 0)
2685           DIE(aTHX_ "Illegal division by zero");
2686       num = SvIV_nomg(left);
2687
2688       /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2689       if (value == -1)
2690           value = - num;
2691       else
2692           value = num / value;
2693       SETi(value);
2694       RETURN;
2695     }
2696 }
2697
2698 PP(pp_i_modulo)
2699 {
2700      dSP; dATARGET;
2701      tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2702      {
2703           dPOPTOPiirl_nomg;
2704           if (!right)
2705                DIE(aTHX_ "Illegal modulus zero");
2706           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2707           if (right == -1)
2708               SETi( 0 );
2709           else
2710               SETi( left % right );
2711           RETURN;
2712      }
2713 }
2714
2715 PP(pp_i_add)
2716 {
2717     dSP; dATARGET;
2718     tryAMAGICbin_MG(add_amg, AMGf_assign);
2719     {
2720       dPOPTOPiirl_ul_nomg;
2721       SETi( left + right );
2722       RETURN;
2723     }
2724 }
2725
2726 PP(pp_i_subtract)
2727 {
2728     dSP; dATARGET;
2729     tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2730     {
2731       dPOPTOPiirl_ul_nomg;
2732       SETi( left - right );
2733       RETURN;
2734     }
2735 }
2736
2737 PP(pp_i_lt)
2738 {
2739     dSP;
2740     tryAMAGICbin_MG(lt_amg, 0);
2741     {
2742       dPOPTOPiirl_nomg;
2743       SETs(boolSV(left < right));
2744       RETURN;
2745     }
2746 }
2747
2748 PP(pp_i_gt)
2749 {
2750     dSP;
2751     tryAMAGICbin_MG(gt_amg, 0);
2752     {
2753       dPOPTOPiirl_nomg;
2754       SETs(boolSV(left > right));
2755       RETURN;
2756     }
2757 }
2758
2759 PP(pp_i_le)
2760 {
2761     dSP;
2762     tryAMAGICbin_MG(le_amg, 0);
2763     {
2764       dPOPTOPiirl_nomg;
2765       SETs(boolSV(left <= right));
2766       RETURN;
2767     }
2768 }
2769
2770 PP(pp_i_ge)
2771 {
2772     dSP;
2773     tryAMAGICbin_MG(ge_amg, 0);
2774     {
2775       dPOPTOPiirl_nomg;
2776       SETs(boolSV(left >= right));
2777       RETURN;
2778     }
2779 }
2780
2781 PP(pp_i_eq)
2782 {
2783     dSP;
2784     tryAMAGICbin_MG(eq_amg, 0);
2785     {
2786       dPOPTOPiirl_nomg;
2787       SETs(boolSV(left == right));
2788       RETURN;
2789     }
2790 }
2791
2792 PP(pp_i_ne)
2793 {
2794     dSP;
2795     tryAMAGICbin_MG(ne_amg, 0);
2796     {
2797       dPOPTOPiirl_nomg;
2798       SETs(boolSV(left != right));
2799       RETURN;
2800     }
2801 }
2802
2803 PP(pp_i_ncmp)
2804 {
2805     dSP; dTARGET;
2806     tryAMAGICbin_MG(ncmp_amg, 0);
2807     {
2808       dPOPTOPiirl_nomg;
2809       I32 value;
2810
2811       if (left > right)
2812         value = 1;
2813       else if (left < right)
2814         value = -1;
2815       else
2816         value = 0;
2817       SETi(value);
2818       RETURN;
2819     }
2820 }
2821
2822 PP(pp_i_negate)
2823 {
2824     dSP; dTARGET;
2825     tryAMAGICun_MG(neg_amg, 0);
2826     if (S_negate_string(aTHX)) return NORMAL;
2827     {
2828         SV * const sv = TOPs;
2829         IV const i = SvIV_nomg(sv);
2830         SETi(-i);
2831         return NORMAL;
2832     }
2833 }
2834
2835 /* High falutin' math. */
2836
2837 PP(pp_atan2)
2838 {
2839     dSP; dTARGET;
2840     tryAMAGICbin_MG(atan2_amg, 0);
2841     {
2842       dPOPTOPnnrl_nomg;
2843       SETn(Perl_atan2(left, right));
2844       RETURN;
2845     }
2846 }
2847
2848
2849 /* also used for: pp_cos() pp_exp() pp_log() pp_sqrt() */
2850
2851 PP(pp_sin)
2852 {
2853     dSP; dTARGET;
2854     int amg_type = fallback_amg;
2855     const char *neg_report = NULL;
2856     const int op_type = PL_op->op_type;
2857
2858     switch (op_type) {
2859     case OP_SIN:  amg_type = sin_amg; break;
2860     case OP_COS:  amg_type = cos_amg; break;
2861     case OP_EXP:  amg_type = exp_amg; break;
2862     case OP_LOG:  amg_type = log_amg;  neg_report = "log";  break;
2863     case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break;
2864     }
2865
2866     assert(amg_type != fallback_amg);
2867
2868     tryAMAGICun_MG(amg_type, 0);
2869     {
2870       SV * const arg = TOPs;
2871       const NV value = SvNV_nomg(arg);
2872 #ifdef NV_NAN
2873       NV result = NV_NAN;
2874 #else
2875       NV result = 0.0;
2876 #endif
2877       if (neg_report) { /* log or sqrt */
2878           if (
2879 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2880               ! Perl_isnan(value) &&
2881 #endif
2882               (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0))) {
2883               SET_NUMERIC_STANDARD();
2884               /* diag_listed_as: Can't take log of %g */
2885               DIE(aTHX_ "Can't take %s of %" NVgf, neg_report, value);
2886           }
2887       }
2888       switch (op_type) {
2889       default:
2890       case OP_SIN:  result = Perl_sin(value);  break;
2891       case OP_COS:  result = Perl_cos(value);  break;
2892       case OP_EXP:  result = Perl_exp(value);  break;
2893       case OP_LOG:  result = Perl_log(value);  break;
2894       case OP_SQRT: result = Perl_sqrt(value); break;
2895       }
2896       SETn(result);
2897       return NORMAL;
2898     }
2899 }
2900
2901 /* Support Configure command-line overrides for rand() functions.
2902    After 5.005, perhaps we should replace this by Configure support
2903    for drand48(), random(), or rand().  For 5.005, though, maintain
2904    compatibility by calling rand() but allow the user to override it.
2905    See INSTALL for details.  --Andy Dougherty  15 July 1998
2906 */
2907 /* Now it's after 5.005, and Configure supports drand48() and random(),
2908    in addition to rand().  So the overrides should not be needed any more.
2909    --Jarkko Hietaniemi  27 September 1998
2910  */
2911
2912 PP(pp_rand)
2913 {
2914     if (!PL_srand_called) {
2915         (void)seedDrand01((Rand_seed_t)seed());
2916         PL_srand_called = TRUE;
2917     }
2918     {
2919         dSP;
2920         NV value;
2921
2922         if (MAXARG < 1)
2923         {
2924             EXTEND(SP, 1);
2925             value = 1.0;
2926         }
2927         else {
2928             SV * const sv = POPs;
2929             if(!sv)
2930                 value = 1.0;
2931             else
2932                 value = SvNV(sv);
2933         }
2934     /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
2935 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2936         if (! Perl_isnan(value) && value == 0.0)
2937 #else
2938         if (value == 0.0)
2939 #endif
2940             value = 1.0;
2941         {
2942             dTARGET;
2943             PUSHs(TARG);
2944             PUTBACK;
2945             value *= Drand01();
2946             sv_setnv_mg(TARG, value);
2947         }
2948     }
2949     return NORMAL;
2950 }
2951
2952 PP(pp_srand)
2953 {
2954     dSP; dTARGET;
2955     UV anum;
2956
2957     if (MAXARG >= 1 && (TOPs || POPs)) {
2958         SV *top;
2959         char *pv;
2960         STRLEN len;
2961         int flags;
2962
2963         top = POPs;
2964         pv = SvPV(top, len);
2965         flags = grok_number(pv, len, &anum);
2966
2967         if (!(flags & IS_NUMBER_IN_UV)) {
2968             Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
2969                              "Integer overflow in srand");
2970             anum = UV_MAX;
2971         }
2972     }
2973     else {
2974         anum = seed();
2975     }
2976
2977     (void)seedDrand01((Rand_seed_t)anum);
2978     PL_srand_called = TRUE;
2979     if (anum)
2980         XPUSHu(anum);
2981     else {
2982         /* Historically srand always returned true. We can avoid breaking
2983            that like this:  */
2984         sv_setpvs(TARG, "0 but true");
2985         XPUSHTARG;
2986     }
2987     RETURN;
2988 }
2989
2990 PP(pp_int)
2991 {
2992     dSP; dTARGET;
2993     tryAMAGICun_MG(int_amg, AMGf_numeric);
2994     {
2995       SV * const sv = TOPs;
2996       const IV iv = SvIV_nomg(sv);
2997       /* XXX it's arguable that compiler casting to IV might be subtly
2998          different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2999          else preferring IV has introduced a subtle behaviour change bug. OTOH
3000          relying on floating point to be accurate is a bug.  */
3001
3002       if (!SvOK(sv)) {
3003         SETu(0);
3004       }
3005       else if (SvIOK(sv)) {
3006         if (SvIsUV(sv))
3007             SETu(SvUV_nomg(sv));
3008         else
3009             SETi(iv);
3010       }
3011       else {
3012           const NV value = SvNV_nomg(sv);
3013           if (UNLIKELY(Perl_isinfnan(value)))
3014               SETn(value);
3015           else if (value >= 0.0) {
3016               if (value < (NV)UV_MAX + 0.5) {
3017                   SETu(U_V(value));
3018               } else {
3019                   SETn(Perl_floor(value));
3020               }
3021           }
3022           else {
3023               if (value > (NV)IV_MIN - 0.5) {
3024                   SETi(I_V(value));
3025               } else {
3026                   SETn(Perl_ceil(value));
3027               }
3028           }
3029       }
3030     }
3031     return NORMAL;
3032 }
3033
3034 PP(pp_abs)
3035 {
3036     dSP; dTARGET;
3037     tryAMAGICun_MG(abs_amg, AMGf_numeric);
3038     {
3039       SV * const sv = TOPs;
3040       /* This will cache the NV value if string isn't actually integer  */
3041       const IV iv = SvIV_nomg(sv);
3042
3043       if (!SvOK(sv)) {
3044         SETu(0);
3045       }
3046       else if (SvIOK(sv)) {
3047         /* IVX is precise  */
3048         if (SvIsUV(sv)) {
3049           SETu(SvUV_nomg(sv));  /* force it to be numeric only */
3050         } else {
3051           if (iv >= 0) {
3052             SETi(iv);
3053           } else {
3054             if (iv != IV_MIN) {
3055               SETi(-iv);
3056             } else {
3057               /* 2s complement assumption. Also, not really needed as
3058                  IV_MIN and -IV_MIN should both be %100...00 and NV-able  */
3059               SETu((UV)IV_MIN);
3060             }
3061           }
3062         }
3063       } else{
3064         const NV value = SvNV_nomg(sv);
3065         if (value < 0.0)
3066           SETn(-value);
3067         else
3068           SETn(value);
3069       }
3070     }
3071     return NORMAL;
3072 }
3073
3074
3075 /* also used for: pp_hex() */
3076
3077 PP(pp_oct)
3078 {
3079     dSP; dTARGET;
3080     const char *tmps;
3081     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
3082     STRLEN len;
3083     NV result_nv;
3084     UV result_uv;
3085     SV* const sv = TOPs;
3086
3087     tmps = (SvPV_const(sv, len));
3088     if (DO_UTF8(sv)) {
3089          /* If Unicode, try to downgrade
3090           * If not possible, croak. */
3091          SV* const tsv = sv_2mortal(newSVsv(sv));
3092
3093          SvUTF8_on(tsv);
3094          sv_utf8_downgrade(tsv, FALSE);
3095          tmps = SvPV_const(tsv, len);
3096     }
3097     if (PL_op->op_type == OP_HEX)
3098         goto hex;
3099
3100     while (*tmps && len && isSPACE(*tmps))
3101         tmps++, len--;
3102     if (*tmps == '0')
3103         tmps++, len--;
3104     if (isALPHA_FOLD_EQ(*tmps, 'x')) {
3105         tmps++, len--;
3106         flags |= PERL_SCAN_DISALLOW_PREFIX;
3107     hex:
3108         result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3109     }
3110     else if (isALPHA_FOLD_EQ(*tmps, 'b')) {
3111         tmps++, len--;
3112         flags |= PERL_SCAN_DISALLOW_PREFIX;
3113         result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3114     }
3115     else {
3116         if (isALPHA_FOLD_EQ(*tmps, 'o')) {
3117             tmps++, len--;
3118         }
3119         result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3120     }
3121
3122     if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3123         SETn(result_nv);
3124     }
3125     else {
3126         SETu(result_uv);
3127     }
3128     return NORMAL;
3129 }
3130
3131 /* String stuff. */
3132
3133
3134 PP(pp_length)
3135 {
3136     dSP; dTARGET;
3137     SV * const sv = TOPs;
3138
3139     U32 in_bytes = IN_BYTES;
3140     /* Simplest case shortcut:
3141      * set svflags to just the SVf_POK|SVs_GMG|SVf_UTF8 from the SV,
3142      * with the SVf_UTF8 flag inverted if under 'use bytes' (HINT_BYTES
3143      * set)
3144      */
3145     U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8);
3146
3147     STATIC_ASSERT_STMT(SVf_UTF8 == (HINT_BYTES << 26));
3148     SETs(TARG);
3149
3150     if (LIKELY(svflags == SVf_POK))
3151         goto simple_pv;
3152
3153     if (svflags & SVs_GMG)
3154         mg_get(sv);
3155
3156     if (SvOK(sv)) {
3157         STRLEN len;
3158         if (!IN_BYTES) { /* reread to avoid using an C auto/register */
3159             if ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == SVf_POK)
3160                 goto simple_pv;
3161             if ( SvPOK(sv) && (PL_op->op_private & OPpTRUEBOOL)) {
3162                 /* no need to convert from bytes to chars */
3163                 len = SvCUR(sv);
3164                 goto return_bool;
3165             }
3166             len = sv_len_utf8_nomg(sv);
3167         }
3168         else {
3169             /* unrolled SvPV_nomg_const(sv,len) */
3170             if (SvPOK_nog(sv)) {
3171               simple_pv:
3172                 len = SvCUR(sv);
3173                 if (PL_op->op_private & OPpTRUEBOOL) {
3174                   return_bool:
3175                     SETs(len ? &PL_sv_yes : &PL_sv_zero);
3176                     return NORMAL;
3177                 }
3178             }
3179             else {
3180                 (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN);
3181             }
3182         }
3183         TARGi((IV)(len), 1);
3184     }
3185     else {
3186         if (!SvPADTMP(TARG)) {
3187             /* OPpTARGET_MY: targ is var in '$lex = length()' */
3188             sv_set_undef(TARG);
3189             SvSETMAGIC(TARG);
3190         }
3191         else
3192             /* TARG is on stack at this point and is overwriten by SETs.
3193              * This branch is the odd one out, so put TARG by default on
3194              * stack earlier to let local SP go out of liveness sooner */
3195             SETs(&PL_sv_undef);
3196     }
3197     return NORMAL; /* no putback, SP didn't move in this opcode */
3198 }
3199
3200
3201 /* Returns false if substring is completely outside original string.
3202    No length is indicated by len_iv = 0 and len_is_uv = 0.  len_is_uv must
3203    always be true for an explicit 0.
3204 */
3205 bool
3206 Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv,
3207                                 bool pos1_is_uv, IV len_iv,
3208                                 bool len_is_uv, STRLEN *posp,
3209                                 STRLEN *lenp)
3210 {
3211     IV pos2_iv;
3212     int    pos2_is_uv;
3213
3214     PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
3215
3216     if (!pos1_is_uv && pos1_iv < 0 && curlen) {
3217         pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3218         pos1_iv += curlen;
3219     }
3220     if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
3221         return FALSE;
3222
3223     if (len_iv || len_is_uv) {
3224         if (!len_is_uv && len_iv < 0) {
3225             pos2_iv = curlen + len_iv;
3226             if (curlen)
3227                 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3228             else
3229                 pos2_is_uv = 0;
3230         } else {  /* len_iv >= 0 */
3231             if (!pos1_is_uv && pos1_iv < 0) {
3232                 pos2_iv = pos1_iv + len_iv;
3233                 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3234             } else {
3235                 if ((UV)len_iv > curlen-(UV)pos1_iv)
3236                     pos2_iv = curlen;
3237                 else
3238                     pos2_iv = pos1_iv+len_iv;
3239                 pos2_is_uv = 1;
3240             }
3241         }
3242     }
3243     else {
3244         pos2_iv = curlen;
3245         pos2_is_uv = 1;
3246     }
3247
3248     if (!pos2_is_uv && pos2_iv < 0) {
3249         if (!pos1_is_uv && pos1_iv < 0)
3250             return FALSE;
3251         pos2_iv = 0;
3252     }
3253     else if (!pos1_is_uv && pos1_iv < 0)
3254         pos1_iv = 0;
3255
3256     if ((UV)pos2_iv < (UV)pos1_iv)
3257         pos2_iv = pos1_iv;
3258     if ((UV)pos2_iv > curlen)
3259         pos2_iv = curlen;
3260
3261     /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3262     *posp = (STRLEN)( (UV)pos1_iv );
3263     *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3264
3265     return TRUE;
3266 }
3267
3268 PP(pp_substr)
3269 {
3270     dSP; dTARGET;
3271     SV *sv;
3272     STRLEN curlen;
3273     STRLEN utf8_curlen;
3274     SV *   pos_sv;
3275     IV     pos1_iv;
3276     int    pos1_is_uv;
3277     SV *   len_sv;
3278     IV     len_iv = 0;
3279     int    len_is_uv = 0;
3280     I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3281     const bool rvalue = (GIMME_V != G_VOID);
3282     const char *tmps;
3283     SV *repl_sv = NULL;
3284     const char *repl = NULL;
3285     STRLEN repl_len;
3286     int num_args = PL_op->op_private & 7;
3287     bool repl_need_utf8_upgrade = FALSE;
3288
3289     if (num_args > 2) {
3290         if (num_args > 3) {
3291           if(!(repl_sv = POPs)) num_args--;
3292         }
3293         if ((len_sv = POPs)) {
3294             len_iv    = SvIV(len_sv);
3295             len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
3296         }
3297         else num_args--;
3298     }
3299     pos_sv     = POPs;
3300     pos1_iv    = SvIV(pos_sv);
3301     pos1_is_uv = SvIOK_UV(pos_sv);
3302     sv = POPs;
3303     if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3304         assert(!repl_sv);
3305         repl_sv = POPs;
3306     }
3307     if (lvalue && !repl_sv) {
3308         SV * ret;
3309         ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
3310         sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3311         LvTYPE(ret) = 'x';
3312         LvTARG(ret) = SvREFCNT_inc_simple(sv);
3313         LvTARGOFF(ret) =
3314             pos1_is_uv || pos1_iv >= 0
3315                 ? (STRLEN)(UV)pos1_iv
3316                 : (LvFLAGS(ret) |= LVf_NEG_OFF, (STRLEN)(UV)-pos1_iv);
3317         LvTARGLEN(ret) =
3318             len_is_uv || len_iv > 0
3319                 ? (STRLEN)(UV)len_iv
3320                 : (LvFLAGS(ret) |= LVf_NEG_LEN, (STRLEN)(UV)-len_iv);
3321
3322         PUSHs(ret);    /* avoid SvSETMAGIC here */
3323         RETURN;
3324     }
3325     if (repl_sv) {
3326         repl = SvPV_const(repl_sv, repl_len);
3327         SvGETMAGIC(sv);
3328         if (SvROK(sv))
3329             Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3330                             "Attempt to use reference as lvalue in substr"
3331             );
3332         tmps = SvPV_force_nomg(sv, curlen);
3333         if (DO_UTF8(repl_sv) && repl_len) {
3334             if (!DO_UTF8(sv)) {
3335                 /* Upgrade the dest, and recalculate tmps in case the buffer
3336                  * got reallocated; curlen may also have been changed */
3337                 sv_utf8_upgrade_nomg(sv);
3338                 tmps = SvPV_nomg(sv, curlen);
3339             }
3340         }
3341         else if (DO_UTF8(sv))
3342             repl_need_utf8_upgrade = TRUE;
3343     }
3344     else tmps = SvPV_const(sv, curlen);
3345     if (DO_UTF8(sv)) {
3346         utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
3347         if (utf8_curlen == curlen)
3348             utf8_curlen = 0;
3349         else
3350             curlen = utf8_curlen;
3351     }
3352     else
3353         utf8_curlen = 0;
3354
3355     {
3356         STRLEN pos, len, byte_len, byte_pos;
3357
3358         if (!translate_substr_offsets(
3359                 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3360         )) goto bound_fail;
3361
3362         byte_len = len;
3363         byte_pos = utf8_curlen
3364             ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
3365
3366         tmps += byte_pos;
3367
3368         if (rvalue) {
3369             SvTAINTED_off(TARG);                        /* decontaminate */
3370             SvUTF8_off(TARG);                   /* decontaminate */
3371             sv_setpvn(TARG, tmps, byte_len);
3372 #ifdef USE_LOCALE_COLLATE
3373             sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3374 #endif
3375             if (utf8_curlen)
3376                 SvUTF8_on(TARG);
3377         }
3378
3379         if (repl) {
3380             SV* repl_sv_copy = NULL;
3381
3382             if (repl_need_utf8_upgrade) {
3383                 repl_sv_copy = newSVsv(repl_sv);
3384                 sv_utf8_upgrade(repl_sv_copy);
3385                 repl = SvPV_const(repl_sv_copy, repl_len);
3386             }
3387             if (!SvOK(sv))
3388                 SvPVCLEAR(sv);
3389             sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3390             SvREFCNT_dec(repl_sv_copy);
3391         }
3392     }
3393     if (PL_op->op_private & OPpSUBSTR_REPL_FIRST)
3394         SP++;
3395     else if (rvalue) {
3396         SvSETMAGIC(TARG);
3397         PUSHs(TARG);
3398     }
3399     RETURN;
3400
3401   bound_fail:
3402     if (repl)
3403         Perl_croak(aTHX_ "substr outside of string");
3404     Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3405     RETPUSHUNDEF;
3406 }
3407
3408 PP(pp_vec)
3409 {
3410     dSP;
3411     const IV size   = POPi;
3412     SV* offsetsv   = POPs;
3413     SV * const src = POPs;
3414     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3415     SV * ret;
3416     UV   retuv;
3417     STRLEN offset = 0;
3418     char errflags = 0;
3419
3420     /* extract a STRLEN-ranged integer value from offsetsv into offset,
3421      * or flag that its out of range */
3422     {
3423         IV iv = SvIV(offsetsv);
3424
3425         /* avoid a large UV being wrapped to a negative value */
3426         if (SvIOK_UV(offsetsv) && SvUVX(offsetsv) > (UV)IV_MAX)
3427             errflags = LVf_OUT_OF_RANGE;
3428         else if (iv < 0)
3429             errflags = (LVf_NEG_OFF|LVf_OUT_OF_RANGE);
3430 #if PTRSIZE < IVSIZE
3431         else if (iv > Size_t_MAX)
3432             errflags = LVf_OUT_OF_RANGE;
3433 #endif
3434         else
3435             offset = (STRLEN)iv;
3436     }
3437
3438     retuv = errflags ? 0 : do_vecget(src, offset, size);
3439
3440     if (lvalue) {                       /* it's an lvalue! */
3441         ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
3442         sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3443         LvTYPE(ret) = 'v';
3444         LvTARG(ret) = SvREFCNT_inc_simple(src);
3445         LvTARGOFF(ret) = offset;
3446         LvTARGLEN(ret) = size;
3447         LvFLAGS(ret)   = errflags;
3448     }
3449     else {
3450         dTARGET;
3451         SvTAINTED_off(TARG);            /* decontaminate */
3452         ret = TARG;
3453     }
3454
3455     sv_setuv(ret, retuv);
3456     if (!lvalue)
3457         SvSETMAGIC(ret);
3458     PUSHs(ret);
3459     RETURN;
3460 }
3461
3462
3463 /* also used for: pp_rindex() */
3464
3465 PP(pp_index)
3466 {
3467     dSP; dTARGET;
3468     SV *big;
3469     SV *little;
3470     SV *temp = NULL;
3471     STRLEN biglen;
3472     STRLEN llen = 0;
3473     SSize_t offset = 0;
3474     SSize_t retval;
3475     const char *big_p;
3476     const char *little_p;
3477     bool big_utf8;
3478     bool little_utf8;
3479     const bool is_index = PL_op->op_type == OP_INDEX;
3480     const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
3481
3482     if (threeargs)
3483         offset = POPi;
3484     little = POPs;
3485     big = POPs;
3486     big_p = SvPV_const(big, biglen);
3487     little_p = SvPV_const(little, llen);
3488
3489     big_utf8 = DO_UTF8(big);
3490     little_utf8 = DO_UTF8(little);
3491     if (big_utf8 ^ little_utf8) {
3492         /* One needs to be upgraded.  */
3493         if (little_utf8) {
3494             /* Well, maybe instead we might be able to downgrade the small
3495                string?  */
3496             char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3497                                                      &little_utf8);
3498             if (little_utf8) {
3499                 /* If the large string is ISO-8859-1, and it's not possible to
3500                    convert the small string to ISO-8859-1, then there is no
3501                    way that it could be found anywhere by index.  */
3502                 retval = -1;
3503                 goto push_result;
3504             }
3505
3506             /* At this point, pv is a malloc()ed string. So donate it to temp
3507                to ensure it will get free()d  */
3508             little = temp = newSV(0);
3509             sv_usepvn(temp, pv, llen);
3510             little_p = SvPVX(little);
3511         } else {
3512             temp = newSVpvn(little_p, llen);
3513
3514             sv_utf8_upgrade(temp);
3515             little = temp;
3516             little_p = SvPV_const(little, llen);
3517         }
3518     }
3519     if (SvGAMAGIC(big)) {
3520         /* Life just becomes a lot easier if I use a temporary here.
3521            Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3522            will trigger magic and overloading again, as will fbm_instr()
3523         */
3524         big = newSVpvn_flags(big_p, biglen,
3525                              SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3526         big_p = SvPVX(big);
3527     }
3528     if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3529         /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3530            warn on undef, and we've already triggered a warning with the
3531            SvPV_const some lines above. We can't remove that, as we need to
3532            call some SvPV to trigger overloading early and find out if the
3533            string is UTF-8.
3534            This is all getting too messy. The API isn't quite clean enough,
3535            because data access has side effects.
3536         */
3537         little = newSVpvn_flags(little_p, llen,
3538                                 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3539         little_p = SvPVX(little);
3540     }
3541
3542     if (!threeargs)
3543         offset = is_index ? 0 : biglen;
3544     else {
3545         if (big_utf8 && offset > 0)
3546             offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
3547         if (!is_index)
3548             offset += llen;
3549     }
3550     if (offset < 0)
3551         offset = 0;
3552     else if (offset > (SSize_t)biglen)
3553         offset = biglen;
3554     if (!(little_p = is_index
3555           ? fbm_instr((unsigned char*)big_p + offset,
3556                       (unsigned char*)big_p + biglen, little, 0)
3557           : rninstr(big_p,  big_p  + offset,
3558                     little_p, little_p + llen)))
3559         retval = -1;
3560     else {
3561         retval = little_p - big_p;
3562         if (retval > 1 && big_utf8)
3563             retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
3564     }
3565     SvREFCNT_dec(temp);
3566
3567   push_result:
3568     /* OPpTRUEBOOL indicates an '== -1' has been optimised away */
3569     if (PL_op->op_private & OPpTRUEBOOL) {
3570         SV *result = ((retval != -1) ^ cBOOL(PL_op->op_private & OPpINDEX_BOOLNEG))
3571             ? &PL_sv_yes : &PL_sv_no;
3572         if (PL_op->op_private & OPpTARGET_MY) {
3573             /* $lex = (index() == -1) */
3574             sv_setsv_mg(TARG, result);
3575             PUSHs(TARG);
3576         }
3577         else {
3578             PUSHs(result);
3579         }
3580     }
3581     else
3582         PUSHi(retval);
3583     RETURN;
3584 }
3585
3586 PP(pp_sprintf)
3587 {
3588     dSP; dMARK; dORIGMARK; dTARGET;
3589     SvTAINTED_off(TARG);
3590     do_sprintf(TARG, SP-MARK, MARK+1);
3591     TAINT_IF(SvTAINTED(TARG));
3592     SP = ORIGMARK;
3593     PUSHTARG;
3594     RETURN;
3595 }
3596
3597 PP(pp_ord)
3598 {
3599     dSP; dTARGET;
3600
3601     SV *argsv = TOPs;
3602     STRLEN len;
3603     const U8 *s = (U8*)SvPV_const(argsv, len);
3604
3605     SETu(DO_UTF8(argsv)
3606            ? (len ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV) : 0)
3607            : (UV)(*s));
3608
3609     return NORMAL;
3610 }
3611
3612 PP(pp_chr)
3613 {
3614     dSP; dTARGET;
3615     char *tmps;
3616     UV value;
3617     SV *top = TOPs;
3618
3619     SvGETMAGIC(top);
3620     if (UNLIKELY(SvAMAGIC(top)))
3621         top = sv_2num(top);
3622     if (UNLIKELY(isinfnansv(top)))
3623         Perl_croak(aTHX_ "Cannot chr %" NVgf, SvNV(top));
3624     else {
3625         if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3626             && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3627                 ||
3628                 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3629                  && SvNV_nomg(top) < 0.0)))
3630         {
3631             if (ckWARN(WARN_UTF8)) {
3632                 if (SvGMAGICAL(top)) {
3633                     SV *top2 = sv_newmortal();
3634                     sv_setsv_nomg(top2, top);
3635                     top = top2;
3636                 }
3637                 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3638                             "Invalid negative number (%" SVf ") in chr", SVfARG(top));
3639             }
3640             value = UNICODE_REPLACEMENT;
3641         } else {
3642             value = SvUV_nomg(top);
3643         }
3644     }
3645
3646     SvUPGRADE(TARG,SVt_PV);
3647
3648     if (value > 255 && !IN_BYTES) {
3649         SvGROW(TARG, (STRLEN)UVCHR_SKIP(value)+1);
3650         tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3651         SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3652         *tmps = '\0';
3653         (void)SvPOK_only(TARG);
3654         SvUTF8_on(TARG);
3655         SETTARG;
3656         return NORMAL;
3657     }
3658
3659     SvGROW(TARG,2);
3660     SvCUR_set(TARG, 1);
3661     tmps = SvPVX(TARG);
3662     *tmps++ = (char)value;
3663     *tmps = '\0';
3664     (void)SvPOK_only(TARG);
3665
3666     SETTARG;
3667     return NORMAL;
3668 }
3669
3670 PP(pp_crypt)
3671 {
3672 #ifdef HAS_CRYPT
3673     dSP; dTARGET;
3674     dPOPTOPssrl;
3675     STRLEN len;
3676     const char *tmps = SvPV_const(left, len);
3677
3678     if (DO_UTF8(left)) {
3679          /* If Unicode, try to downgrade.
3680           * If not possible, croak.
3681           * Yes, we made this up.  */
3682          SV* const tsv = newSVpvn_flags(tmps, len, SVf_UTF8|SVs_TEMP);
3683
3684          sv_utf8_downgrade(tsv, FALSE);
3685          tmps = SvPV_const(tsv, len);
3686     }
3687 #  ifdef USE_ITHREADS
3688 #    ifdef HAS_CRYPT_R
3689     if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3690       /* This should be threadsafe because in ithreads there is only
3691        * one thread per interpreter.  If this would not be true,
3692        * we would need a mutex to protect this malloc. */
3693         PL_reentrant_buffer->_crypt_struct_buffer =
3694           (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3695 #      if defined(__GLIBC__) || defined(__EMX__)
3696         if (PL_reentrant_buffer->_crypt_struct_buffer) {
3697             PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3698         }
3699 #      endif
3700     }
3701 #    endif /* HAS_CRYPT_R */
3702 #  endif /* USE_ITHREADS */
3703
3704     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3705
3706     SvUTF8_off(TARG);
3707     SETTARG;
3708     RETURN;
3709 #else
3710     DIE(aTHX_
3711       "The crypt() function is unimplemented due to excessive paranoia.");
3712 #endif
3713 }
3714
3715 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level.  So
3716  * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3717
3718
3719 /* also used for: pp_lcfirst() */
3720
3721 PP(pp_ucfirst)
3722 {
3723     /* Actually is both lcfirst() and ucfirst().  Only the first character
3724      * changes.  This means that possibly we can change in-place, ie., just
3725      * take the source and change that one character and store it back, but not
3726      * if read-only etc, or if the length changes */
3727
3728     dSP;
3729     SV *source = TOPs;
3730     STRLEN slen; /* slen is the byte length of the whole SV. */
3731     STRLEN need;
3732     SV *dest;
3733     bool inplace;   /* ? Convert first char only, in-place */
3734     bool doing_utf8 = FALSE;               /* ? using utf8 */
3735     bool convert_source_to_utf8 = FALSE;   /* ? need to convert */
3736     const int op_type = PL_op->op_type;
3737     const U8 *s;
3738     U8 *d;
3739     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3740     STRLEN ulen;    /* ulen is the byte length of the original Unicode character
3741                      * stored as UTF-8 at s. */
3742     STRLEN tculen;  /* tculen is the byte length of the freshly titlecased (or
3743                      * lowercased) character stored in tmpbuf.  May be either
3744                      * UTF-8 or not, but in either case is the number of bytes */
3745     bool remove_dot_above = FALSE;
3746
3747     s = (const U8*)SvPV_const(source, slen);
3748
3749     /* We may be able to get away with changing only the first character, in
3750      * place, but not if read-only, etc.  Later we may discover more reasons to
3751      * not convert in-place. */
3752     inplace = !SvREADONLY(source) && SvPADTMP(source);
3753
3754 #ifdef USE_LOCALE_CTYPE
3755
3756     if (IN_LC_RUNTIME(LC_CTYPE)) {
3757         _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3758     }
3759
3760 #endif
3761
3762     /* First calculate what the changed first character should be.  This affects
3763      * whether we can just swap it out, leaving the rest of the string unchanged,
3764      * or even if have to convert the dest to UTF-8 when the source isn't */
3765
3766     if (! slen) {   /* If empty */
3767         need = 1; /* still need a trailing NUL */
3768         ulen = 0;
3769         *tmpbuf = '\0';
3770     }
3771     else if (DO_UTF8(source)) { /* Is the source utf8? */
3772         doing_utf8 = TRUE;
3773         ulen = UTF8SKIP(s);
3774
3775         if (op_type == OP_UCFIRST) {
3776 #ifdef USE_LOCALE_CTYPE
3777             _toTITLE_utf8_flags(s, s +slen, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3778 #else
3779             _toTITLE_utf8_flags(s, s +slen, tmpbuf, &tculen, 0);
3780 #endif
3781         }
3782         else {
3783
3784 #ifdef USE_LOCALE_CTYPE
3785
3786             _toLOWER_utf8_flags(s, s + slen, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3787
3788             /* In turkic locales, lower casing an 'I' normally yields U+0131,
3789              * LATIN SMALL LETTER DOTLESS I, but not if the grapheme also
3790              * contains a COMBINING DOT ABOVE.  Instead it is treated like
3791              * LATIN CAPITAL LETTER I WITH DOT ABOVE lowercased to 'i'.  The
3792              * call to lowercase above has handled this.  But SpecialCasing.txt
3793              * says we are supposed to remove the COMBINING DOT ABOVE.  We can
3794              * tell if we have this situation if I ==> i in a turkic locale. */
3795             if (   UNLIKELY(PL_in_utf8_turkic_locale)
3796                 && IN_LC_RUNTIME(LC_CTYPE)
3797                 && (UNLIKELY(*s == 'I' && tmpbuf[0] == 'i')))
3798             {
3799                 /* Here, we know there was a COMBINING DOT ABOVE.  We won't be
3800                  * able to handle this in-place. */
3801                 inplace = FALSE;
3802
3803                 /* It seems likely that the DOT will immediately follow the
3804                  * 'I'.  If so, we can remove it simply by indicating to the
3805                  * code below to start copying the source just beyond the DOT.
3806                  * We know its length is 2 */
3807                 if (LIKELY(memBEGINs(s + 1, s + slen, COMBINING_DOT_ABOVE_UTF8))) {
3808                     ulen += 2;
3809                 }
3810                 else {  /* But if it doesn't follow immediately, set a flag for
3811                            the code below */
3812                     remove_dot_above = TRUE;
3813                 }
3814             }
3815 #else
3816             PERL_UNUSED_VAR(remove_dot_above);
3817
3818             _toLOWER_utf8_flags(s, s + slen, tmpbuf, &tculen, 0);
3819 #endif
3820
3821         }
3822
3823         /* we can't do in-place if the length changes.  */
3824         if (ulen != tculen) inplace = FALSE;
3825         need = slen + 1 - ulen + tculen;
3826     }
3827     else { /* Non-zero length, non-UTF-8,  Need to consider locale and if
3828             * latin1 is treated as caseless.  Note that a locale takes
3829             * precedence */
3830         ulen = 1;       /* Original character is 1 byte */
3831         tculen = 1;     /* Most characters will require one byte, but this will
3832                          * need to be overridden for the tricky ones */
3833         need = slen + 1;
3834
3835
3836 #ifdef USE_LOCALE_CTYPE
3837
3838         if (IN_LC_RUNTIME(LC_CTYPE)) {
3839             if (    UNLIKELY(PL_in_utf8_turkic_locale)
3840                 && (   (op_type == OP_LCFIRST && UNLIKELY(*s == 'I'))
3841                     || (op_type == OP_UCFIRST && UNLIKELY(*s == 'i'))))
3842             {
3843                 if (*s == 'I') { /* lcfirst('I') */
3844                     tmpbuf[0] = UTF8_TWO_BYTE_HI(LATIN_SMALL_LETTER_DOTLESS_I);
3845                     tmpbuf[1] = UTF8_TWO_BYTE_LO(LATIN_SMALL_LETTER_DOTLESS_I);
3846                 }
3847                 else {  /* ucfirst('i') */
3848                     tmpbuf[0] = UTF8_TWO_BYTE_HI(LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
3849                     tmpbuf[1] = UTF8_TWO_BYTE_LO(LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
3850                 }
3851                 tculen = 2;
3852                 inplace = FALSE;
3853                 doing_utf8 = TRUE;
3854                 convert_source_to_utf8 = TRUE;
3855                 need += variant_under_utf8_count(s, s + slen);
3856             }
3857             else if (op_type == OP_LCFIRST) {
3858
3859                 /* For lc, there are no gotchas for UTF-8 locales (other than
3860                  * the turkish ones already handled above) */
3861                 *tmpbuf = toLOWER_LC(*s);
3862             }
3863             else { /* ucfirst */
3864
3865                 /* But for uc, some characters require special handling */
3866                 if (IN_UTF8_CTYPE_LOCALE) {
3867                     goto do_uni_rules;
3868                 }
3869
3870                 /* This would be a bug if any locales have upper and title case
3871                  * different */
3872                 *tmpbuf = (U8) toUPPER_LC(*s);
3873             }
3874         }
3875         else
3876 #endif
3877         /* Here, not in locale.  If not using Unicode rules, is a simple
3878          * lower/upper, depending */
3879         if (! IN_UNI_8_BIT) {
3880             *tmpbuf = (op_type == OP_LCFIRST)
3881                       ? toLOWER(*s)
3882                       : toUPPER(*s);
3883         }
3884         else if (op_type == OP_LCFIRST) {
3885             /* lower case the first letter: no trickiness for any character */
3886             *tmpbuf = toLOWER_LATIN1(*s);
3887         }
3888         else {
3889             /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is
3890              * non-turkic UTF-8, which we treat as not in locale), and cased
3891              * latin1 */
3892             UV title_ord;
3893 #ifdef USE_LOCALE_CTYPE
3894       do_uni_rules:
3895 #endif
3896
3897             title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3898             if (tculen > 1) {
3899                 assert(tculen == 2);
3900
3901                 /* If the result is an upper Latin1-range character, it can
3902                  * still be represented in one byte, which is its ordinal */
3903                 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3904                     *tmpbuf = (U8) title_ord;
3905                     tculen = 1;
3906                 }
3907                 else {
3908                     /* Otherwise it became more than one ASCII character (in
3909                      * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3910                      * beyond Latin1, so the number of bytes changed, so can't
3911                      * replace just the first character in place. */
3912                     inplace = FALSE;
3913
3914                     /* If the result won't fit in a byte, the entire result
3915                      * will have to be in UTF-8.  Allocate enough space for the
3916                      * expanded first byte, and if UTF-8, the rest of the input
3917                      * string, some or all of which may also expand to two
3918                      * bytes, plus the terminating NUL. */
3919                     if (title_ord > 255) {
3920                         doing_utf8 = TRUE;
3921                         convert_source_to_utf8 = TRUE;
3922                         need = slen
3923                             + variant_under_utf8_count(s, s + slen)
3924                             + 1;
3925
3926                         /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3927                          * characters whose title case is above 255 is
3928                          * 2. */
3929                         ulen = 2;
3930                     }
3931                     else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3932                         need = slen + 1 + 1;
3933                     }
3934                 }
3935             }
3936         } /* End of use Unicode (Latin1) semantics */
3937     } /* End of changing the case of the first character */
3938
3939     /* Here, have the first character's changed case stored in tmpbuf.  Ready to
3940      * generate the result */
3941     if (inplace) {
3942
3943         /* We can convert in place.  This means we change just the first
3944          * character without disturbing the rest; no need to grow */
3945         dest = source;
3946         s = d = (U8*)SvPV_force_nomg(source, slen);
3947     } else {
3948         dTARGET;
3949
3950         dest = TARG;
3951
3952         /* Here, we can't convert in place; we earlier calculated how much
3953          * space we will need, so grow to accommodate that */
3954         SvUPGRADE(dest, SVt_PV);
3955         d = (U8*)SvGROW(dest, need);
3956         (void)SvPOK_only(dest);
3957
3958         SETs(dest);
3959     }
3960
3961     if (doing_utf8) {
3962         if (! inplace) {
3963             if (! convert_source_to_utf8) {
3964
3965                 /* Here  both source and dest are in UTF-8, but have to create
3966                  * the entire output.  We initialize the result to be the
3967                  * title/lower cased first character, and then append the rest
3968                  * of the string. */
3969                 sv_setpvn(dest, (char*)tmpbuf, tculen);
3970                 if (slen > ulen) {
3971
3972                     /* But this boolean being set means we are in a turkic
3973                      * locale, and there is a DOT character that needs to be
3974                      * removed, and it isn't immediately after the current
3975                      * character.  Keep concatenating characters to the output
3976                      * one at a time, until we find the DOT, which we simply
3977                      * skip */
3978                     if (UNLIKELY(remove_dot_above)) {
3979                         do {
3980                             Size_t this_len = UTF8SKIP(s + ulen);
3981
3982                             sv_catpvn(dest, (char*)(s + ulen), this_len);
3983
3984                             ulen += this_len;
3985                             if (memBEGINs(s + ulen, s + slen, COMBINING_DOT_ABOVE_UTF8)) {
3986                                 ulen += 2;
3987                                 break;
3988                             }
3989                         } while (s + ulen < s + slen);
3990                     }
3991
3992                     /* The rest of the string can be concatenated unchanged,
3993                      * all at once */
3994                     sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3995                 }
3996             }
3997             else {
3998                 const U8 *const send = s + slen;
3999
4000                 /* Here the dest needs to be in UTF-8, but the source isn't,
4001                  * except we earlier UTF-8'd the first character of the source
4002                  * into tmpbuf.  First put that into dest, and then append the
4003                  * rest of the source, converting it to UTF-8 as we go. */
4004
4005                 /* Assert tculen is 2 here because the only characters that
4006                  * get to this part of the code have 2-byte UTF-8 equivalents */
4007                 assert(tculen == 2);
4008                 *d++ = *tmpbuf;
4009                 *d++ = *(tmpbuf + 1);
4010                 s++;    /* We have just processed the 1st char */
4011
4012                 while (s < send) {
4013                     append_utf8_from_native_byte(*s, &d);
4014                     s++;
4015                 }
4016
4017                 *d = '\0';
4018                 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4019             }
4020             SvUTF8_on(dest);
4021         }
4022         else {   /* in-place UTF-8.  Just overwrite the first character */
4023             Copy(tmpbuf, d, tculen, U8);
4024             SvCUR_set(dest, need - 1);
4025         }
4026
4027     }
4028     else {  /* Neither source nor dest are, nor need to be UTF-8 */
4029         if (slen) {
4030             if (inplace) {  /* in-place, only need to change the 1st char */
4031                 *d = *tmpbuf;
4032             }
4033             else {      /* Not in-place */
4034
4035                 /* Copy the case-changed character(s) from tmpbuf */
4036                 Copy(tmpbuf, d, tculen, U8);
4037                 d += tculen - 1; /* Code below expects d to point to final
4038                                   * character stored */
4039             }
4040         }
4041         else {  /* empty source */
4042             /* See bug #39028: Don't taint if empty  */
4043             *d = *s;
4044         }
4045
4046         /* In a "use bytes" we don't treat the source as UTF-8, but, still want
4047          * the destination to retain that flag */
4048         if (DO_UTF8(source))
4049             SvUTF8_on(dest);
4050
4051         if (!inplace) { /* Finish the rest of the string, unchanged */
4052             /* This will copy the trailing NUL  */
4053             Copy(s + 1, d + 1, slen, U8);
4054             SvCUR_set(dest, need - 1);
4055         }
4056     }
4057 #ifdef USE_LOCALE_CTYPE
4058     if (IN_LC_RUNTIME(LC_CTYPE)) {
4059         TAINT;
4060         SvTAINTED_on(dest);
4061     }
4062 #endif
4063     if (dest != source && SvTAINTED(source))
4064         SvTAINT(dest);
4065     SvSETMAGIC(dest);
4066     return NORMAL;
4067 }
4068
4069 PP(pp_uc)
4070 {
4071     dSP;
4072     SV *source = TOPs;
4073     STRLEN len;
4074     STRLEN min;
4075     SV *dest;
4076     const U8 *s;
4077     U8 *d;
4078
4079     SvGETMAGIC(source);
4080
4081     if (   SvPADTMP(source)
4082         && !SvREADONLY(source) && SvPOK(source)
4083         && !DO_UTF8(source)
4084         && (
4085 #ifdef USE_LOCALE_CTYPE
4086             (IN_LC_RUNTIME(LC_CTYPE))
4087             ? ! IN_UTF8_CTYPE_LOCALE
4088             :
4089 #endif
4090               ! IN_UNI_8_BIT))
4091     {
4092
4093         /* We can convert in place.  The reason we can't if in UNI_8_BIT is to
4094          * make the loop tight, so we overwrite the source with the dest before
4095          * looking at it, and we need to look at the original source
4096          * afterwards.  There would also need to be code added to handle
4097          * switching to not in-place in midstream if we run into characters
4098          * that change the length.  Since being in locale overrides UNI_8_BIT,
4099          * that latter becomes irrelevant in the above test; instead for
4100          * locale, the size can't normally change, except if the locale is a
4101          * UTF-8 one */
4102         dest = source;
4103         s = d = (U8*)SvPV_force_nomg(source, len);
4104         min = len + 1;
4105     } else {
4106         dTARGET;
4107
4108         dest = TARG;
4109
4110         s = (const U8*)SvPV_nomg_const(source, len);
4111         min = len + 1;
4112
4113         SvUPGRADE(dest, SVt_PV);
4114         d = (U8*)SvGROW(dest, min);
4115         (void)SvPOK_only(dest);
4116
4117         SETs(dest);
4118     }
4119
4120 #ifdef USE_LOCALE_CTYPE
4121
4122     if (IN_LC_RUNTIME(LC_CTYPE)) {
4123         _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4124     }
4125
4126 #endif
4127
4128     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4129        to check DO_UTF8 again here.  */
4130
4131     if (DO_UTF8(source)) {
4132         const U8 *const send = s + len;
4133         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4134
4135 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
4136 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
4137         /* All occurrences of these are to be moved to follow any other marks.
4138          * This is context-dependent.  We may not be passed enough context to
4139          * move the iota subscript beyond all of them, but we do the best we can
4140          * with what we're given.  The result is always better than if we
4141          * hadn't done this.  And, the problem would only arise if we are
4142          * passed a character without all its combining marks, which would be
4143          * the caller's mistake.  The information this is based on comes from a
4144          * comment in Unicode SpecialCasing.txt, (and the Standard's text
4145          * itself) and so can't be checked properly to see if it ever gets
4146          * revised.  But the likelihood of it changing is remote */
4147         bool in_iota_subscript = FALSE;
4148
4149         while (s < send) {
4150             STRLEN u;
4151             STRLEN ulen;
4152             UV uv;
4153             if (UNLIKELY(in_iota_subscript)) {
4154                 UV cp = utf8_to_uvchr_buf(s, send, NULL);
4155
4156                 if (! _invlist_contains_cp(PL_utf8_mark, cp)) {
4157
4158                     /* A non-mark.  Time to output the iota subscript */
4159                     *d++ = UTF8_TWO_BYTE_HI(GREEK_CAPITAL_LETTER_IOTA);
4160                     *d++ = UTF8_TWO_BYTE_LO(GREEK_CAPITAL_LETTER_IOTA);
4161                     in_iota_subscript = FALSE;
4162                 }
4163             }
4164
4165             /* Then handle the current character.  Get the changed case value
4166              * and copy it to the output buffer */
4167
4168             u = UTF8SKIP(s);
4169 #ifdef USE_LOCALE_CTYPE
4170             uv = _toUPPER_utf8_flags(s, send, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4171 #else
4172             uv = _toUPPER_utf8_flags(s, send, tmpbuf, &ulen, 0);
4173 #endif
4174             if (uv == GREEK_CAPITAL_LETTER_IOTA
4175                 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
4176             {
4177                 in_iota_subscript = TRUE;
4178             }
4179             else {
4180                 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4181                     /* If the eventually required minimum size outgrows the
4182                      * available space, we need to grow. */
4183                     const UV o = d - (U8*)SvPVX_const(dest);
4184
4185                     /* If someone uppercases one million U+03B0s we SvGROW()
4186                      * one million times.  Or we could try guessing how much to
4187                      * allocate without allocating too much.  But we can't
4188                      * really guess without examining the rest of the string.
4189                      * Such is life.  See corresponding comment in lc code for
4190                      * another option */
4191                     d = o + (U8*) SvGROW(dest, min);
4192                 }
4193                 Copy(tmpbuf, d, ulen, U8);
4194                 d += ulen;
4195             }
4196             s += u;
4197         }
4198         if (in_iota_subscript) {
4199             *d++ = UTF8_TWO_BYTE_HI(GREEK_CAPITAL_LETTER_IOTA);
4200             *d++ = UTF8_TWO_BYTE_LO(GREEK_CAPITAL_LETTER_IOTA);
4201         }
4202         SvUTF8_on(dest);
4203         *d = '\0';
4204
4205         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4206     }
4207     else {      /* Not UTF-8 */
4208         if (len) {
4209             const U8 *const send = s + len;
4210
4211             /* Use locale casing if in locale; regular style if not treating
4212              * latin1 as having case; otherwise the latin1 casing.  Do the
4213              * whole thing in a tight loop, for speed, */
4214 #ifdef USE_LOCALE_CTYPE
4215             if (IN_LC_RUNTIME(LC_CTYPE)) {
4216                 if (IN_UTF8_CTYPE_LOCALE) {
4217                     goto do_uni_rules;
4218                 }
4219                 for (; s < send; d++, s++)
4220                     *d = (U8) toUPPER_LC(*s);
4221             }
4222             else
4223 #endif
4224                  if (! IN_UNI_8_BIT) {
4225                 for (; s < send; d++, s++) {
4226                     *d = toUPPER(*s);
4227                 }
4228             }
4229             else {
4230 #ifdef USE_LOCALE_CTYPE
4231           do_uni_rules:
4232 #endif
4233                 for (; s < send; d++, s++) {
4234                     Size_t extra;
4235
4236                     *d = toUPPER_LATIN1_MOD(*s);
4237                     if (   LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)
4238
4239 #ifdef USE_LOCALE_CTYPE
4240
4241                         && (LIKELY(   ! PL_in_utf8_turkic_locale
4242                                    || ! IN_LC_RUNTIME(LC_CTYPE))
4243                                    || *s != 'i')
4244 #endif
4245
4246                     ) {
4247                         continue;
4248                     }
4249
4250                     /* The mainstream case is the tight loop above.  To avoid
4251                      * extra tests in that, all three characters that always
4252                      * require special handling are mapped by the MOD to the
4253                      * one tested just above.  Use the source to distinguish
4254                      * between those cases */
4255
4256 #if    UNICODE_MAJOR_VERSION > 2                                        \
4257    || (UNICODE_MAJOR_VERSION == 2 && UNICODE_DOT_VERSION >= 1           \
4258                                   && UNICODE_DOT_DOT_VERSION >= 8)
4259                     if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4260
4261                         /* uc() of this requires 2 characters, but they are
4262                          * ASCII.  If not enough room, grow the string */
4263                         if (SvLEN(dest) < ++min) {
4264                             const UV o = d - (U8*)SvPVX_const(dest);
4265                             d = o + (U8*) SvGROW(dest, min);
4266                         }
4267                         *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
4268                         continue;   /* Back to the tight loop; still in ASCII */
4269                     }
4270 #endif
4271
4272                     /* The other special handling characters have their
4273                      * upper cases outside the latin1 range, hence need to be
4274                      * in UTF-8, so the whole result needs to be in UTF-8.
4275                      *
4276                      * So, here we are somewhere in the middle of processing a
4277                      * non-UTF-8 string, and realize that we will have to
4278                      * convert the whole thing to UTF-8.  What to do?  There
4279                      * are several possibilities.  The simplest to code is to
4280                      * convert what we have so far, set a flag, and continue on
4281                      * in the loop.  The flag would be tested each time through
4282                      * the loop, and if set, the next character would be
4283                      * converted to UTF-8 and stored.  But, I (khw) didn't want
4284                      * to slow down the mainstream case at all for this fairly
4285                      * rare case, so I didn't want to add a test that didn't
4286                      * absolutely have to be there in the loop, besides the
4287                      * possibility that it would get too complicated for
4288                      * optimizers to deal with.  Another possibility is to just
4289                      * give up, convert the source to UTF-8, and restart the
4290                      * function that way.  Another possibility is to convert
4291                      * both what has already been processed and what is yet to
4292                      * come separately to UTF-8, then jump into the loop that
4293                      * handles UTF-8.  But the most efficient time-wise of the
4294                      * ones I could think of is what follows, and turned out to
4295                      * not require much extra code.
4296                      *
4297                      * First, calculate the extra space needed for the
4298                      * remainder of the source needing to be in UTF-8.  Except
4299                      * for the 'i' in Turkic locales, in UTF-8 strings, the
4300                      * uppercase of a character below 256 occupies the same
4301                      * number of bytes as the original.  Therefore, the space
4302                      * needed is the that number plus the number of characters
4303                      * that become two bytes when converted to UTF-8, plus, in
4304                      * turkish locales, the number of 'i's. */
4305
4306                     extra = send - s + variant_under_utf8_count(s, send);
4307
4308 #ifdef USE_LOCALE_CTYPE
4309
4310                     if (UNLIKELY(*s == 'i')) {  /* We wouldn't get an 'i' here
4311                                                    unless are in a Turkic
4312                                                    locale */
4313                         const U8 * s_peek = s;
4314
4315                         do {
4316                             extra++;
4317
4318                             s_peek = (U8 *) memchr(s_peek + 1, 'i',
4319                                                    send - (s_peek + 1));
4320                         } while (s_peek != NULL);
4321                     }
4322 #endif
4323
4324                     /* Convert what we have so far into UTF-8, telling the
4325                      * function that we know it should be converted, and to
4326                      * allow extra space for what we haven't processed yet.
4327                      *
4328                      * This may cause the string pointer to move, so need to
4329                      * save and re-find it. */
4330
4331                     len = d - (U8*)SvPVX_const(dest);
4332                     SvCUR_set(dest, len);
4333                     len = sv_utf8_upgrade_flags_grow(dest,
4334                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4335                                                 extra
4336                                               + 1 /* trailing NUL */ );
4337                     d = (U8*)SvPVX(dest) + len;
4338
4339                     /* Now process the remainder of the source, simultaneously
4340                      * converting to upper and UTF-8.
4341                      *
4342                      * To avoid extra tests in the loop body, and since the
4343                      * loop is so simple, split out the rare Turkic case into
4344                      * its own loop */
4345
4346 #ifdef USE_LOCALE_CTYPE
4347                     if (   UNLIKELY(PL_in_utf8_turkic_locale)
4348                         && UNLIKELY(IN_LC_RUNTIME(LC_CTYPE)))
4349                     {
4350                         for (; s < send; s++) {
4351                             if (*s == 'i') {
4352                                 *d++ = UTF8_TWO_BYTE_HI(LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
4353                                 *d++ = UTF8_TWO_BYTE_LO(LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
4354                             }
4355                             else {
4356                                 (void) _to_upper_title_latin1(*s, d, &len, 'S');
4357                                 d += len;
4358                             }
4359                         }
4360                     }
4361                     else
4362 #endif
4363                         for (; s < send; s++) {
4364                             (void) _to_upper_title_latin1(*s, d, &len, 'S');
4365                             d += len;
4366                         }
4367
4368                     /* Here have processed the whole source; no need to
4369                      * continue with the outer loop.  Each character has been
4370                      * converted to upper case and converted to UTF-8. */
4371                     break;
4372                 } /* End of processing all latin1-style chars */
4373             } /* End of processing all chars */
4374         } /* End of source is not empty */
4375
4376         if (source != dest) {
4377             *d = '\0';  /* Here d points to 1 after last char, add NUL */
4378             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4379         }
4380     } /* End of isn't utf8 */
4381 #ifdef USE_LOCALE_CTYPE
4382     if (IN_LC_RUNTIME(LC_CTYPE)) {
4383         TAINT;
4384         SvTAINTED_on(dest);
4385     }
4386 #endif
4387     if (dest != source && SvTAINTED(source))
4388         SvTAINT(dest);
4389     SvSETMAGIC(dest);
4390     return NORMAL;
4391 }
4392
4393 PP(pp_lc)
4394 {
4395     dSP;
4396     SV *source = TOPs;
4397     STRLEN len;
4398     STRLEN min;
4399     SV *dest;
4400     const U8 *s;
4401     U8 *d;
4402     bool has_turkic_I = FALSE;
4403
4404     SvGETMAGIC(source);
4405
4406     if (   SvPADTMP(source)
4407         && !SvREADONLY(source) && SvPOK(source)
4408         && !DO_UTF8(source)
4409
4410 #ifdef USE_LOCALE_CTYPE
4411
4412         && (   LIKELY(! IN_LC_RUNTIME(LC_CTYPE))
4413             || LIKELY(! PL_in_utf8_turkic_locale))
4414
4415 #endif
4416
4417     ) {
4418
4419         /* We can convert in place, as, outside of Turkic UTF-8 locales,
4420          * lowercasing anything in the latin1 range (or else DO_UTF8 would have
4421          * been on) doesn't lengthen it. */
4422         dest = source;
4423         s = d = (U8*)SvPV_force_nomg(source, len);
4424         min = len + 1;
4425     } else {
4426         dTARGET;
4427
4428         dest = TARG;
4429
4430         s = (const U8*)SvPV_nomg_const(source, len);
4431         min = len + 1;
4432
4433         SvUPGRADE(dest, SVt_PV);
4434         d = (U8*)SvGROW(dest, min);
4435         (void)SvPOK_only(dest);
4436
4437         SETs(dest);
4438     }
4439
4440 #ifdef USE_LOCALE_CTYPE
4441
4442     if (IN_LC_RUNTIME(LC_CTYPE)) {
4443         const U8 * next_I;
4444
4445         _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4446
4447         /* Lowercasing in a Turkic locale can cause non-UTF-8 to need to become
4448          * UTF-8 for the single case of the character 'I' */
4449         if (     UNLIKELY(PL_in_utf8_turkic_locale)
4450             && ! DO_UTF8(source)
4451             &&   (next_I = (U8 *) memchr(s, 'I', len)))
4452         {
4453             Size_t I_count = 0;
4454             const U8 *const send = s + len;
4455
4456             do {
4457                 I_count++;
4458
4459                 next_I = (U8 *) memchr(next_I + 1, 'I',
4460                                         send - (next_I + 1));
4461             } while (next_I != NULL);
4462
4463             /* Except for the 'I', in UTF-8 strings, the lower case of a
4464              * character below 256 occupies the same number of bytes as the
4465              * original.  Therefore, the space needed is the original length
4466              * plus I_count plus the number of characters that become two bytes
4467              * when converted to UTF-8 */
4468             sv_utf8_upgrade_flags_grow(dest, 0, len
4469                                               + I_count
4470                                               + variant_under_utf8_count(s, send)
4471                                               + 1 /* Trailing NUL */ );
4472             d = (U8*)SvPVX(dest);
4473             has_turkic_I = TRUE;
4474         }
4475     }
4476
4477 #else
4478     PERL_UNUSED_VAR(has_turkic_I);
4479 #endif
4480
4481     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4482        to check DO_UTF8 again here.  */
4483
4484     if (DO_UTF8(source)) {
4485         const U8 *const send = s + len;
4486         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4487         bool remove_dot_above = FALSE;
4488
4489         while (s < send) {
4490             const STRLEN u = UTF8SKIP(s);
4491             STRLEN ulen;
4492
4493 #ifdef USE_LOCALE_CTYPE
4494
4495             _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4496
4497             /* If we are in a Turkic locale, we have to do more work.  As noted
4498              * in the comments for lcfirst, there is a special case if a 'I'
4499              * is in a grapheme with COMBINING DOT ABOVE UTF8.  It turns into a
4500              * 'i', and the DOT must be removed.  We check for that situation,
4501              * and set a flag if the DOT is there.  Then each time through the
4502              * loop, we have to see if we need to remove the next DOT above,
4503              * and if so, do it.  We know that there is a DOT because
4504              * _toLOWER_utf8_flags() wouldn't have returned 'i' unless there
4505              * was one in a proper position. */
4506             if (   UNLIKELY(PL_in_utf8_turkic_locale)
4507                 && IN_LC_RUNTIME(LC_CTYPE))
4508             {
4509                 if (   UNLIKELY(remove_dot_above)
4510                     && memBEGINs(tmpbuf, sizeof(tmpbuf), COMBINING_DOT_ABOVE_UTF8))
4511                 {
4512                     s += u;
4513                     remove_dot_above = FALSE;
4514                     continue;
4515                 }
4516                 else if (UNLIKELY(*s == 'I' && tmpbuf[0] == 'i')) {
4517                     remove_dot_above = TRUE;
4518                 }
4519             }
4520 #else
4521             PERL_UNUSED_VAR(remove_dot_above);
4522
4523             _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, 0);
4524 #endif
4525
4526             /* Here is where we would do context-sensitive actions for the
4527              * Greek final sigma.  See the commit message for 86510fb15 for why
4528              * there isn't any */
4529
4530             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4531
4532                 /* If the eventually required minimum size outgrows the
4533                  * available space, we need to grow. */
4534                 const UV o = d - (U8*)SvPVX_const(dest);
4535
4536                 /* If someone lowercases one million U+0130s we SvGROW() one
4537                  * million times.  Or we could try guessing how much to
4538                  * allocate without allocating too much.  Such is life.
4539                  * Another option would be to grow an extra byte or two more
4540                  * each time we need to grow, which would cut down the million
4541                  * to 500K, with little waste */
4542                 d = o + (U8*) SvGROW(dest, min);
4543             }
4544
4545             /* Copy the newly lowercased letter to the output buffer we're
4546              * building */
4547             Copy(tmpbuf, d, ulen, U8);
4548             d += ulen;
4549             s += u;
4550         }   /* End of looping through the source string */
4551         SvUTF8_on(dest);
4552         *d = '\0';
4553         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4554     } else {    /* 'source' not utf8 */
4555         if (len) {
4556             const U8 *const send = s + len;
4557
4558             /* Use locale casing if in locale; regular style if not treating
4559              * latin1 as having case; otherwise the latin1 casing.  Do the
4560              * whole thing in a tight loop, for speed, */
4561 #ifdef USE_LOCALE_CTYPE
4562             if (IN_LC_RUNTIME(LC_CTYPE)) {
4563                 if (LIKELY( ! has_turkic_I)) {
4564                     for (; s < send; d++, s++)
4565                         *d = toLOWER_LC(*s);
4566                 }
4567                 else {  /* This is the only case where lc() converts 'dest'
4568                            into UTF-8 from a non-UTF-8 'source' */
4569                     for (; s < send; s++) {
4570                         if (*s == 'I') {
4571                             *d++ = UTF8_TWO_BYTE_HI(LATIN_SMALL_LETTER_DOTLESS_I);
4572                             *d++ = UTF8_TWO_BYTE_LO(LATIN_SMALL_LETTER_DOTLESS_I);
4573                         }
4574                         else {
4575                             append_utf8_from_native_byte(toLOWER_LATIN1(*s), &d);
4576                         }
4577                     }
4578                 }
4579             }
4580             else
4581 #endif
4582             if (! IN_UNI_8_BIT) {
4583                 for (; s < send; d++, s++) {
4584                     *d = toLOWER(*s);
4585                 }
4586             }
4587             else {
4588                 for (; s < send; d++, s++) {
4589                     *d = toLOWER_LATIN1(*s);
4590                 }
4591             }
4592         }
4593         if (source != dest) {
4594             *d = '\0';
4595             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4596         }
4597     }
4598 #ifdef USE_LOCALE_CTYPE
4599     if (IN_LC_RUNTIME(LC_CTYPE)) {
4600         TAINT;
4601         SvTAINTED_on(dest);
4602     }
4603 #endif
4604     if (dest != source && SvTAINTED(source))
4605         SvTAINT(dest);
4606     SvSETMAGIC(dest);
4607     return NORMAL;
4608 }
4609
4610 PP(pp_quotemeta)
4611 {
4612     dSP; dTARGET;
4613     SV * const sv = TOPs;
4614     STRLEN len;
4615     const char *s = SvPV_const(sv,len);
4616
4617     SvUTF8_off(TARG);                           /* decontaminate */
4618     if (len) {
4619         char *d;
4620         SvUPGRADE(TARG, SVt_PV);
4621         SvGROW(TARG, (len * 2) + 1);
4622         d = SvPVX(TARG);
4623         if (DO_UTF8(sv)) {
4624             while (len) {
4625                 STRLEN ulen = UTF8SKIP(s);
4626                 bool to_quote = FALSE;
4627
4628                 if (UTF8_IS_INVARIANT(*s)) {
4629                     if (_isQUOTEMETA(*s)) {
4630                         to_quote = TRUE;
4631                     }
4632                 }
4633                 else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(s, s + len)) {
4634                     if (
4635 #ifdef USE_LOCALE_CTYPE
4636                     /* In locale, we quote all non-ASCII Latin1 chars.
4637                      * Otherwise use the quoting rules */
4638
4639                     IN_LC_RUNTIME(LC_CTYPE)
4640                         ||
4641 #endif
4642                         _isQUOTEMETA(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s + 1))))
4643                     {
4644                         to_quote = TRUE;
4645                     }
4646                 }
4647                 else if (is_QUOTEMETA_high(s)) {
4648                     to_quote = TRUE;
4649                 }
4650
4651                 if (to_quote) {
4652                     *d++ = '\\';
4653                 }
4654                 if (ulen > len)
4655                     ulen = len;
4656                 len -= ulen;
4657                 while (ulen--)
4658                     *d++ = *s++;
4659             }
4660             SvUTF8_on(TARG);
4661         }
4662         else if (IN_UNI_8_BIT) {
4663             while (len--) {
4664                 if (_isQUOTEMETA(*s))
4665                     *d++ = '\\';
4666                 *d++ = *s++;
4667             }
4668         }
4669         else {
4670             /* For non UNI_8_BIT (and hence in locale) just quote all \W
4671              * including everything above ASCII */
4672             while (len--) {
4673                 if (!isWORDCHAR_A(*s))
4674                     *d++ = '\\';
4675                 *d++ = *s++;
4676             }
4677         }
4678         *d = '\0';
4679         SvCUR_set(TARG, d - SvPVX_const(TARG));
4680         (void)SvPOK_only_UTF8(TARG);
4681     }
4682     else
4683         sv_setpvn(TARG, s, len);
4684     SETTARG;
4685     return NORMAL;
4686 }
4687
4688 PP(pp_fc)
4689 {
4690     dTARGET;
4691     dSP;
4692     SV *source = TOPs;
4693     STRLEN len;
4694     STRLEN min;
4695     SV *dest;
4696     const U8 *s;
4697     const U8 *send;
4698     U8 *d;
4699     U8 tmpbuf[UTF8_MAXBYTES_CASE + 1];
4700 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
4701    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
4702                                       || UNICODE_DOT_DOT_VERSION > 0)
4703     const bool full_folding = TRUE; /* This variable is here so we can easily
4704                                        move to more generality later */
4705 #else
4706     const bool full_folding = FALSE;
4707 #endif
4708     const U8 flags = ( full_folding      ? FOLD_FLAGS_FULL   : 0 )
4709 #ifdef USE_LOCALE_CTYPE
4710                    | ( IN_LC_RUNTIME(LC_CTYPE) ? FOLD_FLAGS_LOCALE : 0 )
4711 #endif
4712     ;
4713
4714     /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4715      * You are welcome(?) -Hugmeir
4716      */
4717
4718     SvGETMAGIC(source);
4719
4720     dest = TARG;
4721
4722     if (SvOK(source)) {
4723         s = (const U8*)SvPV_nomg_const(source, len);
4724     } else {
4725         if (ckWARN(WARN_UNINITIALIZED))
4726             report_uninit(source);
4727         s = (const U8*)"";
4728         len = 0;
4729     }
4730
4731     min = len + 1;
4732
4733     SvUPGRADE(dest, SVt_PV);
4734     d = (U8*)SvGROW(dest, min);
4735     (void)SvPOK_only(dest);
4736
4737     SETs(dest);
4738
4739     send = s + len;
4740
4741 #ifdef USE_LOCALE_CTYPE
4742
4743     if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
4744         _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4745     }
4746
4747 #endif
4748
4749     if (DO_UTF8(source)) { /* UTF-8 flagged string. */
4750         while (s < send) {
4751             const STRLEN u = UTF8SKIP(s);
4752             STRLEN ulen;
4753
4754             _toFOLD_utf8_flags(s, send, tmpbuf, &ulen, flags);
4755
4756             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4757                 const UV o = d - (U8*)SvPVX_const(dest);
4758                 d = o + (U8*) SvGROW(dest, min);
4759             }
4760
4761             Copy(tmpbuf, d, ulen, U8);
4762             d += ulen;
4763             s += u;
4764         }
4765         SvUTF8_on(dest);
4766     } /* Unflagged string */
4767     else if (len) {
4768 #ifdef USE_LOCALE_CTYPE
4769         if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
4770             if (IN_UTF8_CTYPE_LOCALE) {
4771                 goto do_uni_folding;
4772             }
4773             for (; s < send; d++, s++)
4774                 *d = (U8) toFOLD_LC(*s);
4775         }
4776         else
4777 #endif
4778         if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
4779             for (; s < send; d++, s++)
4780                 *d = toFOLD(*s);
4781         }
4782         else {
4783 #ifdef USE_LOCALE_CTYPE
4784       do_uni_folding:
4785 #endif
4786             /* For ASCII and the Latin-1 range, there's potentially three
4787              * troublesome folds:
4788              *      \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
4789              *             casefolding becomes 'ss';
4790              *      \x{B5} (\N{MICRO SIGN}), which under any fold becomes
4791              *             \x{3BC} (\N{GREEK SMALL LETTER MU})
4792              *      I      only in Turkic locales, this folds to \x{131}
4793              *             \N{LATIN SMALL LETTER DOTLESS I}
4794              * For the rest, the casefold is their lowercase.  */
4795             for (; s < send; d++, s++) {
4796                 if (    UNLIKELY(*s == MICRO_SIGN)
4797 #ifdef USE_LOCALE_CTYPE
4798                     || (   UNLIKELY(PL_in_utf8_turkic_locale)
4799                         && UNLIKELY(IN_LC_RUNTIME(LC_CTYPE))
4800                         && UNLIKELY(*s == 'I'))
4801 #endif
4802                 ) {
4803                     Size_t extra = send - s
4804                                  + variant_under_utf8_count(s, send);
4805
4806                     /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
4807                      * and 'I' in Turkic locales is \N{LATIN SMALL LETTER
4808                      * DOTLESS I} both of which are outside of the latin-1
4809                      * range. There's a couple of ways to deal with this -- khw
4810                      * discusses them in pp_lc/uc, so go there :) What we do
4811                      * here is upgrade what we had already casefolded, then
4812                      * enter an inner loop that appends the rest of the
4813                      * characters as UTF-8.
4814                      *
4815                      * First we calculate the needed size of the upgraded dest
4816                      * beyond what's been processed already (the upgrade
4817                      * function figures that out).  Except for the 'I' in
4818                      * Turkic locales, in UTF-8 strings, the fold case of a
4819                      * character below 256 occupies the same number of bytes as
4820                      * the original (even the Sharp S).  Therefore, the space
4821                      * needed is the number of bytes remaining plus the number
4822                      * of characters that become two bytes when converted to
4823                      * UTF-8 plus, in turkish locales, the number of 'I's */
4824
4825                     if (UNLIKELY(*s == 'I')) {
4826                         const U8 * s_peek = s;
4827
4828                         do {
4829                             extra++;
4830
4831                             s_peek = (U8 *) memchr(s_peek + 1, 'I',
4832                                                    send - (s_peek + 1));
4833                         } while (s_peek != NULL);
4834                     }
4835
4836                     /* Growing may move things, so have to save and recalculate
4837                      * 'd' */
4838                     len = d - (U8*)SvPVX_const(dest);
4839                     SvCUR_set(dest, len);
4840                     len = sv_utf8_upgrade_flags_grow(dest,
4841                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4842                                                 extra
4843                                               + 1 /* Trailing NUL */ );
4844                     d = (U8*)SvPVX(dest) + len;
4845
4846                     if (*s == 'I') {
4847                         *d++ = UTF8_TWO_BYTE_HI(LATIN_SMALL_LETTER_DOTLESS_I);
4848                         *d++ = UTF8_TWO_BYTE_LO(LATIN_SMALL_LETTER_DOTLESS_I);
4849                     }
4850                     else {
4851                         *d++ = UTF8_TWO_BYTE_HI(GREEK_SMALL_LETTER_MU);
4852                         *d++ = UTF8_TWO_BYTE_LO(GREEK_SMALL_LETTER_MU);
4853                     }
4854                     s++;
4855
4856                     for (; s < send; s++) {
4857                         STRLEN ulen;
4858                         _to_uni_fold_flags(*s, d, &ulen, flags);
4859                         d += ulen;
4860                     }
4861                     break;
4862                 }
4863                 else if (   UNLIKELY(*s == LATIN_SMALL_LETTER_SHARP_S)
4864                          && full_folding)
4865                 {
4866                     /* Under full casefolding, LATIN SMALL LETTER SHARP S
4867                      * becomes "ss", which may require growing the SV. */
4868                     if (SvLEN(dest) < ++min) {
4869                         const UV o = d - (U8*)SvPVX_const(dest);
4870                         d = o + (U8*) SvGROW(dest, min);
4871                      }
4872                     *(d)++ = 's';
4873                     *d = 's';
4874                 }
4875                 else { /* Else, the fold is the lower case */
4876                     *d = toLOWER_LATIN1(*s);
4877                 }
4878              }
4879         }
4880     }
4881     *d = '\0';
4882     SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4883
4884 #ifdef USE_LOCALE_CTYPE
4885     if (IN_LC_RUNTIME(LC_CTYPE)) {
4886         TAINT;
4887         SvTAINTED_on(dest);
4888     }
4889 #endif
4890     if (SvTAINTED(source))
4891         SvTAINT(dest);
4892     SvSETMAGIC(dest);
4893     RETURN;
4894 }
4895
4896 /* Arrays. */
4897
4898 PP(pp_aslice)
4899 {
4900     dSP; dMARK; dORIGMARK;
4901     AV *const av = MUTABLE_AV(POPs);
4902     const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4903
4904     if (SvTYPE(av) == SVt_PVAV) {
4905         const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4906         bool can_preserve = FALSE;
4907
4908         if (localizing) {
4909             MAGIC *mg;
4910             HV *stash;
4911
4912             can_preserve = SvCANEXISTDELETE(av);
4913         }
4914
4915         if (lval && localizing) {
4916             SV **svp;
4917             SSize_t max = -1;
4918             for (svp = MARK + 1; svp <= SP; svp++) {
4919                 const SSize_t elem = SvIV(*svp);
4920                 if (elem > max)
4921                     max = elem;
4922             }
4923             if (max > AvMAX(av))
4924                 av_extend(av, max);
4925         }
4926
4927         while (++MARK <= SP) {
4928             SV **svp;
4929             SSize_t elem = SvIV(*MARK);
4930             bool preeminent = TRUE;
4931
4932             if (localizing && can_preserve) {
4933                 /* If we can determine whether the element exist,
4934                  * Try to preserve the existenceness of a tied array
4935                  * element by using EXISTS and DELETE if possible.
4936                  * Fallback to FETCH and STORE otherwise. */
4937                 preeminent = av_exists(av, elem);
4938             }
4939
4940             svp = av_fetch(av, elem, lval);
4941             if (lval) {
4942                 if (!svp || !*svp)
4943                     DIE(aTHX_ PL_no_aelem, elem);
4944                 if (localizing) {
4945                     if (preeminent)
4946                         save_aelem(av, elem, svp);
4947                     else
4948                         SAVEADELETE(av, elem);
4949                 }
4950             }
4951             *MARK = svp ? *svp : &PL_sv_undef;
4952         }
4953     }
4954     if (GIMME_V != G_ARRAY) {
4955         MARK = ORIGMARK;
4956         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4957         SP = MARK;
4958     }
4959     RETURN;
4960 }
4961
4962 PP(pp_kvaslice)
4963 {
4964     dSP; dMARK;
4965     AV *const av = MUTABLE_AV(POPs);
4966     I32 lval = (PL_op->op_flags & OPf_MOD);
4967     SSize_t items = SP - MARK;
4968
4969     if (PL_op->op_private & OPpMAYBE_LVSUB) {
4970        const I32 flags = is_lvalue_sub();
4971        if (flags) {
4972            if (!(flags & OPpENTERSUB_INARGS))
4973                /* diag_listed_as: Can't modify %s in %s */
4974                Perl_croak(aTHX_ "Can't modify index/value array slice in list assignment");
4975            lval = flags;
4976        }
4977     }
4978
4979     MEXTEND(SP,items);
4980     while (items > 1) {
4981         *(MARK+items*2-1) = *(MARK+items);
4982         items--;
4983     }
4984     items = SP-MARK;
4985     SP += items;
4986
4987     while (++MARK <= SP) {
4988         SV **svp;
4989
4990         svp = av_fetch(av, SvIV(*MARK), lval);
4991         if (lval) {
4992             if (!svp || !*svp || *svp == &PL_sv_undef) {
4993                 DIE(aTHX_ PL_no_aelem, SvIV(*MARK));
4994             }
4995             *MARK = sv_mortalcopy(*MARK);
4996         }
4997         *++MARK = svp ? *svp : &PL_sv_undef;
4998     }
4999     if (GIMME_V != G_ARRAY) {
5000         MARK = SP - items*2;
5001         *++MARK = items > 0 ? *SP : &PL_sv_undef;
5002         SP = MARK;
5003     }
5004     RETURN;
5005 }
5006
5007
5008 PP(pp_aeach)
5009 {
5010     dSP;
5011     AV *array = MUTABLE_AV(POPs);
5012     const U8 gimme = GIMME_V;
5013     IV *iterp = Perl_av_iter_p(aTHX_ array);
5014     const IV current = (*iterp)++;
5015
5016     if (current > av_top_index(array)) {
5017         *iterp = 0;
5018         if (gimme == G_SCALAR)
5019             RETPUSHUNDEF;
5020         else
5021             RETURN;
5022     }
5023
5024     EXTEND(SP, 2);
5025     mPUSHi(current);
5026     if (gimme == G_ARRAY) {
5027         SV **const element = av_fetch(array, current, 0);
5028         PUSHs(element ? *element : &PL_sv_undef);
5029     }
5030     RETURN;
5031 }
5032
5033 /* also used for: pp_avalues()*/
5034 PP(pp_akeys)
5035 {
5036     dSP;
5037     AV *array = MUTABLE_AV(POPs);
5038     const U8 gimme = GIMME_V;
5039
5040     *Perl_av_iter_p(aTHX_ array) = 0;
5041
5042     if (gimme == G_SCALAR) {
5043         dTARGET;
5044         PUSHi(av_count(array));
5045     }
5046     else if (gimme == G_ARRAY) {
5047       if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
5048         const I32 flags = is_lvalue_sub();
5049         if (flags && !(flags & OPpENTERSUB_INARGS))
5050             /* diag_listed_as: Can't modify %s in %s */
5051             Perl_croak(aTHX_
5052                       "Can't modify keys on array in list assignment");
5053       }
5054       {
5055         IV n = av_top_index(array);
5056         IV i;
5057
5058         EXTEND(SP, n + 1);
5059
5060         if (  PL_op->op_type == OP_AKEYS
5061            || (  PL_op->op_type == OP_AVHVSWITCH
5062               && (PL_op->op_private & 3) + OP_AEACH == OP_AKEYS  ))
5063         {
5064             for (i = 0;  i <= n;  i++) {
5065                 mPUSHi(i);
5066             }
5067         }
5068         else {
5069             for (i = 0;  i <= n;  i++) {
5070                 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
5071                 PUSHs(elem ? *elem : &PL_sv_undef);
5072             }
5073         }
5074       }
5075     }
5076     RETURN;
5077 }
5078
5079 /* Associative arrays. */
5080
5081 PP(pp_each)
5082 {
5083     dSP;
5084     HV * hash = MUTABLE_HV(POPs);
5085     HE *entry;
5086     const U8 gimme = GIMME_V;
5087
5088     entry = hv_iternext(hash);
5089
5090     EXTEND(SP, 2);
5091     if (entry) {
5092         SV* const sv = hv_iterkeysv(entry);
5093         PUSHs(sv);
5094         if (gimme == G_ARRAY) {
5095             SV *val;
5096             val = hv_iterval(hash, entry);
5097             PUSHs(val);
5098         }
5099     }
5100     else if (gimme == G_SCALAR)
5101         RETPUSHUNDEF;
5102
5103     RETURN;
5104 }
5105
5106 STATIC OP *
5107 S_do_delete_local(pTHX)
5108 {
5109     dSP;
5110     const U8 gimme = GIMME_V;
5111     const MAGIC *mg;
5112     HV *stash;
5113     const bool sliced = !!(PL_op->op_private & OPpSLICE);
5114     SV **unsliced_keysv = sliced ? NULL : sp--;
5115     SV * const osv = POPs;
5116     SV **mark = sliced ? PL_stack_base + POPMARK : unsliced_keysv-1;
5117     dORIGMARK;
5118     const bool tied = SvRMAGICAL(osv)
5119                             && mg_find((const SV *)osv, PERL_MAGIC_tied);
5120     const bool can_preserve = SvCANEXISTDELETE(osv);
5121     const U32 type = SvTYPE(osv);
5122     SV ** const end = sliced ? SP : unsliced_keysv;
5123
5124     if (type == SVt_PVHV) {                     /* hash element */
5125             HV * const hv = MUTABLE_HV(osv);
5126             while (++MARK <= end) {
5127                 SV * const keysv = *MARK;
5128                 SV *sv = NULL;
5129                 bool preeminent = TRUE;
5130                 if (can_preserve)
5131                     preeminent = hv_exists_ent(hv, keysv, 0);
5132                 if (tied) {
5133                     HE *he = hv_fetch_ent(hv, keysv, 1, 0);
5134                     if (he)
5135                         sv = HeVAL(he);
5136                     else
5137                         preeminent = FALSE;
5138                 }
5139                 else {
5140                     sv = hv_delete_ent(hv, keysv, 0, 0);
5141                     if (preeminent)
5142                         SvREFCNT_inc_simple_void(sv); /* De-mortalize */
5143                 }
5144                 if (preeminent) {
5145                     if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5146                     save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
5147                     if (tied) {
5148                         *MARK = sv_mortalcopy(sv);
5149                         mg_clear(sv);
5150                     } else
5151                         *MARK = sv;
5152                 }
5153                 else {
5154                     SAVEHDELETE(hv, keysv);
5155                     *MARK = &PL_sv_undef;
5156                 }
5157             }
5158     }
5159     else if (type == SVt_PVAV) {                  /* array element */
5160             if (PL_op->op_flags & OPf_SPECIAL) {
5161                 AV * const av = MUTABLE_AV(osv);
5162                 while (++MARK <= end) {
5163                     SSize_t idx = SvIV(*MARK);
5164                     SV *sv = NULL;
5165                     bool preeminent = TRUE;
5166                     if (can_preserve)
5167                         preeminent = av_exists(av, idx);
5168                     if (tied) {
5169                         SV **svp = av_fetch(av, idx, 1);
5170                         if (svp)
5171                             sv = *svp;
5172                         else
5173                             preeminent = FALSE;
5174                     }
5175                     else {
5176                         sv = av_delete(av, idx, 0);
5177                         if (preeminent)
5178                            SvREFCNT_inc_simple_void(sv); /* De-mortalize */
5179                     }
5180                     if (preeminent) {
5181                         save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
5182                         if (tied) {
5183                             *MARK = sv_mortalcopy(sv);
5184                             mg_clear(sv);
5185                         } else
5186                             *MARK = sv;
5187                     }
5188                     else {
5189                         SAVEADELETE(av, idx);
5190                         *MARK = &PL_sv_undef;
5191                     }
5192                 }
5193             }
5194             else
5195                 DIE(aTHX_ "panic: avhv_delete no longer supported");
5196     }
5197     else
5198             DIE(aTHX_ "Not a HASH reference");
5199     if (sliced) {
5200         if (gimme == G_VOID)
5201             SP = ORIGMARK;
5202         else if (gimme == G_SCALAR) {
5203             MARK = ORIGMARK;
5204             if (SP > MARK)
5205                 *++MARK = *SP;
5206             else
5207                 *++MARK = &PL_sv_undef;
5208             SP = MARK;
5209         }
5210     }
5211     else if (gimme != G_VOID)
5212         PUSHs(*unsliced_keysv);
5213
5214     RETURN;
5215 }
5216
5217 PP(pp_delete)
5218 {
5219     dSP;
5220     U8 gimme;
5221     I32 discard;
5222
5223     if (PL_op->op_private & OPpLVAL_INTRO)
5224         return do_delete_local();
5225
5226     gimme = GIMME_V;
5227     discard = (gimme == G_VOID) ? G_DISCARD : 0;
5228
5229     if (PL_op->op_private & (OPpSLICE|OPpKVSLICE)) {
5230         dMARK; dORIGMARK;
5231         HV * const hv = MUTABLE_HV(POPs);
5232         const U32 hvtype = SvTYPE(hv);
5233         int skip = 0;
5234         if (PL_op->op_private & OPpKVSLICE) {
5235             SSize_t items = SP - MARK;
5236
5237             MEXTEND(SP,items);
5238             while (items > 1) {
5239                 *(MARK+items*2-1) = *(MARK+items);
5240                 items--;
5241             }
5242             items = SP - MARK;
5243             SP += items;
5244             skip = 1;
5245         }
5246         if (hvtype == SVt_PVHV) {                       /* hash element */
5247             while ((MARK += (1+skip)) <= SP) {
5248                 SV * const sv = hv_delete_ent(hv, *(MARK-skip), discard, 0);
5249                 *MARK = sv ? sv : &PL_sv_undef;
5250             }
5251         }
5252         else if (hvtype == SVt_PVAV) {                  /* array element */
5253             if (PL_op->op_flags & OPf_SPECIAL) {
5254                 while ((MARK += (1+skip)) <= SP) {
5255                     SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*(MARK-skip)), discard);
5256                     *MARK = sv ? sv : &PL_sv_undef;
5257                 }
5258             }
5259         }
5260         else
5261             DIE(aTHX_ "Not a HASH reference");
5262         if (discard)
5263             SP = ORIGMARK;
5264         else if (gimme == G_SCALAR) {
5265             MARK = ORIGMARK;
5266             if (SP > MARK)
5267                 *++MARK = *SP;
5268             else
5269                 *++MARK = &PL_sv_undef;
5270             SP = MARK;
5271         }
5272     }
5273     else {
5274         SV *keysv = POPs;
5275         HV * const hv = MUTABLE_HV(POPs);
5276         SV *sv = NULL;
5277         if (SvTYPE(hv) == SVt_PVHV)
5278             sv = hv_delete_ent(hv, keysv, discard, 0);
5279         else if (SvTYPE(hv) == SVt_PVAV) {
5280             if (PL_op->op_flags & OPf_SPECIAL)
5281                 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
5282             else
5283                 DIE(aTHX_ "panic: avhv_delete no longer supported");
5284         }
5285         else
5286             DIE(aTHX_ "Not a HASH reference");
5287         if (!sv)
5288             sv = &PL_sv_undef;
5289         if (!discard)
5290             PUSHs(sv);
5291     }
5292     RETURN;
5293 }
5294
5295 PP(pp_exists)
5296 {
5297     dSP;
5298     SV *tmpsv;
5299     HV *hv;
5300
5301     if (UNLIKELY( PL_op->op_private & OPpEXISTS_SUB )) {
5302         GV *gv;
5303         SV * const sv = POPs;
5304         CV * const cv = sv_2cv(sv, &hv, &gv, 0);
5305         if (cv)
5306             RETPUSHYES;
5307         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
5308             RETPUSHYES;
5309         RETPUSHNO;
5310     }
5311     tmpsv = POPs;
5312     hv = MUTABLE_HV(POPs);
5313     if (LIKELY( SvTYPE(hv) == SVt_PVHV )) {
5314         if (hv_exists_ent(hv, tmpsv, 0))
5315             RETPUSHYES;
5316     }
5317     else if (SvTYPE(hv) == SVt_PVAV) {
5318         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
5319             if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
5320                 RETPUSHYES;
5321         }
5322     }
5323     else {
5324         DIE(aTHX_ "Not a HASH reference");
5325     }
5326     RETPUSHNO;
5327 }
5328
5329 PP(pp_hslice)
5330 {
5331     dSP; dMARK; dORIGMARK;
5332     HV * const hv = MUTABLE_HV(POPs);
5333     const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
5334     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
5335     bool can_preserve = FALSE;
5336
5337     if (localizing) {
5338         MAGIC *mg;
5339         HV *stash;
5340
5341         if (SvCANEXISTDELETE(hv))
5342             can_preserve = TRUE;
5343     }
5344
5345     while (++MARK <= SP) {
5346         SV * const keysv = *MARK;
5347         SV **svp;
5348         HE *he;
5349         bool preeminent = TRUE;
5350
5351         if (localizing && can_preserve) {
5352             /* If we can determine whether the element exist,
5353              * try to preserve the existenceness of a tied hash
5354              * element by using EXISTS and DELETE if possible.
5355              * Fallback to FETCH and STORE otherwise. */
5356             preeminent = hv_exists_ent(hv, keysv, 0);
5357         }
5358
5359         he = hv_fetch_ent(hv, keysv, lval, 0);
5360         svp = he ? &HeVAL(he) : NULL;
5361
5362         if (lval) {
5363             if (!svp || !*svp || *svp == &PL_sv_undef) {
5364                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5365             }
5366             if (localizing) {
5367                 if (HvNAME_get(hv) && isGV_or_RVCV(*svp))
5368                     save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
5369                 else if (preeminent)
5370                     save_helem_flags(hv, keysv, svp,
5371                          (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
5372                 else
5373                     SAVEHDELETE(hv, keysv);
5374             }
5375         }
5376         *MARK = svp && *svp ? *svp : &PL_sv_undef;
5377     }
5378     if (GIMME_V != G_ARRAY) {
5379         MARK = ORIGMARK;
5380         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
5381         SP = MARK;
5382     }
5383     RETURN;
5384 }
5385
5386 PP(pp_kvhslice)
5387 {
5388     dSP; dMARK;
5389     HV * const hv = MUTABLE_HV(POPs);
5390     I32 lval = (PL_op->op_flags & OPf_MOD);
5391     SSize_t items = SP - MARK;
5392
5393     if (PL_op->op_private & OPpMAYBE_LVSUB) {
5394        const I32 flags = is_lvalue_sub();
5395        if (flags) {
5396            if (!(flags & OPpENTERSUB_INARGS))
5397                /* diag_listed_as: Can't modify %s in %s */
5398                Perl_croak(aTHX_ "Can't modify key/value hash slice in %s assignment",
5399                                  GIMME_V == G_ARRAY ? "list" : "scalar");
5400            lval = flags;
5401        }
5402     }
5403
5404     MEXTEND(SP,items);
5405     while (items > 1) {
5406         *(MARK+items*2-1) = *(MARK+items);
5407         items--;
5408     }
5409     items = SP-MARK;
5410     SP += items;
5411
5412     while (++MARK <= SP) {
5413         SV * const keysv = *MARK;
5414         SV **svp;
5415         HE *he;
5416
5417         he = hv_fetch_ent(hv, keysv, lval, 0);
5418         svp = he ? &HeVAL(he) : NULL;
5419
5420         if (lval) {
5421             if (!svp || !*svp || *svp == &PL_sv_undef) {
5422                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5423             }
5424             *MARK = sv_mortalcopy(*MARK);
5425         }
5426         *++MARK = svp && *svp ? *svp : &PL_sv_undef;
5427     }
5428     if (GIMME_V != G_ARRAY) {
5429         MARK = SP - items*2;
5430         *++MARK = items > 0 ? *SP : &PL_sv_undef;
5431         SP = MARK;
5432     }
5433     RETURN;
5434 }
5435
5436 /* List operators. */
5437
5438 PP(pp_list)
5439 {
5440     I32 markidx = POPMARK;
5441     if (GIMME_V != G_ARRAY) {
5442         /* don't initialize mark here, EXTEND() may move the stack */
5443         SV **mark;
5444         dSP;
5445         EXTEND(SP, 1);          /* in case no arguments, as in @empty */
5446         mark = PL_stack_base + markidx;
5447         if (++MARK <= SP)
5448             *MARK = *SP;                /* unwanted list, return last item */
5449         else
5450             *MARK = &PL_sv_undef;
5451         SP = MARK;
5452         PUTBACK;
5453     }
5454     return NORMAL;
5455 }
5456
5457 PP(pp_lslice)
5458 {
5459     dSP;
5460     SV ** const lastrelem = PL_stack_sp;
5461     SV ** const lastlelem = PL_stack_base + POPMARK;
5462     SV ** const firstlelem = PL_stack_base + POPMARK + 1;
5463     SV ** const firstrelem = lastlelem + 1;
5464     const U8 mod = PL_op->op_flags & OPf_MOD;
5465
5466     const I32 max = lastrelem - lastlelem;
5467     SV **lelem;
5468
5469     if (GIMME_V != G_ARRAY) {
5470         if (lastlelem < firstlelem) {
5471             EXTEND(SP, 1);
5472             *firstlelem = &PL_sv_undef;
5473         }
5474         else {
5475             I32 ix = SvIV(*lastlelem);
5476             if (ix < 0)
5477                 ix += max;
5478             if (ix < 0 || ix >= max)
5479                 *firstlelem = &PL_sv_undef;
5480             else
5481                 *firstlelem = firstrelem[ix];
5482         }
5483         SP = firstlelem;
5484         RETURN;
5485     }
5486
5487     if (max == 0) {
5488         SP = firstlelem - 1;
5489         RETURN;
5490     }
5491
5492     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
5493         I32 ix = SvIV(*lelem);
5494         if (ix < 0)
5495             ix += max;
5496         if (ix < 0 || ix >= max)
5497             *lelem = &PL_sv_undef;
5498         else {
5499             if (!(*lelem = firstrelem[ix]))
5500                 *lelem = &PL_sv_undef;
5501             else if (mod && SvPADTMP(*lelem)) {
5502                 *lelem = firstrelem[ix] = sv_mortalcopy(*lelem);
5503             }
5504         }
5505     }
5506     SP = lastlelem;
5507     RETURN;
5508 }
5509
5510 PP(pp_anonlist)
5511 {
5512     dSP; dMARK;
5513     const I32 items = SP - MARK;
5514     SV * const av = MUTABLE_SV(av_make(items, MARK+1));
5515     SP = MARK;
5516     mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5517             ? newRV_noinc(av) : av);
5518     RETURN;
5519 }
5520
5521 PP(pp_anonhash)
5522 {
5523     dSP; dMARK; dORIGMARK;
5524     HV* const hv = newHV();
5525     SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL
5526                                     ? newRV_noinc(MUTABLE_SV(hv))
5527                                     : MUTABLE_SV(hv) );
5528
5529     while (MARK < SP) {
5530         SV * const key =
5531             (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK);
5532         SV *val;
5533         if (MARK < SP)
5534         {
5535             MARK++;
5536             SvGETMAGIC(*MARK);
5537             val = newSV(0);
5538             sv_setsv_nomg(val, *MARK);
5539         }
5540         else
5541         {
5542             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
5543             val = newSV(0);
5544         }
5545         (void)hv_store_ent(hv,key,val,0);
5546     }
5547     SP = ORIGMARK;
5548     XPUSHs(retval);
5549     RETURN;
5550 }
5551
5552 PP(pp_splice)
5553 {
5554     dSP; dMARK; dORIGMARK;
5555     int num_args = (SP - MARK);
5556     AV *ary = MUTABLE_AV(*++MARK);
5557     SV **src;
5558     SV **dst;
5559     SSize_t i;
5560     SSize_t offset;
5561     SSize_t length;
5562     SSize_t newlen;
5563     SSize_t after;
5564     SSize_t diff;
5565     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5566
5567     if (mg) {
5568         return Perl_tied_method(aTHX_ SV_CONST(SPLICE), mark - 1, MUTABLE_SV(ary), mg,
5569                                     GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
5570                                     sp - mark);
5571     }
5572
5573     if (SvREADONLY(ary))
5574         Perl_croak_no_modify();
5575
5576     SP++;
5577
5578     if (++MARK < SP) {
5579         offset = i = SvIV(*MARK);
5580         if (offset < 0)
5581             offset += AvFILLp(ary) + 1;
5582         if (offset < 0)
5583             DIE(aTHX_ PL_no_aelem, i);
5584         if (++MARK < SP) {
5585             length = SvIVx(*MARK++);
5586             if (length < 0) {
5587                 length += AvFILLp(ary) - offset + 1;
5588                 if (length < 0)
5589                     length = 0;
5590             }
5591         }
5592         else
5593             length = AvMAX(ary) + 1;            /* close enough to infinity */
5594     }
5595     else {
5596         offset = 0;
5597         length = AvMAX(ary) + 1;
5598     }
5599     if (offset > AvFILLp(ary) + 1) {
5600         if (num_args > 2)
5601             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
5602         offset = AvFILLp(ary) + 1;
5603     }
5604     after = AvFILLp(ary) + 1 - (offset + length);
5605     if (after < 0) {                            /* not that much array */
5606         length += after;                        /* offset+length now in array */
5607         after = 0;
5608         if (!AvALLOC(ary))
5609             av_extend(ary, 0);
5610     }
5611
5612     /* At this point, MARK .. SP-1 is our new LIST */
5613
5614     newlen = SP - MARK;
5615     diff = newlen - length;
5616     if (newlen && !AvREAL(ary) && AvREIFY(ary))
5617         av_reify(ary);
5618
5619     /* make new elements SVs now: avoid problems if they're from the array */
5620     for (dst = MARK, i = newlen; i; i--) {
5621         SV * const h = *dst;
5622         *dst++ = newSVsv(h);
5623     }
5624
5625     if (diff < 0) {                             /* shrinking the area */
5626         SV **tmparyval = NULL;
5627         if (newlen) {
5628             Newx(tmparyval, newlen, SV*);       /* so remember insertion */
5629             Copy(MARK, tmparyval, newlen, SV*);
5630         }
5631
5632         MARK = ORIGMARK + 1;
5633         if (GIMME_V == G_ARRAY) {               /* copy return vals to stack */
5634             const bool real = cBOOL(AvREAL(ary));
5635             MEXTEND(MARK, length);
5636             if (real)
5637                 EXTEND_MORTAL(length);
5638             for (i = 0, dst = MARK; i < length; i++) {
5639                 if ((*dst = AvARRAY(ary)[i+offset])) {
5640                   if (real)
5641                     sv_2mortal(*dst);   /* free them eventually */
5642                 }
5643                 else
5644                     *dst = &PL_sv_undef;
5645                 dst++;
5646             }
5647             MARK += length - 1;
5648         }
5649         else {
5650             *MARK = AvARRAY(ary)[offset+length-1];
5651             if (AvREAL(ary)) {
5652                 sv_2mortal(*MARK);
5653                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5654                     SvREFCNT_dec(*dst++);       /* free them now */
5655             }
5656             if (!*MARK)
5657                 *MARK = &PL_sv_undef;
5658         }
5659         AvFILLp(ary) += diff;
5660
5661         /* pull up or down? */
5662
5663         if (offset < after) {                   /* easier to pull up */
5664             if (offset) {                       /* esp. if nothing to pull */
5665                 src = &AvARRAY(ary)[offset-1];
5666                 dst = src - diff;               /* diff is negative */
5667                 for (i = offset; i > 0; i--)    /* can't trust Copy */
5668                     *dst-- = *src--;
5669             }
5670             dst = AvARRAY(ary);
5671             AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5672             AvMAX(ary) += diff;
5673         }
5674         else {
5675             if (after) {                        /* anything to pull down? */
5676                 src = AvARRAY(ary) + offset + length;
5677                 dst = src + diff;               /* diff is negative */
5678                 Move(src, dst, after, SV*);
5679             }
5680             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5681                                                 /* avoid later double free */
5682         }
5683         i = -diff;
5684         while (i)
5685             dst[--i] = NULL;
5686
5687         if (newlen) {
5688             Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5689             Safefree(tmparyval);
5690         }
5691     }
5692     else {                                      /* no, expanding (or same) */
5693         SV** tmparyval = NULL;
5694         if (length) {
5695             Newx(tmparyval, length, SV*);       /* so remember deletion */
5696             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5697         }
5698
5699         if (diff > 0) {                         /* expanding */
5700             /* push up or down? */
5701             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5702                 if (offset) {
5703                     src = AvARRAY(ary);
5704                     dst = src - diff;
5705                     Move(src, dst, offset, SV*);
5706                 }
5707                 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5708                 AvMAX(ary) += diff;
5709                 AvFILLp(ary) += diff;
5710             }
5711             else {
5712                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
5713                     av_extend(ary, AvFILLp(ary) + diff);
5714                 AvFILLp(ary) += diff;
5715
5716                 if (after) {
5717                     dst = AvARRAY(ary) + AvFILLp(ary);
5718                     src = dst - diff;
5719                     for (i = after; i; i--) {
5720                         *dst-- = *src--;
5721                     }
5722                 }
5723             }
5724         }
5725
5726         if (newlen) {
5727             Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5728         }
5729
5730         MARK = ORIGMARK + 1;
5731         if (GIMME_V == G_ARRAY) {               /* copy return vals to stack */
5732             if (length) {
5733                 const bool real = cBOOL(AvREAL(ary));
5734                 if (real)
5735                     EXTEND_MORTAL(length);
5736                 for (i = 0, dst = MARK; i < length; i++) {
5737                     if ((*dst = tmparyval[i])) {
5738                       if (real)
5739                         sv_2mortal(*dst);       /* free them eventually */
5740                     }
5741                     else *dst = &PL_sv_undef;
5742                     dst++;
5743                 }
5744             }
5745             MARK += length - 1;
5746         }
5747         else if (length--) {
5748             *MARK = tmparyval[length];
5749             if (AvREAL(ary)) {
5750                 sv_2mortal(*MARK);
5751                 while (length-- > 0)
5752                     SvREFCNT_dec(tmparyval[length]);
5753             }
5754             if (!*MARK)
5755                 *MARK = &PL_sv_undef;
5756         }
5757         else
5758             *MARK = &PL_sv_undef;
5759         Safefree(tmparyval);
5760     }
5761
5762     if (SvMAGICAL(ary))
5763         mg_set(MUTABLE_SV(ary));
5764
5765     SP = MARK;
5766     RETURN;
5767 }
5768
5769 PP(pp_push)
5770 {
5771     dSP; dMARK; dORIGMARK; dTARGET;
5772     AV * const ary = MUTABLE_AV(*++MARK);
5773     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5774
5775     if (mg) {
5776         *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5777         PUSHMARK(MARK);
5778         PUTBACK;
5779         ENTER_with_name("call_PUSH");
5780         call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5781         LEAVE_with_name("call_PUSH");
5782         /* SPAGAIN; not needed: SP is assigned to immediately below */
5783     }
5784     else {
5785         /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
5786          * only need to save locally, not on the save stack */
5787         U16 old_delaymagic = PL_delaymagic;
5788
5789         if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify();
5790         PL_delaymagic = DM_DELAY;
5791         for (++MARK; MARK <= SP; MARK++) {
5792             SV *sv;
5793             if (*MARK) SvGETMAGIC(*MARK);
5794             sv = newSV(0);
5795             if (*MARK)
5796                 sv_setsv_nomg(sv, *MARK);
5797             av_store(ary, AvFILLp(ary)+1, sv);
5798         }
5799         if (PL_delaymagic & DM_ARRAY_ISA)
5800             mg_set(MUTABLE_SV(ary));
5801         PL_delaymagic = old_delaymagic;
5802     }
5803     SP = ORIGMARK;
5804     if (OP_GIMME(PL_op, 0) != G_VOID) {
5805         PUSHi( AvFILL(ary) + 1 );
5806     }
5807     RETURN;
5808 }
5809
5810 /* also used for: pp_pop()*/
5811 PP(pp_shift)
5812 {
5813     dSP;
5814     AV * const av = PL_op->op_flags & OPf_SPECIAL
5815         ? MUTABLE_AV(GvAVn(PL_defgv)) : MUTABLE_AV(POPs);
5816     SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5817     EXTEND(SP, 1);
5818     assert (sv);
5819     if (AvREAL(av))
5820         (void)sv_2mortal(sv);
5821     PUSHs(sv);
5822     RETURN;
5823 }
5824
5825 PP(pp_unshift)
5826 {
5827     dSP; dMARK; dORIGMARK; dTARGET;
5828     AV *ary = MUTABLE_AV(*++MARK);
5829     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5830
5831     if (mg) {
5832         *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5833         PUSHMARK(MARK);
5834         PUTBACK;
5835         ENTER_with_name("call_UNSHIFT");
5836         call_sv(SV_CONST(UNSHIFT),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5837         LEAVE_with_name("call_UNSHIFT");
5838         /* SPAGAIN; not needed: SP is assigned to immediately below */
5839     }
5840     else {
5841         /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
5842          * only need to save locally, not on the save stack */
5843         U16 old_delaymagic = PL_delaymagic;
5844         SSize_t i = 0;
5845
5846         av_unshift(ary, SP - MARK);
5847         PL_delaymagic = DM_DELAY;
5848         while (MARK < SP) {
5849             SV * const sv = newSVsv(*++MARK);
5850             (void)av_store(ary, i++, sv);
5851         }
5852         if (PL_delaymagic & DM_ARRAY_ISA)
5853             mg_set(MUTABLE_SV(ary));
5854         PL_delaymagic = old_delaymagic;
5855     }
5856     SP = ORIGMARK;
5857     if (OP_GIMME(PL_op, 0) != G_VOID) {
5858         PUSHi( AvFILL(ary) + 1 );
5859     }
5860     RETURN;
5861 }
5862
5863 PP(pp_reverse)
5864 {
5865     dSP; dMARK;
5866
5867     if (GIMME_V == G_ARRAY) {
5868         if (PL_op->op_private & OPpREVERSE_INPLACE) {
5869             AV *av;
5870
5871             /* See pp_sort() */
5872             assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5873             (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5874             av = MUTABLE_AV((*SP));
5875             /* In-place reversing only happens in void context for the array
5876              * assignment. We don't need to push anything on the stack. */
5877             SP = MARK;
5878
5879             if (SvMAGICAL(av)) {
5880                 SSize_t i, j;
5881                 SV *tmp = sv_newmortal();
5882                 /* For SvCANEXISTDELETE */
5883                 HV *stash;
5884                 const MAGIC *mg;
5885                 bool can_preserve = SvCANEXISTDELETE(av);
5886
5887                 for (i = 0, j = av_top_index(av); i < j; ++i, --j) {
5888                     SV *begin, *end;
5889
5890                     if (can_preserve) {
5891                         if (!av_exists(av, i)) {
5892                             if (av_exists(av, j)) {
5893                                 SV *sv = av_delete(av, j, 0);
5894                                 begin = *av_fetch(av, i, TRUE);
5895                                 sv_setsv_mg(begin, sv);
5896                             }
5897                             continue;
5898                         }
5899                         else if (!av_exists(av, j)) {
5900                             SV *sv = av_delete(av, i, 0);
5901                             end = *av_fetch(av, j, TRUE);
5902                             sv_setsv_mg(end, sv);
5903                             continue;
5904                         }
5905                     }
5906
5907                     begin = *av_fetch(av, i, TRUE);
5908                     end   = *av_fetch(av, j, TRUE);
5909                     sv_setsv(tmp,      begin);
5910                     sv_setsv_mg(begin, end);
5911                     sv_setsv_mg(end,   tmp);
5912                 }
5913             }
5914             else {
5915                 SV **begin = AvARRAY(av);
5916
5917                 if (begin) {
5918                     SV **end   = begin + AvFILLp(av);
5919
5920                     while (begin < end) {
5921                         SV * const tmp = *begin;
5922                         *begin++ = *end;
5923                         *end--   = tmp;
5924                     }
5925                 }
5926             }
5927         }
5928         else {
5929             SV **oldsp = SP;
5930             MARK++;
5931             while (MARK < SP) {
5932                 SV * const tmp = *MARK;
5933                 *MARK++ = *SP;
5934                 *SP--   = tmp;
5935             }
5936             /* safe as long as stack cannot get extended in the above */
5937             SP = oldsp;
5938         }
5939     }
5940     else {
5941         char *up;
5942         dTARGET;
5943         STRLEN len;
5944
5945         SvUTF8_off(TARG);                               /* decontaminate */
5946         if (SP - MARK > 1) {
5947             do_join(TARG, &PL_sv_no, MARK, SP);
5948             SP = MARK + 1;
5949             SETs(TARG);
5950         } else if (SP > MARK) {
5951             sv_setsv(TARG, *SP);
5952             SETs(TARG);
5953         } else {
5954             sv_setsv(TARG, DEFSV);
5955             XPUSHs(TARG);
5956         }
5957         SvSETMAGIC(TARG); /* remove any utf8 length magic */
5958
5959         up = SvPV_force(TARG, len);
5960         if (len > 1) {
5961             char *down;
5962             if (DO_UTF8(TARG)) {        /* first reverse each character */
5963                 U8* s = (U8*)SvPVX(TARG);
5964                 const U8* send = (U8*)(s + len);
5965                 while (s < send) {
5966                     if (UTF8_IS_INVARIANT(*s)) {
5967                         s++;
5968                         continue;
5969                     }
5970                     else {
5971                         if (!utf8_to_uvchr_buf(s, send, 0))
5972                             break;
5973                         up = (char*)s;
5974                         s += UTF8SKIP(s);
5975                         down = (char*)(s - 1);
5976                         /* reverse this character */
5977                         while (down > up) {
5978                             const char tmp = *up;
5979                             *up++ = *down;
5980                             *down-- = tmp;
5981                         }
5982                     }
5983                 }
5984                 up = SvPVX(TARG);
5985             }
5986             down = SvPVX(TARG) + len - 1;
5987             while (down > up) {
5988                 const char tmp = *up;
5989                 *up++ = *down;
5990                 *down-- = tmp;
5991             }
5992             (void)SvPOK_only_UTF8(TARG);
5993         }
5994     }
5995     RETURN;
5996 }
5997
5998 PP(pp_split)
5999 {
6000     dSP; dTARG;
6001     AV *ary = (   (PL_op->op_private & OPpSPLIT_ASSIGN) /* @a = split */
6002                && (PL_op->op_flags & OPf_STACKED))      /* @{expr} = split */
6003                ? (AV *)POPs : NULL;
6004     IV limit = POPi;                    /* note, negative is forever */
6005     SV * const sv = POPs;
6006     STRLEN len;
6007     const char *s = SvPV_const(sv, len);
6008     const bool do_utf8 = DO_UTF8(sv);
6009     const bool in_uni_8_bit = IN_UNI_8_BIT;
6010     const char *strend = s + len;
6011     PMOP *pm = cPMOPx(PL_op);
6012     REGEXP *rx;
6013     SV *dstr;
6014     const char *m;
6015     SSize_t iters = 0;
6016     const STRLEN slen = do_utf8
6017                         ? utf8_length((U8*)s, (U8*)strend)
6018                         : (STRLEN)(strend - s);
6019     SSize_t maxiters = slen + 10;
6020     I32 trailing_empty = 0;
6021     const char *orig;
6022     const IV origlimit = limit;
6023     bool realarray = 0;
6024     I32 base;
6025     const U8 gimme = GIMME_V;
6026     bool gimme_scalar;
6027     I32 oldsave = PL_savestack_ix;
6028     U32 flags = (do_utf8 ? SVf_UTF8 : 0) |
6029          SVs_TEMP; /* Make mortal SVs by default */
6030     MAGIC *mg = NULL;
6031
6032     rx = PM_GETRE(pm);
6033
6034     TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
6035              (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
6036
6037     /* handle @ary = split(...) optimisation */
6038     if (PL_op->op_private & OPpSPLIT_ASSIGN) {
6039         realarray = 1;
6040         if (!(PL_op->op_flags & OPf_STACKED)) {
6041             if (PL_op->op_private & OPpSPLIT_LEX) {
6042                 if (PL_op->op_private & OPpLVAL_INTRO)
6043                     SAVECLEARSV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff));
6044                 ary = (AV *)PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff);
6045             }
6046             else {
6047                 GV *gv =
6048 #ifdef USE_ITHREADS
6049                         MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff));
6050 #else
6051                         pm->op_pmreplrootu.op_pmtargetgv;
6052 #endif
6053                 if (PL_op->op_private & OPpLVAL_INTRO)
6054                     ary = save_ary(gv);
6055                 else
6056                     ary = GvAVn(gv);
6057             }
6058             /* skip anything pushed by OPpLVAL_INTRO above */
6059             oldsave = PL_savestack_ix;
6060         }
6061
6062         /* Some defence against stack-not-refcounted bugs */
6063         (void)sv_2mortal(SvREFCNT_inc_simple_NN(ary));
6064
6065         if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
6066             PUSHMARK(SP);
6067             XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
6068         } else {
6069             flags &= ~SVs_TEMP; /* SVs will not be mortal */
6070         }
6071     }
6072
6073     base = SP - PL_stack_base;
6074     orig = s;
6075     if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
6076         if (do_utf8) {
6077             while (s < strend && isSPACE_utf8_safe(s, strend))
6078                 s += UTF8SKIP(s);
6079         }
6080         else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
6081             while (s < strend && isSPACE_LC(*s))
6082                 s++;
6083         }
6084         else if (in_uni_8_bit) {
6085             while (s < strend && isSPACE_L1(*s))
6086                 s++;
6087         }
6088         else {
6089             while (s < strend && isSPACE(*s))
6090                 s++;
6091         }
6092     }
6093
6094     gimme_scalar = gimme == G_SCALAR && !ary;
6095
6096     if (!limit)
6097         limit = maxiters + 2;
6098     if (RX_EXTFLAGS(rx) & RXf_WHITE) {
6099         while (--limit) {
6100             m = s;
6101             /* this one uses 'm' and is a negative test */
6102             if (do_utf8) {
6103                 while (m < strend && ! isSPACE_utf8_safe(m, strend) ) {
6104                     const int t = UTF8SKIP(m);
6105                     /* isSPACE_utf8_safe returns FALSE for malform utf8 */
6106                     if (strend - m < t)
6107                         m = strend;
6108                     else
6109                         m += t;
6110                 }
6111             }
6112             else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
6113             {
6114                 while (m < strend && !isSPACE_LC(*m))
6115                     ++m;
6116             }
6117             else if (in_uni_8_bit) {
6118                 while (m < strend && !isSPACE_L1(*m))
6119                     ++m;
6120             } else {
6121                 while (m < strend && !isSPACE(*m))
6122                     ++m;
6123             }
6124             if (m >= strend)
6125                 break;
6126
6127             if (gimme_scalar) {
6128                 iters++;
6129                 if (m-s == 0)
6130                     trailing_empty++;
6131                 else
6132                     trailing_empty = 0;
6133             } else {
6134                 dstr = newSVpvn_flags(s, m-s, flags);
6135                 XPUSHs(dstr);
6136             }
6137
6138             /* skip the whitespace found last */
6139             if (do_utf8)
6140                 s = m + UTF8SKIP(m);
6141             else
6142                 s = m + 1;
6143
6144             /* this one uses 's' and is a positive test */
6145             if (do_utf8) {
6146                 while (s < strend && isSPACE_utf8_safe(s, strend) )
6147                     s +=  UTF8SKIP(s);
6148             }
6149             else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
6150             {
6151                 while (s < strend && isSPACE_LC(*s))
6152                     ++s;
6153             }
6154             else if (in_uni_8_bit) {
6155                 while (s < strend && isSPACE_L1(*s))
6156                     ++s;
6157             } else {
6158                 while (s < strend && isSPACE(*s))
6159                     ++s;
6160             }
6161         }
6162     }
6163     else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
6164         while (--limit) {
6165             for (m = s; m < strend && *m != '\n'; m++)
6166                 ;
6167             m++;
6168             if (m >= strend)
6169                 break;
6170
6171             if (gimme_scalar) {
6172                 iters++;
6173                 if (m-s == 0)
6174                     trailing_empty++;
6175                 else
6176                     trailing_empty = 0;
6177             } else {
6178                 dstr = newSVpvn_flags(s, m-s, flags);
6179                 XPUSHs(dstr);
6180             }
6181             s = m;
6182         }
6183     }
6184     else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
6185         /* This case boils down to deciding which is the smaller of:
6186          * limit - effectively a number of characters
6187          * slen - which already contains the number of characters in s
6188          *
6189          * The resulting number is the number of iters (for gimme_scalar)
6190          * or the number of SVs to create (!gimme_scalar). */
6191
6192         /* setting it to -1 will trigger a panic in EXTEND() */
6193         const SSize_t sslen = slen > SSize_t_MAX ?  -1 : (SSize_t)slen;
6194         const IV items = limit - 1;
6195         if (sslen < items || items < 0) {
6196             iters = slen -1;
6197             limit = slen + 1;
6198             /* Note: The same result is returned if the following block
6199              * is removed, because of the "keep field after final delim?"
6200              * adjustment, but having the following makes the "correct"
6201              * behaviour more apparent. */
6202             if (gimme_scalar) {
6203                 s = strend;
6204                 iters++;
6205             }
6206         } else {
6207             iters = items;
6208         }
6209         if (!gimme_scalar) {
6210             /*
6211               Pre-extend the stack, either the number of bytes or
6212               characters in the string or a limited amount, triggered by:
6213               my ($x, $y) = split //, $str;
6214                 or
6215               split //, $str, $i;
6216             */
6217             EXTEND(SP, limit);
6218             if (do_utf8) {
6219                 while (--limit) {
6220                     m = s;
6221                     s += UTF8SKIP(s);
6222                     dstr = newSVpvn_flags(m, s-m, flags);
6223                     PUSHs(dstr);
6224                 }
6225             } else {
6226                 while (--limit) {
6227                     dstr = newSVpvn_flags(s, 1, flags);
6228                     PUSHs(dstr);
6229                     s++;
6230                 }
6231             }
6232         }
6233     }
6234     else if (do_utf8 == (RX_UTF8(rx) != 0) &&
6235              (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
6236              && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
6237              && !(RX_EXTFLAGS(rx) & RXf_IS_ANCHORED)) {
6238         const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
6239         SV * const csv = CALLREG_INTUIT_STRING(rx);
6240
6241         len = RX_MINLENRET(rx);
6242         if (len == 1 && !RX_UTF8(rx) && !tail) {
6243             const char c = *SvPV_nolen_const(csv);
6244             while (--limit) {
6245                 for (m = s; m < strend && *m != c; m++)
6246                     ;
6247                 if (m >= strend)
6248                     break;
6249                 if (gimme_scalar) {
6250                     iters++;
6251                     if (m-s == 0)
6252                         trailing_empty++;
6253                     else
6254                         trailing_empty = 0;
6255                 } else {
6256                     dstr = newSVpvn_flags(s, m-s, flags);
6257                     XPUSHs(dstr);
6258                 }
6259                 /* The rx->minlen is in characters but we want to step
6260                  * s ahead by bytes. */
6261                 if (do_utf8)
6262                     s = (char*)utf8_hop_forward((U8*) m, len, (U8*) strend);
6263                 else
6264                     s = m + len; /* Fake \n at the end */
6265             }
6266         }
6267         else {
6268             const bool multiline = (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) ? 1 : 0;
6269
6270             while (s < strend && --limit &&
6271               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
6272                              csv, multiline ? FBMrf_MULTILINE : 0)) )
6273             {
6274                 if (gimme_scalar) {
6275                     iters++;
6276                     if (m-s == 0)
6277                         trailing_empty++;
6278                     else
6279                         trailing_empty = 0;
6280                 } else {
6281                     dstr = newSVpvn_flags(s, m-s, flags);
6282                     XPUSHs(dstr);
6283                 }
6284                 /* The rx->minlen is in characters but we want to step
6285                  * s ahead by bytes. */
6286                 if (do_utf8)
6287                     s = (char*)utf8_hop_forward((U8*)m, len, (U8 *) strend);
6288                 else
6289                     s = m + len; /* Fake \n at the end */
6290             }
6291         }
6292     }
6293     else {
6294         maxiters += slen * RX_NPARENS(rx);
6295         while (s < strend && --limit)
6296         {
6297             I32 rex_return;
6298             PUTBACK;
6299             rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1,
6300                                      sv, NULL, 0);
6301             SPAGAIN;
6302             if (rex_return == 0)
6303                 break;
6304             TAINT_IF(RX_MATCH_TAINTED(rx));
6305             /* we never pass the REXEC_COPY_STR flag, so it should
6306              * never get copied */
6307             assert(!RX_MATCH_COPIED(rx));
6308             m = RX_OFFS(rx)[0].start + orig;
6309
6310             if (gimme_scalar) {
6311                 iters++;
6312                 if (m-s == 0)
6313                     trailing_empty++;
6314                 else
6315                     trailing_empty = 0;
6316             } else {
6317                 dstr = newSVpvn_flags(s, m-s, flags);
6318                 XPUSHs(dstr);
6319             }
6320             if (RX_NPARENS(rx)) {
6321                 I32 i;
6322                 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
6323                     s = RX_OFFS(rx)[i].start + orig;
6324                     m = RX_OFFS(rx)[i].end + orig;
6325
6326                     /* japhy (07/27/01) -- the (m && s) test doesn't catch
6327                        parens that didn't match -- they should be set to
6328                        undef, not the empty string */
6329                     if (gimme_scalar) {
6330                         iters++;
6331                         if (m-s == 0)
6332                             trailing_empty++;
6333                         else
6334                             trailing_empty = 0;
6335                     } else {
6336                         if (m >= orig && s >= orig) {
6337                             dstr = newSVpvn_flags(s, m-s, flags);
6338                         }
6339                         else
6340                             dstr = &PL_sv_undef;  /* undef, not "" */
6341                         XPUSHs(dstr);
6342                     }
6343
6344                 }
6345             }
6346             s = RX_OFFS(rx)[0].end + orig;
6347         }
6348     }
6349
6350     if (!gimme_scalar) {
6351         iters = (SP - PL_stack_base) - base;
6352     }
6353     if (iters > maxiters)
6354         DIE(aTHX_ "Split loop");
6355
6356     /* keep field after final delim? */
6357     if (s < strend || (iters && origlimit)) {
6358         if (!gimme_scalar) {
6359             const STRLEN l = strend - s;
6360             dstr = newSVpvn_flags(s, l, flags);
6361             XPUSHs(dstr);
6362         }
6363         iters++;
6364     }
6365     else if (!origlimit) {
6366         if (gimme_scalar) {
6367             iters -= trailing_empty;
6368         } else {
6369             while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
6370                 if (TOPs && !(flags & SVs_TEMP))
6371                     sv_2mortal(TOPs);
6372                 *SP-- = NULL;
6373                 iters--;
6374             }
6375         }
6376     }
6377
6378     PUTBACK;
6379     LEAVE_SCOPE(oldsave);
6380     SPAGAIN;
6381     if (realarray) {
6382         if (!mg) {
6383             PUTBACK;
6384             if(AvREAL(ary)) {
6385                 if (av_count(ary) > 0)
6386                     av_clear(ary);
6387             } else {
6388                 AvREAL_on(ary);
6389                 AvREIFY_off(ary);
6390
6391                 if (AvMAX(ary) > -1) {
6392                     /* don't free mere refs */
6393                     Zero(AvARRAY(ary), AvMAX(ary), SV*);
6394                 }
6395             }
6396             if(AvMAX(ary) < iters)
6397                 av_extend(ary,iters);
6398             SPAGAIN;
6399
6400             /* Need to copy the SV*s from the stack into ary */
6401             Copy(SP + 1 - iters, AvARRAY(ary), iters, SV*);
6402             AvFILLp(ary) = iters - 1;
6403
6404             if (SvSMAGICAL(ary)) {
6405                 PUTBACK;
6406                 mg_set(MUTABLE_SV(ary));
6407                 SPAGAIN;
6408             }
6409
6410             if (gimme != G_ARRAY) {
6411                 /* SP points to the final SV* pushed to the stack. But the SV*  */
6412                 /* are not going to be used from the stack. Point SP to below   */
6413                 /* the first of these SV*.                                      */
6414                 SP -= iters;
6415                 PUTBACK;
6416             }
6417         }
6418         else {
6419             PUTBACK;
6420             av_extend(ary,iters);
6421             av_clear(ary);
6422
6423             ENTER_with_name("call_PUSH");
6424             call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
6425             LEAVE_with_name("call_PUSH");
6426             SPAGAIN;
6427
6428             if (gimme == G_ARRAY) {
6429                 SSize_t i;
6430                 /* EXTEND should not be needed - we just popped them */
6431                 EXTEND_SKIP(SP, iters);
6432                 for (i=0; i < iters; i++) {
6433                     SV **svp = av_fetch(ary, i, FALSE);
6434                     PUSHs((svp) ? *svp : &PL_sv_undef);
6435                 }
6436                 RETURN;
6437             }
6438         }
6439     }
6440
6441     if (gimme != G_ARRAY) {
6442         GETTARGET;
6443         XPUSHi(iters);
6444      }
6445
6446     RETURN;
6447 }
6448
6449 PP(pp_once)
6450 {
6451     dSP;
6452     SV *const sv = PAD_SVl(PL_op->op_targ);
6453
6454     if (SvPADSTALE(sv)) {
6455         /* First time. */
6456         SvPADSTALE_off(sv);
6457         RETURNOP(cLOGOP->op_other);
6458     }
6459     RETURNOP(cLOGOP->op_next);
6460 }
6461
6462 PP(pp_lock)
6463 {
6464     dSP;
6465     dTOPss;
6466     SV *retsv = sv;
6467     SvLOCK(sv);
6468     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6469      || SvTYPE(retsv) == SVt_PVCV) {
6470         retsv = refto(retsv);
6471     }
6472     SETs(retsv);
6473     RETURN;
6474 }
6475
6476
6477 /* used for: pp_padany(), pp_custom(); plus any system ops
6478  * that aren't implemented on a particular platform */
6479
6480 PP(unimplemented_op)
6481 {
6482     const Optype op_type = PL_op->op_type;
6483     /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
6484        with out of range op numbers - it only "special" cases op_custom.
6485        Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
6486        if we get here for a custom op then that means that the custom op didn't
6487        have an implementation. Given that OP_NAME() looks up the custom op
6488        by its op_ppaddr, likely it will return NULL, unless someone (unhelpfully)
6489        registers &Perl_unimplemented_op as the address of their custom op.
6490        NULL doesn't generate a useful error message. "custom" does. */
6491     const char *const name = op_type >= OP_max
6492         ? "[out of range]" : PL_op_name[op_type];
6493     if(OP_IS_SOCKET(op_type))
6494         DIE(aTHX_ PL_no_sock_func, name);
6495     DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name,  op_type);
6496 }
6497
6498 static void
6499 S_maybe_unwind_defav(pTHX)
6500 {
6501     if (CX_CUR()->cx_type & CXp_HASARGS) {
6502         PERL_CONTEXT *cx = CX_CUR();
6503
6504         assert(CxHASARGS(cx));
6505         cx_popsub_args(cx);
6506         cx->cx_type &= ~CXp_HASARGS;
6507     }
6508 }
6509
6510 /* For sorting out arguments passed to a &CORE:: subroutine */
6511 PP(pp_coreargs)
6512 {
6513     dSP;
6514     int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
6515     int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0;
6516     AV * const at_ = GvAV(PL_defgv);
6517     SV **svp = at_ ? AvARRAY(at_) : NULL;
6518     I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
6519     I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
6520     bool seen_question = 0;
6521     const char *err = NULL;
6522     const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
6523
6524     /* Count how many args there are first, to get some idea how far to
6525        extend the stack. */
6526     while (oa) {
6527         if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
6528         maxargs++;
6529         if (oa & OA_OPTIONAL) seen_question = 1;
6530         if (!seen_question) minargs++;
6531         oa >>= 4;
6532     }
6533
6534     if(numargs < minargs) err = "Not enough";
6535     else if(numargs > maxargs) err = "Too many";
6536     if (err)
6537         /* diag_listed_as: Too many arguments for %s */
6538         Perl_croak(aTHX_
6539           "%s arguments for %s", err,
6540            opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv)
6541         );
6542
6543     /* Reset the stack pointer.  Without this, we end up returning our own
6544        arguments in list context, in addition to the values we are supposed
6545        to return.  nextstate usually does this on sub entry, but we need
6546        to run the next op with the caller's hints, so we cannot have a
6547        nextstate. */
6548     SP = PL_stack_base + CX_CUR()->blk_oldsp;
6549
6550     if(!maxargs) RETURN;
6551
6552     /* We do this here, rather than with a separate pushmark op, as it has
6553        to come in between two things this function does (stack reset and
6554        arg pushing).  This seems the easiest way to do it. */
6555     if (pushmark) {
6556         PUTBACK;
6557         (void)Perl_pp_pushmark(aTHX);
6558     }
6559
6560     EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
6561     PUTBACK; /* The code below can die in various places. */
6562
6563     oa = PL_opargs[opnum] >> OASHIFT;
6564     for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
6565         whicharg++;
6566         switch (oa & 7) {
6567         case OA_SCALAR:
6568           try_defsv:
6569             if (!numargs && defgv && whicharg == minargs + 1) {
6570                 PUSHs(DEFSV);
6571             }
6572             else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
6573             break;
6574         case OA_LIST:
6575             while (numargs--) {
6576                 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
6577                 svp++;
6578             }
6579             RETURN;
6580         case OA_AVREF:
6581             if (!numargs) {
6582                 GV *gv;
6583                 if (CvUNIQUE(find_runcv_where(FIND_RUNCV_level_eq,1,NULL)))
6584                     gv = PL_argvgv;
6585                 else {
6586                     S_maybe_unwind_defav(aTHX);
6587                     gv = PL_defgv;
6588                 }
6589                 PUSHs((SV *)GvAVn(gv));
6590                 break;
6591             }
6592             if (!svp || !*svp || !SvROK(*svp)
6593              || SvTYPE(SvRV(*svp)) != SVt_PVAV)
6594                 DIE(aTHX_
6595                 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6596                  "Type of arg %d to &CORE::%s must be array reference",
6597                   whicharg, PL_op_desc[opnum]
6598                 );
6599             PUSHs(SvRV(*svp));
6600             break;
6601         case OA_HVREF:
6602             if (!svp || !*svp || !SvROK(*svp)
6603              || (  SvTYPE(SvRV(*svp)) != SVt_PVHV
6604                 && (  opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN
6605                    || SvTYPE(SvRV(*svp)) != SVt_PVAV  )))
6606                 DIE(aTHX_
6607                 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6608                  "Type of arg %d to &CORE::%s must be hash%s reference",
6609                   whicharg, PL_op_desc[opnum],
6610                   opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN
6611                      ? ""
6612                      : " or array"
6613                 );
6614             PUSHs(SvRV(*svp));
6615             break;
6616         case OA_FILEREF:
6617             if (!numargs) PUSHs(NULL);
6618             else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
6619                 /* no magic here, as the prototype will have added an extra
6620                    refgen and we just want what was there before that */
6621                 PUSHs(SvRV(*svp));
6622             else {
6623                 const bool constr = PL_op->op_private & whicharg;
6624                 PUSHs(S_rv2gv(aTHX_
6625                     svp && *svp ? *svp : &PL_sv_undef,
6626                     constr, cBOOL(CopHINTS_get(PL_curcop) & HINT_STRICT_REFS),
6627                     !constr
6628                 ));
6629             }
6630             break;
6631         case OA_SCALARREF:
6632           if (!numargs) goto try_defsv;
6633           else {
6634             const bool wantscalar =
6635                 PL_op->op_private & OPpCOREARGS_SCALARMOD;
6636             if (!svp || !*svp || !SvROK(*svp)
6637                 /* We have to permit globrefs even for the \$ proto, as
6638                    *foo is indistinguishable from ${\*foo}, and the proto-
6639                    type permits the latter. */
6640              || SvTYPE(SvRV(*svp)) > (
6641                      wantscalar       ? SVt_PVLV
6642                    : opnum == OP_LOCK || opnum == OP_UNDEF
6643                                       ? SVt_PVCV
6644                    :                    SVt_PVHV
6645                 )
6646                )
6647                 DIE(aTHX_
6648                  "Type of arg %d to &CORE::%s must be %s",
6649                   whicharg, PL_op_name[opnum],
6650                   wantscalar
6651                     ? "scalar reference"
6652                     : opnum == OP_LOCK || opnum == OP_UNDEF
6653                        ? "reference to one of [$@%&*]"
6654                        : "reference to one of [$@%*]"
6655                 );
6656             PUSHs(SvRV(*svp));
6657             if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv) {
6658                 /* Undo @_ localisation, so that sub exit does not undo
6659                    part of our undeffing. */
6660                 S_maybe_unwind_defav(aTHX);
6661             }
6662           }
6663           break;
6664         default:
6665             DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
6666         }
6667         oa = oa >> 4;
6668     }
6669
6670     RETURN;
6671 }
6672
6673 /* Implement CORE::keys(),values(),each().
6674  *
6675  * We won't know until run-time whether the arg is an array or hash,
6676  * so this op calls
6677  *
6678  *    pp_keys/pp_values/pp_each
6679  * or
6680  *    pp_akeys/pp_avalues/pp_aeach
6681  *
6682  * as appropriate (or whatever pp function actually implements the OP_FOO
6683  * functionality for each FOO).
6684  */
6685
6686 PP(pp_avhvswitch)
6687 {
6688     dSP;
6689     return PL_ppaddr[
6690                 (SvTYPE(TOPs) == SVt_PVAV ? OP_AEACH : OP_EACH)
6691                     + (PL_op->op_private & OPpAVHVSWITCH_MASK)
6692            ](aTHX);
6693 }
6694
6695 PP(pp_runcv)
6696 {
6697     dSP;
6698     CV *cv;
6699     if (PL_op->op_private & OPpOFFBYONE) {
6700         cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL);
6701     }
6702     else cv = find_runcv(NULL);
6703     XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
6704     RETURN;
6705 }
6706
6707 static void
6708 S_localise_aelem_lval(pTHX_ AV * const av, SV * const keysv,
6709                             const bool can_preserve)
6710 {
6711     const SSize_t ix = SvIV(keysv);
6712     if (can_preserve ? av_exists(av, ix) : TRUE) {
6713         SV ** const svp = av_fetch(av, ix, 1);
6714         if (!svp || !*svp)
6715             Perl_croak(aTHX_ PL_no_aelem, ix);
6716         save_aelem(av, ix, svp);
6717     }
6718     else
6719         SAVEADELETE(av, ix);
6720 }
6721
6722 static void
6723 S_localise_helem_lval(pTHX_ HV * const hv, SV * const keysv,
6724                             const bool can_preserve)
6725 {
6726     if (can_preserve ? hv_exists_ent(hv, keysv, 0) : TRUE) {
6727         HE * const he = hv_fetch_ent(hv, keysv, 1, 0);
6728         SV ** const svp = he ? &HeVAL(he) : NULL;
6729         if (!svp || !*svp)
6730             Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(keysv));
6731         save_helem_flags(hv, keysv, svp, 0);
6732     }
6733     else
6734         SAVEHDELETE(hv, keysv);
6735 }
6736
6737 static void
6738 S_localise_gv_slot(pTHX_ GV *gv, U8 type)
6739 {
6740     if (type == OPpLVREF_SV) {
6741         save_pushptrptr(gv, SvREFCNT_inc_simple(GvSV(gv)), SAVEt_GVSV);
6742         GvSV(gv) = 0;
6743     }
6744     else if (type == OPpLVREF_AV)
6745         /* XXX Inefficient, as it creates a new AV, which we are
6746                about to clobber.  */
6747         save_ary(gv);
6748     else {
6749         assert(type == OPpLVREF_HV);
6750         /* XXX Likewise inefficient.  */
6751         save_hash(gv);
6752     }
6753 }
6754
6755
6756 PP(pp_refassign)
6757 {
6758     dSP;
6759     SV * const key = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6760     SV * const left = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6761     dTOPss;
6762     const char *bad = NULL;
6763     const U8 type = PL_op->op_private & OPpLVREF_TYPE;
6764     if (!SvROK(sv)) DIE(aTHX_ "Assigned value is not a reference");
6765     switch (type) {
6766     case OPpLVREF_SV:
6767         if (SvTYPE(SvRV(sv)) > SVt_PVLV)
6768             bad = " SCALAR";
6769         break;
6770     case OPpLVREF_AV:
6771         if (SvTYPE(SvRV(sv)) != SVt_PVAV)
6772             bad = "n ARRAY";
6773         break;
6774     case OPpLVREF_HV:
6775         if (SvTYPE(SvRV(sv)) != SVt_PVHV)
6776             bad = " HASH";
6777         break;
6778     case OPpLVREF_CV:
6779         if (SvTYPE(SvRV(sv)) != SVt_PVCV)
6780             bad = " CODE";
6781     }
6782     if (bad)
6783         /* diag_listed_as: Assigned value is not %s reference */
6784         DIE(aTHX_ "Assigned value is not a%s reference", bad);
6785     {
6786     MAGIC *mg;
6787     HV *stash;
6788     switch (left ? SvTYPE(left) : 0) {
6789     case 0:
6790     {
6791         SV * const old = PAD_SV(ARGTARG);
6792         PAD_SETSV(ARGTARG, SvREFCNT_inc_NN(SvRV(sv)));
6793         SvREFCNT_dec(old);
6794         if ((PL_op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
6795                 == OPpLVAL_INTRO)
6796             SAVECLEARSV(PAD_SVl(ARGTARG));
6797         break;
6798     }
6799     case SVt_PVGV:
6800         if (PL_op->op_private & OPpLVAL_INTRO) {
6801             S_localise_gv_slot(aTHX_ (GV *)left, type);
6802         }
6803         gv_setref(left, sv);
6804         SvSETMAGIC(left);
6805         break;
6806     case SVt_PVAV:
6807         assert(key);
6808         if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6809             S_localise_aelem_lval(aTHX_ (AV *)left, key,
6810                                         SvCANEXISTDELETE(left));
6811         }
6812         av_store((AV *)left, SvIV(key), SvREFCNT_inc_simple_NN(SvRV(sv)));
6813         break;
6814     case SVt_PVHV:
6815         if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6816             assert(key);
6817             S_localise_helem_lval(aTHX_ (HV *)left, key,
6818                                         SvCANEXISTDELETE(left));
6819         }
6820         (void)hv_store_ent((HV *)left, key, SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
6821     }
6822     if (PL_op->op_flags & OPf_MOD)
6823         SETs(sv_2mortal(newSVsv(sv)));
6824     /* XXX else can weak references go stale before they are read, e.g.,
6825        in leavesub?  */
6826     RETURN;
6827     }
6828 }
6829
6830 PP(pp_lvref)
6831 {
6832     dSP;
6833     SV * const ret = sv_2mortal(newSV_type(SVt_PVMG));
6834     SV * const elem = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6835     SV * const arg = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6836     MAGIC * const mg = sv_magicext(ret, arg, PERL_MAGIC_lvref,
6837                                    &PL_vtbl_lvref, (char *)elem,
6838                                    elem ? HEf_SVKEY : (I32)ARGTARG);
6839     mg->mg_private = PL_op->op_private;
6840     if (PL_op->op_private & OPpLVREF_ITER)
6841         mg->mg_flags |= MGf_PERSIST;
6842     if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6843       if (elem) {
6844         MAGIC *mg;
6845         HV *stash;
6846         assert(arg);
6847         {
6848             const bool can_preserve = SvCANEXISTDELETE(arg);
6849             if (SvTYPE(arg) == SVt_PVAV)
6850               S_localise_aelem_lval(aTHX_ (AV *)arg, elem, can_preserve);
6851             else
6852               S_localise_helem_lval(aTHX_ (HV *)arg, elem, can_preserve);
6853         }
6854       }
6855       else if (arg) {
6856         S_localise_gv_slot(aTHX_ (GV *)arg,
6857                                  PL_op->op_private & OPpLVREF_TYPE);
6858       }
6859       else if (!(PL_op->op_private & OPpPAD_STATE))
6860         SAVECLEARSV(PAD_SVl(ARGTARG));
6861     }
6862     XPUSHs(ret);
6863     RETURN;
6864 }
6865
6866 PP(pp_lvrefslice)
6867 {
6868     dSP; dMARK;
6869     AV * const av = (AV *)POPs;
6870     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
6871     bool can_preserve = FALSE;
6872
6873     if (UNLIKELY(localizing)) {
6874         MAGIC *mg;
6875         HV *stash;
6876         SV **svp;
6877
6878         can_preserve = SvCANEXISTDELETE(av);
6879
6880         if (SvTYPE(av) == SVt_PVAV) {
6881             SSize_t max = -1;
6882
6883             for (svp = MARK + 1; svp <= SP; svp++) {
6884                 const SSize_t elem = SvIV(*svp);
6885                 if (elem > max)
6886                     max = elem;
6887             }
6888             if (max > AvMAX(av))
6889                 av_extend(av, max);
6890         }
6891     }
6892
6893     while (++MARK <= SP) {
6894         SV * const elemsv = *MARK;
6895         if (UNLIKELY(localizing)) {
6896             if (SvTYPE(av) == SVt_PVAV)
6897                 S_localise_aelem_lval(aTHX_ av, elemsv, can_preserve);
6898             else
6899                 S_localise_helem_lval(aTHX_ (HV *)av, elemsv, can_preserve);
6900         }
6901         *MARK = sv_2mortal(newSV_type(SVt_PVMG));
6902         sv_magic(*MARK,(SV *)av,PERL_MAGIC_lvref,(char *)elemsv,HEf_SVKEY);
6903     }
6904     RETURN;
6905 }
6906
6907 PP(pp_lvavref)
6908 {
6909     if (PL_op->op_flags & OPf_STACKED)
6910         Perl_pp_rv2av(aTHX);
6911     else
6912         Perl_pp_padav(aTHX);
6913     {
6914         dSP;
6915         dTOPss;
6916         SETs(0); /* special alias marker that aassign recognises */
6917         XPUSHs(sv);
6918         RETURN;
6919     }
6920 }
6921
6922 PP(pp_anonconst)
6923 {
6924     dSP;
6925     dTOPss;
6926     SETs(sv_2mortal((SV *)newCONSTSUB(SvTYPE(CopSTASH(PL_curcop))==SVt_PVHV
6927                                         ? CopSTASH(PL_curcop)
6928                                         : NULL,
6929                                       NULL, SvREFCNT_inc_simple_NN(sv))));
6930     RETURN;
6931 }
6932
6933
6934 /* process one subroutine argument - typically when the sub has a signature:
6935  * introduce PL_curpad[op_targ] and assign to it the value
6936  *  for $:   (OPf_STACKED ? *sp : $_[N])
6937  *  for @/%: @_[N..$#_]
6938  *
6939  * It's equivalent to
6940  *    my $foo = $_[N];
6941  * or
6942  *    my $foo = (value-on-stack)
6943  * or
6944  *    my @foo = @_[N..$#_]
6945  * etc
6946  */
6947
6948 PP(pp_argelem)
6949 {
6950     dTARG;
6951     SV *val;
6952     SV ** padentry;
6953     OP *o = PL_op;
6954     AV *defav = GvAV(PL_defgv); /* @_ */
6955     IV ix = PTR2IV(cUNOP_AUXo->op_aux);
6956     IV argc;
6957
6958     /* do 'my $var, @var or %var' action */
6959     padentry = &(PAD_SVl(o->op_targ));
6960     save_clearsv(padentry);
6961     targ = *padentry;
6962
6963     if ((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_SV) {
6964         if (o->op_flags & OPf_STACKED) {
6965             dSP;
6966             val = POPs;
6967             PUTBACK;
6968         }
6969         else {
6970             SV **svp;
6971             /* should already have been checked */
6972             assert(ix >= 0);
6973 #if IVSIZE > PTRSIZE
6974             assert(ix <= SSize_t_MAX);
6975 #endif
6976
6977             svp = av_fetch(defav, ix, FALSE);
6978             val = svp ? *svp : &PL_sv_undef;
6979         }
6980
6981         /* $var = $val */
6982
6983         /* cargo-culted from pp_sassign */
6984         assert(TAINTING_get || !TAINT_get);
6985         if (UNLIKELY(TAINT_get) && !SvTAINTED(val))
6986             TAINT_NOT;
6987
6988         SvSetMagicSV(targ, val);
6989         return o->op_next;
6990     }
6991
6992     /* must be AV or HV */
6993
6994     assert(!(o->op_flags & OPf_STACKED));
6995     argc = ((IV)AvFILL(defav) + 1) - ix;
6996
6997     /* This is a copy of the relevant parts of pp_aassign().
6998      */
6999     if ((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_AV) {
7000         IV i;
7001
7002         if (AvFILL((AV*)targ) > -1) {
7003             /* target should usually be empty. If we get get
7004              * here, someone's been doing some weird closure tricks.
7005              * Make a copy of all args before clearing the array,
7006              * to avoid the equivalent of @a = ($a[0]) prematurely freeing
7007              * elements. See similar code in pp_aassign.
7008              */
7009             for (i = 0; i < argc; i++) {
7010                 SV **svp = av_fetch(defav, ix + i, FALSE);
7011                 SV *newsv = newSV(0);
7012                 sv_setsv_flags(newsv,
7013                                 svp ? *svp : &PL_sv_undef,
7014                                 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
7015                 if (!av_store(defav, ix + i, newsv))
7016                     SvREFCNT_dec_NN(newsv);
7017             }
7018             av_clear((AV*)targ);
7019         }
7020
7021         if (argc <= 0)
7022             return o->op_next;
7023
7024         av_extend((AV*)targ, argc);
7025
7026         i = 0;
7027         while (argc--) {
7028             SV *tmpsv;
7029             SV **svp = av_fetch(defav, ix + i, FALSE);
7030             SV *val = svp ? *svp : &PL_sv_undef;
7031             tmpsv = newSV(0);
7032             sv_setsv(tmpsv, val);
7033             av_store((AV*)targ, i++, tmpsv);
7034             TAINT_NOT;
7035         }
7036
7037     }
7038     else {
7039         IV i;
7040
7041         assert((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_HV);
7042
7043         if (SvRMAGICAL(targ) || HvUSEDKEYS((HV*)targ)) {
7044             /* see "target should usually be empty" comment above */
7045             for (i = 0; i < argc; i++) {
7046                 SV **svp = av_fetch(defav, ix + i, FALSE);
7047                 SV *newsv = newSV(0);
7048                 sv_setsv_flags(newsv,
7049                                 svp ? *svp : &PL_sv_undef,
7050                                 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
7051                 if (!av_store(defav, ix + i, newsv))
7052                     SvREFCNT_dec_NN(newsv);
7053             }
7054             hv_clear((HV*)targ);
7055         }
7056
7057         if (argc <= 0)
7058             return o->op_next;
7059         assert(argc % 2 == 0);
7060
7061         i = 0;
7062         while (argc) {
7063             SV *tmpsv;
7064             SV **svp;
7065             SV *key;
7066             SV *val;
7067
7068             svp = av_fetch(defav, ix + i++, FALSE);
7069             key = svp ? *svp : &PL_sv_undef;
7070             svp = av_fetch(defav, ix + i++, FALSE);
7071             val = svp ? *svp : &PL_sv_undef;
7072
7073             argc -= 2;
7074             if (UNLIKELY(SvGMAGICAL(key)))
7075                 key = sv_mortalcopy(key);
7076             tmpsv = newSV(0);
7077             sv_setsv(tmpsv, val);
7078             hv_store_ent((HV*)targ, key, tmpsv, 0);
7079             TAINT_NOT;
7080         }
7081     }
7082
7083     return o->op_next;
7084 }
7085
7086 /* Handle a default value for one subroutine argument (typically as part
7087  * of a subroutine signature).
7088  * It's equivalent to
7089  *    @_ > op_targ ? $_[op_targ] : result_of(op_other)
7090  *
7091  * Intended to be used where op_next is an OP_ARGELEM
7092  *
7093  * We abuse the op_targ field slightly: it's an index into @_ rather than
7094  * into PL_curpad.
7095  */
7096
7097 PP(pp_argdefelem)
7098 {
7099     OP * const o = PL_op;
7100     AV *defav = GvAV(PL_defgv); /* @_ */
7101     IV ix = (IV)o->op_targ;
7102
7103     assert(ix >= 0);
7104 #if IVSIZE > PTRSIZE
7105     assert(ix <= SSize_t_MAX);
7106 #endif
7107
7108     if (AvFILL(defav) >= ix) {
7109         dSP;
7110         SV **svp = av_fetch(defav, ix, FALSE);
7111         SV  *val = svp ? *svp : &PL_sv_undef;
7112         XPUSHs(val);
7113         RETURN;
7114     }
7115     return cLOGOPo->op_other;
7116 }
7117
7118
7119 static SV *
7120 S_find_runcv_name(void)
7121 {
7122     dTHX;
7123     CV *cv;
7124     GV *gv;
7125     SV *sv;
7126
7127     cv = find_runcv(0);
7128     if (!cv)
7129         return &PL_sv_no;
7130
7131     gv = CvGV(cv);
7132     if (!gv)
7133         return &PL_sv_no;
7134
7135     sv = sv_2mortal(newSV(0));
7136     gv_fullname4(sv, gv, NULL, TRUE);
7137     return sv;
7138 }
7139
7140 /* Check a sub's arguments - i.e. that it has the correct number of args
7141  * (and anything else we might think of in future). Typically used with
7142  * signatured subs.
7143  */
7144
7145 PP(pp_argcheck)
7146 {
7147     OP * const o       = PL_op;
7148     struct op_argcheck_aux *aux = (struct op_argcheck_aux *)cUNOP_AUXo->op_aux;
7149     UV   params        = aux->params;
7150     UV   opt_params    = aux->opt_params;
7151     char slurpy        = aux->slurpy;
7152     AV  *defav         = GvAV(PL_defgv); /* @_ */
7153     UV   argc;
7154     bool too_few;
7155
7156     assert(!SvMAGICAL(defav));
7157     argc = (UV)(AvFILLp(defav) + 1);
7158     too_few = (argc < (params - opt_params));
7159
7160     if (UNLIKELY(too_few || (!slurpy && argc > params)))
7161
7162         /* diag_listed_as: Too few arguments for subroutine '%s' (got %d; expected %d) */
7163         /* diag_listed_as: Too few arguments for subroutine '%s' (got %d; expected at least %d) */
7164         /* diag_listed_as: Too many arguments for subroutine '%s' (got %d; expected %d) */
7165         /* diag_listed_as: Too many arguments for subroutine '%s' (got %d; expected at most %d)*/
7166         Perl_croak_caller("Too %s arguments for subroutine '%" SVf "' (got %" UVuf "; expected %s%" UVuf ")",
7167                           too_few ? "few" : "many",
7168                           S_find_runcv_name(),
7169                           argc,
7170                           too_few ? (slurpy || opt_params ? "at least " : "") : (opt_params ? "at most " : ""),
7171                           too_few ? (params - opt_params) : params);
7172
7173     if (UNLIKELY(slurpy == '%' && argc > params && (argc - params) % 2))
7174         /* diag_listed_as: Odd name/value argument for subroutine '%s' */
7175         Perl_croak_caller("Odd name/value argument for subroutine '%" SVf "'",
7176                           S_find_runcv_name());
7177
7178     return NORMAL;
7179 }
7180
7181 PP(pp_isa)
7182 {
7183     dSP;
7184     SV *left, *right;
7185
7186     right = POPs;
7187     left  = TOPs;
7188
7189     SETs(boolSV(sv_isa_sv(left, right)));
7190     RETURN;
7191 }
7192
7193 PP(pp_cmpchain_and)
7194 {
7195     dSP;
7196     SV *result = POPs;
7197     PUTBACK;
7198     if (SvTRUE_NN(result)) {
7199         return cLOGOP->op_other;
7200     } else {
7201         TOPs = result;
7202         return NORMAL;
7203     }
7204 }
7205
7206 PP(pp_cmpchain_dup)
7207 {
7208     dSP;
7209     SV *right = TOPs;
7210     SV *left = TOPm1s;
7211     TOPm1s = right;
7212     TOPs = left;
7213     XPUSHs(right);
7214     RETURN;
7215 }
7216
7217 /*
7218  * ex: set ts=8 sts=4 sw=4 et:
7219  */