pp.c

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