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