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