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