pp.c

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