pp.c

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