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     dSP;
4038     SV *source = TOPs;
4039     STRLEN len;
4040     STRLEN min;
4041     SV *dest;
4042     const U8 *s;
4043     U8 *d;
4044
4045     SvGETMAGIC(source);
4046
4047     if (   SvPADTMP(source)
4048         && !SvREADONLY(source) && SvPOK(source)
4049         && !DO_UTF8(source)
4050         && (
4051 #ifdef USE_LOCALE_CTYPE
4052             (IN_LC_RUNTIME(LC_CTYPE))
4053             ? ! IN_UTF8_CTYPE_LOCALE
4054             :
4055 #endif
4056               ! IN_UNI_8_BIT))
4057     {
4058
4059         /* We can convert in place.  The reason we can't if in UNI_8_BIT is to
4060          * make the loop tight, so we overwrite the source with the dest before
4061          * looking at it, and we need to look at the original source
4062          * afterwards.  There would also need to be code added to handle
4063          * switching to not in-place in midstream if we run into characters
4064          * that change the length.  Since being in locale overrides UNI_8_BIT,
4065          * that latter becomes irrelevant in the above test; instead for
4066          * locale, the size can't normally change, except if the locale is a
4067          * UTF-8 one */
4068         dest = source;
4069         s = d = (U8*)SvPV_force_nomg(source, len);
4070         min = len + 1;
4071     } else {
4072         dTARGET;
4073
4074         dest = TARG;
4075
4076         s = (const U8*)SvPV_nomg_const(source, len);
4077         min = len + 1;
4078
4079         SvUPGRADE(dest, SVt_PV);
4080         d = (U8*)SvGROW(dest, min);
4081         (void)SvPOK_only(dest);
4082
4083         SETs(dest);
4084     }
4085
4086 #ifdef USE_LOCALE_CTYPE
4087
4088     if (IN_LC_RUNTIME(LC_CTYPE)) {
4089         _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4090     }
4091
4092 #endif
4093
4094     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4095        to check DO_UTF8 again here.  */
4096
4097     if (DO_UTF8(source)) {
4098         const U8 *const send = s + len;
4099         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4100
4101 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
4102 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
4103         /* All occurrences of these are to be moved to follow any other marks.
4104          * This is context-dependent.  We may not be passed enough context to
4105          * move the iota subscript beyond all of them, but we do the best we can
4106          * with what we're given.  The result is always better than if we
4107          * hadn't done this.  And, the problem would only arise if we are
4108          * passed a character without all its combining marks, which would be
4109          * the caller's mistake.  The information this is based on comes from a
4110          * comment in Unicode SpecialCasing.txt, (and the Standard's text
4111          * itself) and so can't be checked properly to see if it ever gets
4112          * revised.  But the likelihood of it changing is remote */
4113         bool in_iota_subscript = FALSE;
4114
4115         while (s < send) {
4116             STRLEN u;
4117             STRLEN ulen;
4118             UV uv;
4119             if (UNLIKELY(in_iota_subscript)) {
4120                 UV cp = utf8_to_uvchr_buf(s, send, NULL);
4121
4122                 if (! _invlist_contains_cp(PL_utf8_mark, cp)) {
4123
4124                     /* A non-mark.  Time to output the iota subscript */
4125                     *d++ = UTF8_TWO_BYTE_HI(GREEK_CAPITAL_LETTER_IOTA);
4126                     *d++ = UTF8_TWO_BYTE_LO(GREEK_CAPITAL_LETTER_IOTA);
4127                     in_iota_subscript = FALSE;
4128                 }
4129             }
4130
4131             /* Then handle the current character.  Get the changed case value
4132              * and copy it to the output buffer */
4133
4134             u = UTF8SKIP(s);
4135 #ifdef USE_LOCALE_CTYPE
4136             uv = _toUPPER_utf8_flags(s, send, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4137 #else
4138             uv = _toUPPER_utf8_flags(s, send, tmpbuf, &ulen, 0);
4139 #endif
4140             if (uv == GREEK_CAPITAL_LETTER_IOTA
4141                 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
4142             {
4143                 in_iota_subscript = TRUE;
4144             }
4145             else {
4146                 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4147                     /* If the eventually required minimum size outgrows the
4148                      * available space, we need to grow. */
4149                     const UV o = d - (U8*)SvPVX_const(dest);
4150
4151                     /* If someone uppercases one million U+03B0s we SvGROW()
4152                      * one million times.  Or we could try guessing how much to
4153                      * allocate without allocating too much.  But we can't
4154                      * really guess without examining the rest of the string.
4155                      * Such is life.  See corresponding comment in lc code for
4156                      * another option */
4157                     d = o + (U8*) SvGROW(dest, min);
4158                 }
4159                 Copy(tmpbuf, d, ulen, U8);
4160                 d += ulen;
4161             }
4162             s += u;
4163         }
4164         if (in_iota_subscript) {
4165             *d++ = UTF8_TWO_BYTE_HI(GREEK_CAPITAL_LETTER_IOTA);
4166             *d++ = UTF8_TWO_BYTE_LO(GREEK_CAPITAL_LETTER_IOTA);
4167         }
4168         SvUTF8_on(dest);
4169         *d = '\0';
4170
4171         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4172     }
4173     else {      /* Not UTF-8 */
4174         if (len) {
4175             const U8 *const send = s + len;
4176
4177             /* Use locale casing if in locale; regular style if not treating
4178              * latin1 as having case; otherwise the latin1 casing.  Do the
4179              * whole thing in a tight loop, for speed, */
4180 #ifdef USE_LOCALE_CTYPE
4181             if (IN_LC_RUNTIME(LC_CTYPE)) {
4182                 if (IN_UTF8_CTYPE_LOCALE) {
4183                     goto do_uni_rules;
4184                 }
4185                 for (; s < send; d++, s++)
4186                     *d = (U8) toUPPER_LC(*s);
4187             }
4188             else
4189 #endif
4190                  if (! IN_UNI_8_BIT) {
4191                 for (; s < send; d++, s++) {
4192                     *d = toUPPER(*s);
4193                 }
4194             }
4195             else {
4196 #ifdef USE_LOCALE_CTYPE
4197           do_uni_rules:
4198 #endif
4199                 for (; s < send; d++, s++) {
4200                     Size_t extra;
4201
4202                     *d = toUPPER_LATIN1_MOD(*s);
4203                     if (   LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)
4204
4205 #ifdef USE_LOCALE_CTYPE
4206
4207                         && (LIKELY(   ! PL_in_utf8_turkic_locale
4208                                    || ! IN_LC_RUNTIME(LC_CTYPE))
4209                                    || *s != 'i')
4210 #endif
4211
4212                     ) {
4213                         continue;
4214                     }
4215
4216                     /* The mainstream case is the tight loop above.  To avoid
4217                      * extra tests in that, all three characters that always
4218                      * require special handling are mapped by the MOD to the
4219                      * one tested just above.  Use the source to distinguish
4220                      * between those cases */
4221
4222 #if    UNICODE_MAJOR_VERSION > 2                                        \
4223    || (UNICODE_MAJOR_VERSION == 2 && UNICODE_DOT_VERSION >= 1           \
4224                                   && UNICODE_DOT_DOT_VERSION >= 8)
4225                     if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4226
4227                         /* uc() of this requires 2 characters, but they are
4228                          * ASCII.  If not enough room, grow the string */
4229                         if (SvLEN(dest) < ++min) {
4230                             const UV o = d - (U8*)SvPVX_const(dest);
4231                             d = o + (U8*) SvGROW(dest, min);
4232                         }
4233                         *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
4234                         continue;   /* Back to the tight loop; still in ASCII */
4235                     }
4236 #endif
4237
4238                     /* The other special handling characters have their
4239                      * upper cases outside the latin1 range, hence need to be
4240                      * in UTF-8, so the whole result needs to be in UTF-8.
4241                      *
4242                      * So, here we are somewhere in the middle of processing a
4243                      * non-UTF-8 string, and realize that we will have to
4244                      * convert the whole thing to UTF-8.  What to do?  There
4245                      * are several possibilities.  The simplest to code is to
4246                      * convert what we have so far, set a flag, and continue on
4247                      * in the loop.  The flag would be tested each time through
4248                      * the loop, and if set, the next character would be
4249                      * converted to UTF-8 and stored.  But, I (khw) didn't want
4250                      * to slow down the mainstream case at all for this fairly
4251                      * rare case, so I didn't want to add a test that didn't
4252                      * absolutely have to be there in the loop, besides the
4253                      * possibility that it would get too complicated for
4254                      * optimizers to deal with.  Another possibility is to just
4255                      * give up, convert the source to UTF-8, and restart the
4256                      * function that way.  Another possibility is to convert
4257                      * both what has already been processed and what is yet to
4258                      * come separately to UTF-8, then jump into the loop that
4259                      * handles UTF-8.  But the most efficient time-wise of the
4260                      * ones I could think of is what follows, and turned out to
4261                      * not require much extra code.
4262                      *
4263                      * First, calculate the extra space needed for the
4264                      * remainder of the source needing to be in UTF-8.  Except
4265                      * for the 'i' in Turkic locales, in UTF-8 strings, the
4266                      * uppercase of a character below 256 occupies the same
4267                      * number of bytes as the original.  Therefore, the space
4268                      * needed is the that number plus the number of characters
4269                      * that become two bytes when converted to UTF-8, plus, in
4270                      * turkish locales, the number of 'i's. */
4271
4272                     extra = send - s + variant_under_utf8_count(s, send);
4273
4274 #ifdef USE_LOCALE_CTYPE
4275
4276                     if (UNLIKELY(*s == 'i')) {  /* We wouldn't get an 'i' here
4277                                                    unless are in a Turkic
4278                                                    locale */
4279                         const U8 * s_peek = s;
4280
4281                         do {
4282                             extra++;
4283
4284                             s_peek = (U8 *) memchr(s_peek + 1, 'i',
4285                                                    send - (s_peek + 1));
4286                         } while (s_peek != NULL);
4287                     }
4288 #endif
4289
4290                     /* Convert what we have so far into UTF-8, telling the
4291                      * function that we know it should be converted, and to
4292                      * allow extra space for what we haven't processed yet.
4293                      *
4294                      * This may cause the string pointer to move, so need to
4295                      * save and re-find it. */
4296
4297                     len = d - (U8*)SvPVX_const(dest);
4298                     SvCUR_set(dest, len);
4299                     len = sv_utf8_upgrade_flags_grow(dest,
4300                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4301                                                 extra);
4302                     d = (U8*)SvPVX(dest) + len;
4303
4304                     /* Now process the remainder of the source, simultaneously
4305                      * converting to upper and UTF-8.
4306                      *
4307                      * To avoid extra tests in the loop body, and since the
4308                      * loop is so simple, split out the rare Turkic case into
4309                      * its own loop */
4310
4311 #ifdef USE_LOCALE_CTYPE
4312                     if (   UNLIKELY(PL_in_utf8_turkic_locale)
4313                         && UNLIKELY(IN_LC_RUNTIME(LC_CTYPE)))
4314                     {
4315                         for (; s < send; s++) {
4316                             if (*s == 'i') {
4317                                 *d++ = UTF8_TWO_BYTE_HI(LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
4318                                 *d++ = UTF8_TWO_BYTE_LO(LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
4319                             }
4320                             else {
4321                                 (void) _to_upper_title_latin1(*s, d, &len, 'S');
4322                                 d += len;
4323                             }
4324                         }
4325                     }
4326                     else
4327 #endif
4328                         for (; s < send; s++) {
4329                             (void) _to_upper_title_latin1(*s, d, &len, 'S');
4330                             d += len;
4331                         }
4332
4333                     /* Here have processed the whole source; no need to
4334                      * continue with the outer loop.  Each character has been
4335                      * converted to upper case and converted to UTF-8. */
4336                     break;
4337                 } /* End of processing all latin1-style chars */
4338             } /* End of processing all chars */
4339         } /* End of source is not empty */
4340
4341         if (source != dest) {
4342             *d = '\0';  /* Here d points to 1 after last char, add NUL */
4343             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4344         }
4345     } /* End of isn't utf8 */
4346 #ifdef USE_LOCALE_CTYPE
4347     if (IN_LC_RUNTIME(LC_CTYPE)) {
4348         TAINT;
4349         SvTAINTED_on(dest);
4350     }
4351 #endif
4352     if (dest != source && SvTAINTED(source))
4353         SvTAINT(dest);
4354     SvSETMAGIC(dest);
4355     return NORMAL;
4356 }
4357
4358 PP(pp_lc)
4359 {
4360     dSP;
4361     SV *source = TOPs;
4362     STRLEN len;
4363     STRLEN min;
4364     SV *dest;
4365     const U8 *s;
4366     U8 *d;
4367     bool has_turkic_I = FALSE;
4368
4369     SvGETMAGIC(source);
4370
4371     if (   SvPADTMP(source)
4372         && !SvREADONLY(source) && SvPOK(source)
4373         && !DO_UTF8(source)
4374
4375 #ifdef USE_LOCALE_CTYPE
4376
4377         && (   LIKELY(! IN_LC_RUNTIME(LC_CTYPE))
4378             || LIKELY(! PL_in_utf8_turkic_locale))
4379
4380 #endif
4381
4382     ) {
4383
4384         /* We can convert in place, as, outside of Turkic UTF-8 locales,
4385          * lowercasing anything in the latin1 range (or else DO_UTF8 would have
4386          * been on) doesn't lengthen it. */
4387         dest = source;
4388         s = d = (U8*)SvPV_force_nomg(source, len);
4389         min = len + 1;
4390     } else {
4391         dTARGET;
4392
4393         dest = TARG;
4394
4395         s = (const U8*)SvPV_nomg_const(source, len);
4396         min = len + 1;
4397
4398         SvUPGRADE(dest, SVt_PV);
4399         d = (U8*)SvGROW(dest, min);
4400         (void)SvPOK_only(dest);
4401
4402         SETs(dest);
4403     }
4404
4405 #ifdef USE_LOCALE_CTYPE
4406
4407     if (IN_LC_RUNTIME(LC_CTYPE)) {
4408         const U8 * next_I;
4409
4410         _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4411
4412         /* Lowercasing in a Turkic locale can cause non-UTF-8 to need to become
4413          * UTF-8 for the single case of the character 'I' */
4414         if (     UNLIKELY(PL_in_utf8_turkic_locale)
4415             && ! DO_UTF8(source)
4416             &&   (next_I = (U8 *) memchr(s, 'I', len)))
4417         {
4418             Size_t I_count = 0;
4419             const U8 *const send = s + len;
4420
4421             do {
4422                 I_count++;
4423
4424                 next_I = (U8 *) memchr(next_I + 1, 'I',
4425                                         send - (next_I + 1));
4426             } while (next_I != NULL);
4427
4428             /* Except for the 'I', in UTF-8 strings, the lower case of a
4429              * character below 256 occupies the same number of bytes as the
4430              * original.  Therefore, the space needed is the original length
4431              * plus I_count plus the number of characters that become two bytes
4432              * when converted to UTF-8 */
4433             sv_utf8_upgrade_flags_grow(dest, 0, len
4434                                               + I_count
4435                                               + variant_under_utf8_count(s, send));
4436             d = (U8*)SvPVX(dest);
4437             has_turkic_I = TRUE;
4438         }
4439     }
4440
4441 #endif
4442
4443     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4444        to check DO_UTF8 again here.  */
4445
4446     if (DO_UTF8(source)) {
4447         const U8 *const send = s + len;
4448         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4449         bool remove_dot_above = FALSE;
4450
4451         while (s < send) {
4452             const STRLEN u = UTF8SKIP(s);
4453             STRLEN ulen;
4454
4455 #ifdef USE_LOCALE_CTYPE
4456
4457             _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4458
4459             /* If we are in a Turkic locale, we have to do more work.  As noted
4460              * in the comments for lcfirst, there is a special case if a 'I'
4461              * is in a grapheme with COMBINING DOT ABOVE UTF8.  It turns into a
4462              * 'i', and the DOT must be removed.  We check for that situation,
4463              * and set a flag if the DOT is there.  Then each time through the
4464              * loop, we have to see if we need to remove the next DOT above,
4465              * and if so, do it.  We know that there is a DOT because
4466              * _toLOWER_utf8_flags() wouldn't have returned 'i' unless there
4467              * was one in a proper position. */
4468             if (   UNLIKELY(PL_in_utf8_turkic_locale)
4469                 && IN_LC_RUNTIME(LC_CTYPE))
4470             {
4471                 if (   UNLIKELY(remove_dot_above)
4472                     && memBEGINs(tmpbuf, sizeof(tmpbuf), COMBINING_DOT_ABOVE_UTF8))
4473                 {
4474                     s += u;
4475                     remove_dot_above = FALSE;
4476                     continue;
4477                 }
4478                 else if (UNLIKELY(*s == 'I' && tmpbuf[0] == 'i')) {
4479                     remove_dot_above = TRUE;
4480                 }
4481             }
4482 #else
4483             PERL_UNUSED_VAR(remove_dot_above);
4484
4485             _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, 0);
4486 #endif
4487
4488             /* Here is where we would do context-sensitive actions for the
4489              * Greek final sigma.  See the commit message for 86510fb15 for why
4490              * there isn't any */
4491
4492             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4493
4494                 /* If the eventually required minimum size outgrows the
4495                  * available space, we need to grow. */
4496                 const UV o = d - (U8*)SvPVX_const(dest);
4497
4498                 /* If someone lowercases one million U+0130s we SvGROW() one
4499                  * million times.  Or we could try guessing how much to
4500                  * allocate without allocating too much.  Such is life.
4501                  * Another option would be to grow an extra byte or two more
4502                  * each time we need to grow, which would cut down the million
4503                  * to 500K, with little waste */
4504                 d = o + (U8*) SvGROW(dest, min);
4505             }
4506
4507             /* Copy the newly lowercased letter to the output buffer we're
4508              * building */
4509             Copy(tmpbuf, d, ulen, U8);
4510             d += ulen;
4511             s += u;
4512         }   /* End of looping through the source string */
4513         SvUTF8_on(dest);
4514         *d = '\0';
4515         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4516     } else {    /* 'source' not utf8 */
4517         if (len) {
4518             const U8 *const send = s + len;
4519
4520             /* Use locale casing if in locale; regular style if not treating
4521              * latin1 as having case; otherwise the latin1 casing.  Do the
4522              * whole thing in a tight loop, for speed, */
4523 #ifdef USE_LOCALE_CTYPE
4524             if (IN_LC_RUNTIME(LC_CTYPE)) {
4525                 if (LIKELY( ! has_turkic_I)) {
4526                     for (; s < send; d++, s++)
4527                         *d = toLOWER_LC(*s);
4528                 }
4529                 else {  /* This is the only case where lc() converts 'dest'
4530                            into UTF-8 from a non-UTF-8 'source' */
4531                     for (; s < send; s++) {
4532                         if (*s == 'I') {
4533                             *d++ = UTF8_TWO_BYTE_HI(LATIN_SMALL_LETTER_DOTLESS_I);
4534                             *d++ = UTF8_TWO_BYTE_LO(LATIN_SMALL_LETTER_DOTLESS_I);
4535                         }
4536                         else {
4537                             append_utf8_from_native_byte(toLOWER_LATIN1(*s), &d);
4538                         }
4539                     }
4540                 }
4541             }
4542             else
4543 #endif
4544             if (! IN_UNI_8_BIT) {
4545                 for (; s < send; d++, s++) {
4546                     *d = toLOWER(*s);
4547                 }
4548             }
4549             else {
4550                 for (; s < send; d++, s++) {
4551                     *d = toLOWER_LATIN1(*s);
4552                 }
4553             }
4554         }
4555         if (source != dest) {
4556             *d = '\0';
4557             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4558         }
4559     }
4560 #ifdef USE_LOCALE_CTYPE
4561     if (IN_LC_RUNTIME(LC_CTYPE)) {
4562         TAINT;
4563         SvTAINTED_on(dest);
4564     }
4565 #endif
4566     if (dest != source && SvTAINTED(source))
4567         SvTAINT(dest);
4568     SvSETMAGIC(dest);
4569     return NORMAL;
4570 }
4571
4572 PP(pp_quotemeta)
4573 {
4574     dSP; dTARGET;
4575     SV * const sv = TOPs;
4576     STRLEN len;
4577     const char *s = SvPV_const(sv,len);
4578
4579     SvUTF8_off(TARG);                           /* decontaminate */
4580     if (len) {
4581         char *d;
4582         SvUPGRADE(TARG, SVt_PV);
4583         SvGROW(TARG, (len * 2) + 1);
4584         d = SvPVX(TARG);
4585         if (DO_UTF8(sv)) {
4586             while (len) {
4587                 STRLEN ulen = UTF8SKIP(s);
4588                 bool to_quote = FALSE;
4589
4590                 if (UTF8_IS_INVARIANT(*s)) {
4591                     if (_isQUOTEMETA(*s)) {
4592                         to_quote = TRUE;
4593                     }
4594                 }
4595                 else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(s, s + len)) {
4596                     if (
4597 #ifdef USE_LOCALE_CTYPE
4598                     /* In locale, we quote all non-ASCII Latin1 chars.
4599                      * Otherwise use the quoting rules */
4600
4601                     IN_LC_RUNTIME(LC_CTYPE)
4602                         ||
4603 #endif
4604                         _isQUOTEMETA(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s + 1))))
4605                     {
4606                         to_quote = TRUE;
4607                     }
4608                 }
4609                 else if (is_QUOTEMETA_high(s)) {
4610                     to_quote = TRUE;
4611                 }
4612
4613                 if (to_quote) {
4614                     *d++ = '\\';
4615                 }
4616                 if (ulen > len)
4617                     ulen = len;
4618                 len -= ulen;
4619                 while (ulen--)
4620                     *d++ = *s++;
4621             }
4622             SvUTF8_on(TARG);
4623         }
4624         else if (IN_UNI_8_BIT) {
4625             while (len--) {
4626                 if (_isQUOTEMETA(*s))
4627                     *d++ = '\\';
4628                 *d++ = *s++;
4629             }
4630         }
4631         else {
4632             /* For non UNI_8_BIT (and hence in locale) just quote all \W
4633              * including everything above ASCII */
4634             while (len--) {
4635                 if (!isWORDCHAR_A(*s))
4636                     *d++ = '\\';
4637                 *d++ = *s++;
4638             }
4639         }
4640         *d = '\0';
4641         SvCUR_set(TARG, d - SvPVX_const(TARG));
4642         (void)SvPOK_only_UTF8(TARG);
4643     }
4644     else
4645         sv_setpvn(TARG, s, len);
4646     SETTARG;
4647     return NORMAL;
4648 }
4649
4650 PP(pp_fc)
4651 {
4652     dTARGET;
4653     dSP;
4654     SV *source = TOPs;
4655     STRLEN len;
4656     STRLEN min;
4657     SV *dest;
4658     const U8 *s;
4659     const U8 *send;
4660     U8 *d;
4661     U8 tmpbuf[UTF8_MAXBYTES_CASE + 1];
4662 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
4663    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
4664                                       || UNICODE_DOT_DOT_VERSION > 0)
4665     const bool full_folding = TRUE; /* This variable is here so we can easily
4666                                        move to more generality later */
4667 #else
4668     const bool full_folding = FALSE;
4669 #endif
4670     const U8 flags = ( full_folding      ? FOLD_FLAGS_FULL   : 0 )
4671 #ifdef USE_LOCALE_CTYPE
4672                    | ( IN_LC_RUNTIME(LC_CTYPE) ? FOLD_FLAGS_LOCALE : 0 )
4673 #endif
4674     ;
4675
4676     /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4677      * You are welcome(?) -Hugmeir
4678      */
4679
4680     SvGETMAGIC(source);
4681
4682     dest = TARG;
4683
4684     if (SvOK(source)) {
4685         s = (const U8*)SvPV_nomg_const(source, len);
4686     } else {
4687         if (ckWARN(WARN_UNINITIALIZED))
4688             report_uninit(source);
4689         s = (const U8*)"";
4690         len = 0;
4691     }
4692
4693     min = len + 1;
4694
4695     SvUPGRADE(dest, SVt_PV);
4696     d = (U8*)SvGROW(dest, min);
4697     (void)SvPOK_only(dest);
4698
4699     SETs(dest);
4700
4701     send = s + len;
4702
4703 #ifdef USE_LOCALE_CTYPE
4704
4705     if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
4706         _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4707     }
4708
4709 #endif
4710
4711     if (DO_UTF8(source)) { /* UTF-8 flagged string. */
4712         while (s < send) {
4713             const STRLEN u = UTF8SKIP(s);
4714             STRLEN ulen;
4715
4716             _toFOLD_utf8_flags(s, send, tmpbuf, &ulen, flags);
4717
4718             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4719                 const UV o = d - (U8*)SvPVX_const(dest);
4720                 d = o + (U8*) SvGROW(dest, min);
4721             }
4722
4723             Copy(tmpbuf, d, ulen, U8);
4724             d += ulen;
4725             s += u;
4726         }
4727         SvUTF8_on(dest);
4728     } /* Unflagged string */
4729     else if (len) {
4730 #ifdef USE_LOCALE_CTYPE
4731         if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
4732             if (IN_UTF8_CTYPE_LOCALE) {
4733                 goto do_uni_folding;
4734             }
4735             for (; s < send; d++, s++)
4736                 *d = (U8) toFOLD_LC(*s);
4737         }
4738         else
4739 #endif
4740         if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
4741             for (; s < send; d++, s++)
4742                 *d = toFOLD(*s);
4743         }
4744         else {
4745 #ifdef USE_LOCALE_CTYPE
4746       do_uni_folding:
4747 #endif
4748             /* For ASCII and the Latin-1 range, there's potentially three
4749              * troublesome folds:
4750              *      \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
4751              *             casefolding becomes 'ss';
4752              *      \x{B5} (\N{MICRO SIGN}), which under any fold becomes
4753              *             \x{3BC} (\N{GREEK SMALL LETTER MU})
4754              *      I      only in Turkic locales, this folds to \x{131}
4755              *             \N{LATIN SMALL LETTER DOTLESS I}
4756              * For the rest, the casefold is their lowercase.  */
4757             for (; s < send; d++, s++) {
4758                 if (    UNLIKELY(*s == MICRO_SIGN)
4759 #ifdef USE_LOCALE_CTYPE
4760                     || (   UNLIKELY(PL_in_utf8_turkic_locale)
4761                         && UNLIKELY(IN_LC_RUNTIME(LC_CTYPE))
4762                         && UNLIKELY(*s == 'I'))
4763 #endif
4764                 ) {
4765                     Size_t extra = send - s
4766                                  + variant_under_utf8_count(s, send);
4767
4768                     /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
4769                      * and 'I' in Turkic locales is \N{LATIN SMALL LETTER
4770                      * DOTLESS I} both of which are outside of the latin-1
4771                      * range. There's a couple of ways to deal with this -- khw
4772                      * discusses them in pp_lc/uc, so go there :) What we do
4773                      * here is upgrade what we had already casefolded, then
4774                      * enter an inner loop that appends the rest of the
4775                      * characters as UTF-8.
4776                      *
4777                      * First we calculate the needed size of the upgraded dest
4778                      * beyond what's been processed already (the upgrade
4779                      * function figures that out).  Except for the 'I' in
4780                      * Turkic locales, in UTF-8 strings, the fold case of a
4781                      * character below 256 occupies the same number of bytes as
4782                      * the original (even the Sharp S).  Therefore, the space
4783                      * needed is the number of bytes remaining plus the number
4784                      * of characters that become two bytes when converted to
4785                      * UTF-8 plus, in turkish locales, the number of 'I's */
4786
4787                     if (UNLIKELY(*s == 'I')) {
4788                         const U8 * s_peek = s;
4789
4790                         do {
4791                             extra++;
4792
4793                             s_peek = (U8 *) memchr(s_peek + 1, 'i',
4794                                                    send - (s_peek + 1));
4795                         } while (s_peek != NULL);
4796                     }
4797
4798                     /* Growing may move things, so have to save and recalculate
4799                      * 'd' */
4800                     len = d - (U8*)SvPVX_const(dest);
4801                     SvCUR_set(dest, len);
4802                     len = sv_utf8_upgrade_flags_grow(dest,
4803                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4804                                                 extra);
4805                     d = (U8*)SvPVX(dest) + len;
4806
4807                     *d++ = UTF8_TWO_BYTE_HI(GREEK_SMALL_LETTER_MU);
4808                     *d++ = UTF8_TWO_BYTE_LO(GREEK_SMALL_LETTER_MU);
4809                     s++;
4810
4811                     for (; s < send; s++) {
4812                         STRLEN ulen;
4813                         _to_uni_fold_flags(*s, d, &ulen, flags);
4814                         d += ulen;
4815                     }
4816                     break;
4817                 }
4818                 else if (   UNLIKELY(*s == LATIN_SMALL_LETTER_SHARP_S)
4819                          && full_folding)
4820                 {
4821                     /* Under full casefolding, LATIN SMALL LETTER SHARP S
4822                      * becomes "ss", which may require growing the SV. */
4823                     if (SvLEN(dest) < ++min) {
4824                         const UV o = d - (U8*)SvPVX_const(dest);
4825                         d = o + (U8*) SvGROW(dest, min);
4826                      }
4827                     *(d)++ = 's';
4828                     *d = 's';
4829                 }
4830                 else { /* Else, the fold is the lower case */
4831                     *d = toLOWER_LATIN1(*s);
4832                 }
4833              }
4834         }
4835     }
4836     *d = '\0';
4837     SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4838
4839 #ifdef USE_LOCALE_CTYPE
4840     if (IN_LC_RUNTIME(LC_CTYPE)) {
4841         TAINT;
4842         SvTAINTED_on(dest);
4843     }
4844 #endif
4845     if (SvTAINTED(source))
4846         SvTAINT(dest);
4847     SvSETMAGIC(dest);
4848     RETURN;
4849 }
4850
4851 /* Arrays. */
4852
4853 PP(pp_aslice)
4854 {
4855     dSP; dMARK; dORIGMARK;
4856     AV *const av = MUTABLE_AV(POPs);
4857     const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4858
4859     if (SvTYPE(av) == SVt_PVAV) {
4860         const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4861         bool can_preserve = FALSE;
4862
4863         if (localizing) {
4864             MAGIC *mg;
4865             HV *stash;
4866
4867             can_preserve = SvCANEXISTDELETE(av);
4868         }
4869
4870         if (lval && localizing) {
4871             SV **svp;
4872             SSize_t max = -1;
4873             for (svp = MARK + 1; svp <= SP; svp++) {
4874                 const SSize_t elem = SvIV(*svp);
4875                 if (elem > max)
4876                     max = elem;
4877             }
4878             if (max > AvMAX(av))
4879                 av_extend(av, max);
4880         }
4881
4882         while (++MARK <= SP) {
4883             SV **svp;
4884             SSize_t elem = SvIV(*MARK);
4885             bool preeminent = TRUE;
4886
4887             if (localizing && can_preserve) {
4888                 /* If we can determine whether the element exist,
4889                  * Try to preserve the existenceness of a tied array
4890                  * element by using EXISTS and DELETE if possible.
4891                  * Fallback to FETCH and STORE otherwise. */
4892                 preeminent = av_exists(av, elem);
4893             }
4894
4895             svp = av_fetch(av, elem, lval);
4896             if (lval) {
4897                 if (!svp || !*svp)
4898                     DIE(aTHX_ PL_no_aelem, elem);
4899                 if (localizing) {
4900                     if (preeminent)
4901                         save_aelem(av, elem, svp);
4902                     else
4903                         SAVEADELETE(av, elem);
4904                 }
4905             }
4906             *MARK = svp ? *svp : &PL_sv_undef;
4907         }
4908     }
4909     if (GIMME_V != G_ARRAY) {
4910         MARK = ORIGMARK;
4911         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4912         SP = MARK;
4913     }
4914     RETURN;
4915 }
4916
4917 PP(pp_kvaslice)
4918 {
4919     dSP; dMARK;
4920     AV *const av = MUTABLE_AV(POPs);
4921     I32 lval = (PL_op->op_flags & OPf_MOD);
4922     SSize_t items = SP - MARK;
4923
4924     if (PL_op->op_private & OPpMAYBE_LVSUB) {
4925        const I32 flags = is_lvalue_sub();
4926        if (flags) {
4927            if (!(flags & OPpENTERSUB_INARGS))
4928                /* diag_listed_as: Can't modify %s in %s */
4929                Perl_croak(aTHX_ "Can't modify index/value array slice in list assignment");
4930            lval = flags;
4931        }
4932     }
4933
4934     MEXTEND(SP,items);
4935     while (items > 1) {
4936         *(MARK+items*2-1) = *(MARK+items);
4937         items--;
4938     }
4939     items = SP-MARK;
4940     SP += items;
4941
4942     while (++MARK <= SP) {
4943         SV **svp;
4944
4945         svp = av_fetch(av, SvIV(*MARK), lval);
4946         if (lval) {
4947             if (!svp || !*svp || *svp == &PL_sv_undef) {
4948                 DIE(aTHX_ PL_no_aelem, SvIV(*MARK));
4949             }
4950             *MARK = sv_mortalcopy(*MARK);
4951         }
4952         *++MARK = svp ? *svp : &PL_sv_undef;
4953     }
4954     if (GIMME_V != G_ARRAY) {
4955         MARK = SP - items*2;
4956         *++MARK = items > 0 ? *SP : &PL_sv_undef;
4957         SP = MARK;
4958     }
4959     RETURN;
4960 }
4961
4962
4963 PP(pp_aeach)
4964 {
4965     dSP;
4966     AV *array = MUTABLE_AV(POPs);
4967     const U8 gimme = GIMME_V;
4968     IV *iterp = Perl_av_iter_p(aTHX_ array);
4969     const IV current = (*iterp)++;
4970
4971     if (current > av_tindex(array)) {
4972         *iterp = 0;
4973         if (gimme == G_SCALAR)
4974             RETPUSHUNDEF;
4975         else
4976             RETURN;
4977     }
4978
4979     EXTEND(SP, 2);
4980     mPUSHi(current);
4981     if (gimme == G_ARRAY) {
4982         SV **const element = av_fetch(array, current, 0);
4983         PUSHs(element ? *element : &PL_sv_undef);
4984     }
4985     RETURN;
4986 }
4987
4988 /* also used for: pp_avalues()*/
4989 PP(pp_akeys)
4990 {
4991     dSP;
4992     AV *array = MUTABLE_AV(POPs);
4993     const U8 gimme = GIMME_V;
4994
4995     *Perl_av_iter_p(aTHX_ array) = 0;
4996
4997     if (gimme == G_SCALAR) {
4998         dTARGET;
4999         PUSHi(av_tindex(array) + 1);
5000     }
5001     else if (gimme == G_ARRAY) {
5002       if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
5003         const I32 flags = is_lvalue_sub();
5004         if (flags && !(flags & OPpENTERSUB_INARGS))
5005             /* diag_listed_as: Can't modify %s in %s */
5006             Perl_croak(aTHX_
5007                       "Can't modify keys on array in list assignment");
5008       }
5009       {
5010         IV n = Perl_av_len(aTHX_ array);
5011         IV i;
5012
5013         EXTEND(SP, n + 1);
5014
5015         if (  PL_op->op_type == OP_AKEYS
5016            || (  PL_op->op_type == OP_AVHVSWITCH
5017               && (PL_op->op_private & 3) + OP_AEACH == OP_AKEYS  ))
5018         {
5019             for (i = 0;  i <= n;  i++) {
5020                 mPUSHi(i);
5021             }
5022         }
5023         else {
5024             for (i = 0;  i <= n;  i++) {
5025                 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
5026                 PUSHs(elem ? *elem : &PL_sv_undef);
5027             }
5028         }
5029       }
5030     }
5031     RETURN;
5032 }
5033
5034 /* Associative arrays. */
5035
5036 PP(pp_each)
5037 {
5038     dSP;
5039     HV * hash = MUTABLE_HV(POPs);
5040     HE *entry;
5041     const U8 gimme = GIMME_V;
5042
5043     entry = hv_iternext(hash);
5044
5045     EXTEND(SP, 2);
5046     if (entry) {
5047         SV* const sv = hv_iterkeysv(entry);
5048         PUSHs(sv);
5049         if (gimme == G_ARRAY) {
5050             SV *val;
5051             val = hv_iterval(hash, entry);
5052             PUSHs(val);
5053         }
5054     }
5055     else if (gimme == G_SCALAR)
5056         RETPUSHUNDEF;
5057
5058     RETURN;
5059 }
5060
5061 STATIC OP *
5062 S_do_delete_local(pTHX)
5063 {
5064     dSP;
5065     const U8 gimme = GIMME_V;
5066     const MAGIC *mg;
5067     HV *stash;
5068     const bool sliced = !!(PL_op->op_private & OPpSLICE);
5069     SV **unsliced_keysv = sliced ? NULL : sp--;
5070     SV * const osv = POPs;
5071     SV **mark = sliced ? PL_stack_base + POPMARK : unsliced_keysv-1;
5072     dORIGMARK;
5073     const bool tied = SvRMAGICAL(osv)
5074                             && mg_find((const SV *)osv, PERL_MAGIC_tied);
5075     const bool can_preserve = SvCANEXISTDELETE(osv);
5076     const U32 type = SvTYPE(osv);
5077     SV ** const end = sliced ? SP : unsliced_keysv;
5078
5079     if (type == SVt_PVHV) {                     /* hash element */
5080             HV * const hv = MUTABLE_HV(osv);
5081             while (++MARK <= end) {
5082                 SV * const keysv = *MARK;
5083                 SV *sv = NULL;
5084                 bool preeminent = TRUE;
5085                 if (can_preserve)
5086                     preeminent = hv_exists_ent(hv, keysv, 0);
5087                 if (tied) {
5088                     HE *he = hv_fetch_ent(hv, keysv, 1, 0);
5089                     if (he)
5090                         sv = HeVAL(he);
5091                     else
5092                         preeminent = FALSE;
5093                 }
5094                 else {
5095                     sv = hv_delete_ent(hv, keysv, 0, 0);
5096                     if (preeminent)
5097                         SvREFCNT_inc_simple_void(sv); /* De-mortalize */
5098                 }
5099                 if (preeminent) {
5100                     if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5101                     save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
5102                     if (tied) {
5103                         *MARK = sv_mortalcopy(sv);
5104                         mg_clear(sv);
5105                     } else
5106                         *MARK = sv;
5107                 }
5108                 else {
5109                     SAVEHDELETE(hv, keysv);
5110                     *MARK = &PL_sv_undef;
5111                 }
5112             }
5113     }
5114     else if (type == SVt_PVAV) {                  /* array element */
5115             if (PL_op->op_flags & OPf_SPECIAL) {
5116                 AV * const av = MUTABLE_AV(osv);
5117                 while (++MARK <= end) {
5118                     SSize_t idx = SvIV(*MARK);
5119                     SV *sv = NULL;
5120                     bool preeminent = TRUE;
5121                     if (can_preserve)
5122                         preeminent = av_exists(av, idx);
5123                     if (tied) {
5124                         SV **svp = av_fetch(av, idx, 1);
5125                         if (svp)
5126                             sv = *svp;
5127                         else
5128                             preeminent = FALSE;
5129                     }
5130                     else {
5131                         sv = av_delete(av, idx, 0);
5132                         if (preeminent)
5133                            SvREFCNT_inc_simple_void(sv); /* De-mortalize */
5134                     }
5135                     if (preeminent) {
5136                         save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
5137                         if (tied) {
5138                             *MARK = sv_mortalcopy(sv);
5139                             mg_clear(sv);
5140                         } else
5141                             *MARK = sv;
5142                     }
5143                     else {
5144                         SAVEADELETE(av, idx);
5145                         *MARK = &PL_sv_undef;
5146                     }
5147                 }
5148             }
5149             else
5150                 DIE(aTHX_ "panic: avhv_delete no longer supported");
5151     }
5152     else
5153             DIE(aTHX_ "Not a HASH reference");
5154     if (sliced) {
5155         if (gimme == G_VOID)
5156             SP = ORIGMARK;
5157         else if (gimme == G_SCALAR) {
5158             MARK = ORIGMARK;
5159             if (SP > MARK)
5160                 *++MARK = *SP;
5161             else
5162                 *++MARK = &PL_sv_undef;
5163             SP = MARK;
5164         }
5165     }
5166     else if (gimme != G_VOID)
5167         PUSHs(*unsliced_keysv);
5168
5169     RETURN;
5170 }
5171
5172 PP(pp_delete)
5173 {
5174     dSP;
5175     U8 gimme;
5176     I32 discard;
5177
5178     if (PL_op->op_private & OPpLVAL_INTRO)
5179         return do_delete_local();
5180
5181     gimme = GIMME_V;
5182     discard = (gimme == G_VOID) ? G_DISCARD : 0;
5183
5184     if (PL_op->op_private & (OPpSLICE|OPpKVSLICE)) {
5185         dMARK; dORIGMARK;
5186         HV * const hv = MUTABLE_HV(POPs);
5187         const U32 hvtype = SvTYPE(hv);
5188         int skip = 0;
5189         if (PL_op->op_private & OPpKVSLICE) {
5190             SSize_t items = SP - MARK;
5191
5192             MEXTEND(SP,items);
5193             while (items > 1) {
5194                 *(MARK+items*2-1) = *(MARK+items);
5195                 items--;
5196             }
5197             items = SP - MARK;
5198             SP += items;
5199             skip = 1;
5200         }
5201         if (hvtype == SVt_PVHV) {                       /* hash element */
5202             while ((MARK += (1+skip)) <= SP) {
5203                 SV * const sv = hv_delete_ent(hv, *(MARK-skip), discard, 0);
5204                 *MARK = sv ? sv : &PL_sv_undef;
5205             }
5206         }
5207         else if (hvtype == SVt_PVAV) {                  /* array element */
5208             if (PL_op->op_flags & OPf_SPECIAL) {
5209                 while ((MARK += (1+skip)) <= SP) {
5210                     SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*(MARK-skip)), discard);
5211                     *MARK = sv ? sv : &PL_sv_undef;
5212                 }
5213             }
5214         }
5215         else
5216             DIE(aTHX_ "Not a HASH reference");
5217         if (discard)
5218             SP = ORIGMARK;
5219         else if (gimme == G_SCALAR) {
5220             MARK = ORIGMARK;
5221             if (SP > MARK)
5222                 *++MARK = *SP;
5223             else
5224                 *++MARK = &PL_sv_undef;
5225             SP = MARK;
5226         }
5227     }
5228     else {
5229         SV *keysv = POPs;
5230         HV * const hv = MUTABLE_HV(POPs);
5231         SV *sv = NULL;
5232         if (SvTYPE(hv) == SVt_PVHV)
5233             sv = hv_delete_ent(hv, keysv, discard, 0);
5234         else if (SvTYPE(hv) == SVt_PVAV) {
5235             if (PL_op->op_flags & OPf_SPECIAL)
5236                 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
5237             else
5238                 DIE(aTHX_ "panic: avhv_delete no longer supported");
5239         }
5240         else
5241             DIE(aTHX_ "Not a HASH reference");
5242         if (!sv)
5243             sv = &PL_sv_undef;
5244         if (!discard)
5245             PUSHs(sv);
5246     }
5247     RETURN;
5248 }
5249
5250 PP(pp_exists)
5251 {
5252     dSP;
5253     SV *tmpsv;
5254     HV *hv;
5255
5256     if (UNLIKELY( PL_op->op_private & OPpEXISTS_SUB )) {
5257         GV *gv;
5258         SV * const sv = POPs;
5259         CV * const cv = sv_2cv(sv, &hv, &gv, 0);
5260         if (cv)
5261             RETPUSHYES;
5262         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
5263             RETPUSHYES;
5264         RETPUSHNO;
5265     }
5266     tmpsv = POPs;
5267     hv = MUTABLE_HV(POPs);
5268     if (LIKELY( SvTYPE(hv) == SVt_PVHV )) {
5269         if (hv_exists_ent(hv, tmpsv, 0))
5270             RETPUSHYES;
5271     }
5272     else if (SvTYPE(hv) == SVt_PVAV) {
5273         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
5274             if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
5275                 RETPUSHYES;
5276         }
5277     }
5278     else {
5279         DIE(aTHX_ "Not a HASH reference");
5280     }
5281     RETPUSHNO;
5282 }
5283
5284 PP(pp_hslice)
5285 {
5286     dSP; dMARK; dORIGMARK;
5287     HV * const hv = MUTABLE_HV(POPs);
5288     const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
5289     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
5290     bool can_preserve = FALSE;
5291
5292     if (localizing) {
5293         MAGIC *mg;
5294         HV *stash;
5295
5296         if (SvCANEXISTDELETE(hv))
5297             can_preserve = TRUE;
5298     }
5299
5300     while (++MARK <= SP) {
5301         SV * const keysv = *MARK;
5302         SV **svp;
5303         HE *he;
5304         bool preeminent = TRUE;
5305
5306         if (localizing && can_preserve) {
5307             /* If we can determine whether the element exist,
5308              * try to preserve the existenceness of a tied hash
5309              * element by using EXISTS and DELETE if possible.
5310              * Fallback to FETCH and STORE otherwise. */
5311             preeminent = hv_exists_ent(hv, keysv, 0);
5312         }
5313
5314         he = hv_fetch_ent(hv, keysv, lval, 0);
5315         svp = he ? &HeVAL(he) : NULL;
5316
5317         if (lval) {
5318             if (!svp || !*svp || *svp == &PL_sv_undef) {
5319                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5320             }
5321             if (localizing) {
5322                 if (HvNAME_get(hv) && isGV_or_RVCV(*svp))
5323                     save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
5324                 else if (preeminent)
5325                     save_helem_flags(hv, keysv, svp,
5326                          (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
5327                 else
5328                     SAVEHDELETE(hv, keysv);
5329             }
5330         }
5331         *MARK = svp && *svp ? *svp : &PL_sv_undef;
5332     }
5333     if (GIMME_V != G_ARRAY) {
5334         MARK = ORIGMARK;
5335         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
5336         SP = MARK;
5337     }
5338     RETURN;
5339 }
5340
5341 PP(pp_kvhslice)
5342 {
5343     dSP; dMARK;
5344     HV * const hv = MUTABLE_HV(POPs);
5345     I32 lval = (PL_op->op_flags & OPf_MOD);
5346     SSize_t items = SP - MARK;
5347
5348     if (PL_op->op_private & OPpMAYBE_LVSUB) {
5349        const I32 flags = is_lvalue_sub();
5350        if (flags) {
5351            if (!(flags & OPpENTERSUB_INARGS))
5352                /* diag_listed_as: Can't modify %s in %s */
5353                Perl_croak(aTHX_ "Can't modify key/value hash slice in %s assignment",
5354                                  GIMME_V == G_ARRAY ? "list" : "scalar");
5355            lval = flags;
5356        }
5357     }
5358
5359     MEXTEND(SP,items);
5360     while (items > 1) {
5361         *(MARK+items*2-1) = *(MARK+items);
5362         items--;
5363     }
5364     items = SP-MARK;
5365     SP += items;
5366
5367     while (++MARK <= SP) {
5368         SV * const keysv = *MARK;
5369         SV **svp;
5370         HE *he;
5371
5372         he = hv_fetch_ent(hv, keysv, lval, 0);
5373         svp = he ? &HeVAL(he) : NULL;
5374
5375         if (lval) {
5376             if (!svp || !*svp || *svp == &PL_sv_undef) {
5377                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5378             }
5379             *MARK = sv_mortalcopy(*MARK);
5380         }
5381         *++MARK = svp && *svp ? *svp : &PL_sv_undef;
5382     }
5383     if (GIMME_V != G_ARRAY) {
5384         MARK = SP - items*2;
5385         *++MARK = items > 0 ? *SP : &PL_sv_undef;
5386         SP = MARK;
5387     }
5388     RETURN;
5389 }
5390
5391 /* List operators. */
5392
5393 PP(pp_list)
5394 {
5395     I32 markidx = POPMARK;
5396     if (GIMME_V != G_ARRAY) {
5397         /* don't initialize mark here, EXTEND() may move the stack */
5398         SV **mark;
5399         dSP;
5400         EXTEND(SP, 1);          /* in case no arguments, as in @empty */
5401         mark = PL_stack_base + markidx;
5402         if (++MARK <= SP)
5403             *MARK = *SP;                /* unwanted list, return last item */
5404         else
5405             *MARK = &PL_sv_undef;
5406         SP = MARK;
5407         PUTBACK;
5408     }
5409     return NORMAL;
5410 }
5411
5412 PP(pp_lslice)
5413 {
5414     dSP;
5415     SV ** const lastrelem = PL_stack_sp;
5416     SV ** const lastlelem = PL_stack_base + POPMARK;
5417     SV ** const firstlelem = PL_stack_base + POPMARK + 1;
5418     SV ** const firstrelem = lastlelem + 1;
5419     const U8 mod = PL_op->op_flags & OPf_MOD;
5420
5421     const I32 max = lastrelem - lastlelem;
5422     SV **lelem;
5423
5424     if (GIMME_V != G_ARRAY) {
5425         if (lastlelem < firstlelem) {
5426             EXTEND(SP, 1);
5427             *firstlelem = &PL_sv_undef;
5428         }
5429         else {
5430             I32 ix = SvIV(*lastlelem);
5431             if (ix < 0)
5432                 ix += max;
5433             if (ix < 0 || ix >= max)
5434                 *firstlelem = &PL_sv_undef;
5435             else
5436                 *firstlelem = firstrelem[ix];
5437         }
5438         SP = firstlelem;
5439         RETURN;
5440     }
5441
5442     if (max == 0) {
5443         SP = firstlelem - 1;
5444         RETURN;
5445     }
5446
5447     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
5448         I32 ix = SvIV(*lelem);
5449         if (ix < 0)
5450             ix += max;
5451         if (ix < 0 || ix >= max)
5452             *lelem = &PL_sv_undef;
5453         else {
5454             if (!(*lelem = firstrelem[ix]))
5455                 *lelem = &PL_sv_undef;
5456             else if (mod && SvPADTMP(*lelem)) {
5457                 *lelem = firstrelem[ix] = sv_mortalcopy(*lelem);
5458             }
5459         }
5460     }
5461     SP = lastlelem;
5462     RETURN;
5463 }
5464
5465 PP(pp_anonlist)
5466 {
5467     dSP; dMARK;
5468     const I32 items = SP - MARK;
5469     SV * const av = MUTABLE_SV(av_make(items, MARK+1));
5470     SP = MARK;
5471     mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5472             ? newRV_noinc(av) : av);
5473     RETURN;
5474 }
5475
5476 PP(pp_anonhash)
5477 {
5478     dSP; dMARK; dORIGMARK;
5479     HV* const hv = newHV();
5480     SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL
5481                                     ? newRV_noinc(MUTABLE_SV(hv))
5482                                     : MUTABLE_SV(hv) );
5483
5484     while (MARK < SP) {
5485         SV * const key =
5486             (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK);
5487         SV *val;
5488         if (MARK < SP)
5489         {
5490             MARK++;
5491             SvGETMAGIC(*MARK);
5492             val = newSV(0);
5493             sv_setsv_nomg(val, *MARK);
5494         }
5495         else
5496         {
5497             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
5498             val = newSV(0);
5499         }
5500         (void)hv_store_ent(hv,key,val,0);
5501     }
5502     SP = ORIGMARK;
5503     XPUSHs(retval);
5504     RETURN;
5505 }
5506
5507 PP(pp_splice)
5508 {
5509     dSP; dMARK; dORIGMARK;
5510     int num_args = (SP - MARK);
5511     AV *ary = MUTABLE_AV(*++MARK);
5512     SV **src;
5513     SV **dst;
5514     SSize_t i;
5515     SSize_t offset;
5516     SSize_t length;
5517     SSize_t newlen;
5518     SSize_t after;
5519     SSize_t diff;
5520     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5521
5522     if (mg) {
5523         return Perl_tied_method(aTHX_ SV_CONST(SPLICE), mark - 1, MUTABLE_SV(ary), mg,
5524                                     GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
5525                                     sp - mark);
5526     }
5527
5528     if (SvREADONLY(ary))
5529         Perl_croak_no_modify();
5530
5531     SP++;
5532
5533     if (++MARK < SP) {
5534         offset = i = SvIV(*MARK);
5535         if (offset < 0)
5536             offset += AvFILLp(ary) + 1;
5537         if (offset < 0)
5538             DIE(aTHX_ PL_no_aelem, i);
5539         if (++MARK < SP) {
5540             length = SvIVx(*MARK++);
5541             if (length < 0) {
5542                 length += AvFILLp(ary) - offset + 1;
5543                 if (length < 0)
5544                     length = 0;
5545             }
5546         }
5547         else
5548             length = AvMAX(ary) + 1;            /* close enough to infinity */
5549     }
5550     else {
5551         offset = 0;
5552         length = AvMAX(ary) + 1;
5553     }
5554     if (offset > AvFILLp(ary) + 1) {
5555         if (num_args > 2)
5556             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
5557         offset = AvFILLp(ary) + 1;
5558     }
5559     after = AvFILLp(ary) + 1 - (offset + length);
5560     if (after < 0) {                            /* not that much array */
5561         length += after;                        /* offset+length now in array */
5562         after = 0;
5563         if (!AvALLOC(ary))
5564             av_extend(ary, 0);
5565     }
5566
5567     /* At this point, MARK .. SP-1 is our new LIST */
5568
5569     newlen = SP - MARK;
5570     diff = newlen - length;
5571     if (newlen && !AvREAL(ary) && AvREIFY(ary))
5572         av_reify(ary);
5573
5574     /* make new elements SVs now: avoid problems if they're from the array */
5575     for (dst = MARK, i = newlen; i; i--) {
5576         SV * const h = *dst;
5577         *dst++ = newSVsv(h);
5578     }
5579
5580     if (diff < 0) {                             /* shrinking the area */
5581         SV **tmparyval = NULL;
5582         if (newlen) {
5583             Newx(tmparyval, newlen, SV*);       /* so remember insertion */
5584             Copy(MARK, tmparyval, newlen, SV*);
5585         }
5586
5587         MARK = ORIGMARK + 1;
5588         if (GIMME_V == G_ARRAY) {               /* copy return vals to stack */
5589             const bool real = cBOOL(AvREAL(ary));
5590             MEXTEND(MARK, length);
5591             if (real)
5592                 EXTEND_MORTAL(length);
5593             for (i = 0, dst = MARK; i < length; i++) {
5594                 if ((*dst = AvARRAY(ary)[i+offset])) {
5595                   if (real)
5596                     sv_2mortal(*dst);   /* free them eventually */
5597                 }
5598                 else
5599                     *dst = &PL_sv_undef;
5600                 dst++;
5601             }
5602             MARK += length - 1;
5603         }
5604         else {
5605             *MARK = AvARRAY(ary)[offset+length-1];
5606             if (AvREAL(ary)) {
5607                 sv_2mortal(*MARK);
5608                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5609                     SvREFCNT_dec(*dst++);       /* free them now */
5610             }
5611             if (!*MARK)
5612                 *MARK = &PL_sv_undef;
5613         }
5614         AvFILLp(ary) += diff;
5615
5616         /* pull up or down? */
5617
5618         if (offset < after) {                   /* easier to pull up */
5619             if (offset) {                       /* esp. if nothing to pull */
5620                 src = &AvARRAY(ary)[offset-1];
5621                 dst = src - diff;               /* diff is negative */
5622                 for (i = offset; i > 0; i--)    /* can't trust Copy */
5623                     *dst-- = *src--;
5624             }
5625             dst = AvARRAY(ary);
5626             AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5627             AvMAX(ary) += diff;
5628         }
5629         else {
5630             if (after) {                        /* anything to pull down? */
5631                 src = AvARRAY(ary) + offset + length;
5632                 dst = src + diff;               /* diff is negative */
5633                 Move(src, dst, after, SV*);
5634             }
5635             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5636                                                 /* avoid later double free */
5637         }
5638         i = -diff;
5639         while (i)
5640             dst[--i] = NULL;
5641
5642         if (newlen) {
5643             Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5644             Safefree(tmparyval);
5645         }
5646     }
5647     else {                                      /* no, expanding (or same) */
5648         SV** tmparyval = NULL;
5649         if (length) {
5650             Newx(tmparyval, length, SV*);       /* so remember deletion */
5651             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5652         }
5653
5654         if (diff > 0) {                         /* expanding */
5655             /* push up or down? */
5656             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5657                 if (offset) {
5658                     src = AvARRAY(ary);
5659                     dst = src - diff;
5660                     Move(src, dst, offset, SV*);
5661                 }
5662                 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5663                 AvMAX(ary) += diff;
5664                 AvFILLp(ary) += diff;
5665             }
5666             else {
5667                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
5668                     av_extend(ary, AvFILLp(ary) + diff);
5669                 AvFILLp(ary) += diff;
5670
5671                 if (after) {
5672                     dst = AvARRAY(ary) + AvFILLp(ary);
5673                     src = dst - diff;
5674                     for (i = after; i; i--) {
5675                         *dst-- = *src--;
5676                     }
5677                 }
5678             }
5679         }
5680
5681         if (newlen) {
5682             Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5683         }
5684
5685         MARK = ORIGMARK + 1;
5686         if (GIMME_V == G_ARRAY) {               /* copy return vals to stack */
5687             if (length) {
5688                 const bool real = cBOOL(AvREAL(ary));
5689                 if (real)
5690                     EXTEND_MORTAL(length);
5691                 for (i = 0, dst = MARK; i < length; i++) {
5692                     if ((*dst = tmparyval[i])) {
5693                       if (real)
5694                         sv_2mortal(*dst);       /* free them eventually */
5695                     }
5696                     else *dst = &PL_sv_undef;
5697                     dst++;
5698                 }
5699             }
5700             MARK += length - 1;
5701         }
5702         else if (length--) {
5703             *MARK = tmparyval[length];
5704             if (AvREAL(ary)) {
5705                 sv_2mortal(*MARK);
5706                 while (length-- > 0)
5707                     SvREFCNT_dec(tmparyval[length]);
5708             }
5709             if (!*MARK)
5710                 *MARK = &PL_sv_undef;
5711         }
5712         else
5713             *MARK = &PL_sv_undef;
5714         Safefree(tmparyval);
5715     }
5716
5717     if (SvMAGICAL(ary))
5718         mg_set(MUTABLE_SV(ary));
5719
5720     SP = MARK;
5721     RETURN;
5722 }
5723
5724 PP(pp_push)
5725 {
5726     dSP; dMARK; dORIGMARK; dTARGET;
5727     AV * const ary = MUTABLE_AV(*++MARK);
5728     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5729
5730     if (mg) {
5731         *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5732         PUSHMARK(MARK);
5733         PUTBACK;
5734         ENTER_with_name("call_PUSH");
5735         call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5736         LEAVE_with_name("call_PUSH");
5737         /* SPAGAIN; not needed: SP is assigned to immediately below */
5738     }
5739     else {
5740         /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
5741          * only need to save locally, not on the save stack */
5742         U16 old_delaymagic = PL_delaymagic;
5743
5744         if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify();
5745         PL_delaymagic = DM_DELAY;
5746         for (++MARK; MARK <= SP; MARK++) {
5747             SV *sv;
5748             if (*MARK) SvGETMAGIC(*MARK);
5749             sv = newSV(0);
5750             if (*MARK)
5751                 sv_setsv_nomg(sv, *MARK);
5752             av_store(ary, AvFILLp(ary)+1, sv);
5753         }
5754         if (PL_delaymagic & DM_ARRAY_ISA)
5755             mg_set(MUTABLE_SV(ary));
5756         PL_delaymagic = old_delaymagic;
5757     }
5758     SP = ORIGMARK;
5759     if (OP_GIMME(PL_op, 0) != G_VOID) {
5760         PUSHi( AvFILL(ary) + 1 );
5761     }
5762     RETURN;
5763 }
5764
5765 /* also used for: pp_pop()*/
5766 PP(pp_shift)
5767 {
5768     dSP;
5769     AV * const av = PL_op->op_flags & OPf_SPECIAL
5770         ? MUTABLE_AV(GvAVn(PL_defgv)) : MUTABLE_AV(POPs);
5771     SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5772     EXTEND(SP, 1);
5773     assert (sv);
5774     if (AvREAL(av))
5775         (void)sv_2mortal(sv);
5776     PUSHs(sv);
5777     RETURN;
5778 }
5779
5780 PP(pp_unshift)
5781 {
5782     dSP; dMARK; dORIGMARK; dTARGET;
5783     AV *ary = MUTABLE_AV(*++MARK);
5784     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5785
5786     if (mg) {
5787         *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5788         PUSHMARK(MARK);
5789         PUTBACK;
5790         ENTER_with_name("call_UNSHIFT");
5791         call_sv(SV_CONST(UNSHIFT),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5792         LEAVE_with_name("call_UNSHIFT");
5793         /* SPAGAIN; not needed: SP is assigned to immediately below */
5794     }
5795     else {
5796         /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
5797          * only need to save locally, not on the save stack */
5798         U16 old_delaymagic = PL_delaymagic;
5799         SSize_t i = 0;
5800
5801         av_unshift(ary, SP - MARK);
5802         PL_delaymagic = DM_DELAY;
5803         while (MARK < SP) {
5804             SV * const sv = newSVsv(*++MARK);
5805             (void)av_store(ary, i++, sv);
5806         }
5807         if (PL_delaymagic & DM_ARRAY_ISA)
5808             mg_set(MUTABLE_SV(ary));
5809         PL_delaymagic = old_delaymagic;
5810     }
5811     SP = ORIGMARK;
5812     if (OP_GIMME(PL_op, 0) != G_VOID) {
5813         PUSHi( AvFILL(ary) + 1 );
5814     }
5815     RETURN;
5816 }
5817
5818 PP(pp_reverse)
5819 {
5820     dSP; dMARK;
5821
5822     if (GIMME_V == G_ARRAY) {
5823         if (PL_op->op_private & OPpREVERSE_INPLACE) {
5824             AV *av;
5825
5826             /* See pp_sort() */
5827             assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5828             (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5829             av = MUTABLE_AV((*SP));
5830             /* In-place reversing only happens in void context for the array
5831              * assignment. We don't need to push anything on the stack. */
5832             SP = MARK;
5833
5834             if (SvMAGICAL(av)) {
5835                 SSize_t i, j;
5836                 SV *tmp = sv_newmortal();
5837                 /* For SvCANEXISTDELETE */
5838                 HV *stash;
5839                 const MAGIC *mg;
5840                 bool can_preserve = SvCANEXISTDELETE(av);
5841
5842                 for (i = 0, j = av_tindex(av); i < j; ++i, --j) {
5843                     SV *begin, *end;
5844
5845                     if (can_preserve) {
5846                         if (!av_exists(av, i)) {
5847                             if (av_exists(av, j)) {
5848                                 SV *sv = av_delete(av, j, 0);
5849                                 begin = *av_fetch(av, i, TRUE);
5850                                 sv_setsv_mg(begin, sv);
5851                             }
5852                             continue;
5853                         }
5854                         else if (!av_exists(av, j)) {
5855                             SV *sv = av_delete(av, i, 0);
5856                             end = *av_fetch(av, j, TRUE);
5857                             sv_setsv_mg(end, sv);
5858                             continue;
5859                         }
5860                     }
5861
5862                     begin = *av_fetch(av, i, TRUE);
5863                     end   = *av_fetch(av, j, TRUE);
5864                     sv_setsv(tmp,      begin);
5865                     sv_setsv_mg(begin, end);
5866                     sv_setsv_mg(end,   tmp);
5867                 }
5868             }
5869             else {
5870                 SV **begin = AvARRAY(av);
5871
5872                 if (begin) {
5873                     SV **end   = begin + AvFILLp(av);
5874
5875                     while (begin < end) {
5876                         SV * const tmp = *begin;
5877                         *begin++ = *end;
5878                         *end--   = tmp;
5879                     }
5880                 }
5881             }
5882         }
5883         else {
5884             SV **oldsp = SP;
5885             MARK++;
5886             while (MARK < SP) {
5887                 SV * const tmp = *MARK;
5888                 *MARK++ = *SP;
5889                 *SP--   = tmp;
5890             }
5891             /* safe as long as stack cannot get extended in the above */
5892             SP = oldsp;
5893         }
5894     }
5895     else {
5896         char *up;
5897         dTARGET;
5898         STRLEN len;
5899
5900         SvUTF8_off(TARG);                               /* decontaminate */
5901         if (SP - MARK > 1) {
5902             do_join(TARG, &PL_sv_no, MARK, SP);
5903             SP = MARK + 1;
5904             SETs(TARG);
5905         } else if (SP > MARK) {
5906             sv_setsv(TARG, *SP);
5907             SETs(TARG);
5908         } else {
5909             sv_setsv(TARG, DEFSV);
5910             XPUSHs(TARG);
5911         }
5912
5913         up = SvPV_force(TARG, len);
5914         if (len > 1) {
5915             char *down;
5916             if (DO_UTF8(TARG)) {        /* first reverse each character */
5917                 U8* s = (U8*)SvPVX(TARG);
5918                 const U8* send = (U8*)(s + len);
5919                 while (s < send) {
5920                     if (UTF8_IS_INVARIANT(*s)) {
5921                         s++;
5922                         continue;
5923                     }
5924                     else {
5925                         if (!utf8_to_uvchr_buf(s, send, 0))
5926                             break;
5927                         up = (char*)s;
5928                         s += UTF8SKIP(s);
5929                         down = (char*)(s - 1);
5930                         /* reverse this character */
5931                         while (down > up) {
5932                             const char tmp = *up;
5933                             *up++ = *down;
5934                             *down-- = tmp;
5935                         }
5936                     }
5937                 }
5938                 up = SvPVX(TARG);
5939             }
5940             down = SvPVX(TARG) + len - 1;
5941             while (down > up) {
5942                 const char tmp = *up;
5943                 *up++ = *down;
5944                 *down-- = tmp;
5945             }
5946             (void)SvPOK_only_UTF8(TARG);
5947         }
5948     }
5949     RETURN;
5950 }
5951
5952 PP(pp_split)
5953 {
5954     dSP; dTARG;
5955     AV *ary = (   (PL_op->op_private & OPpSPLIT_ASSIGN) /* @a = split */
5956                && (PL_op->op_flags & OPf_STACKED))      /* @{expr} = split */
5957                ? (AV *)POPs : NULL;
5958     IV limit = POPi;                    /* note, negative is forever */
5959     SV * const sv = POPs;
5960     STRLEN len;
5961     const char *s = SvPV_const(sv, len);
5962     const bool do_utf8 = DO_UTF8(sv);
5963     const bool in_uni_8_bit = IN_UNI_8_BIT;
5964     const char *strend = s + len;
5965     PMOP *pm = cPMOPx(PL_op);
5966     REGEXP *rx;
5967     SV *dstr;
5968     const char *m;
5969     SSize_t iters = 0;
5970     const STRLEN slen = do_utf8
5971                         ? utf8_length((U8*)s, (U8*)strend)
5972                         : (STRLEN)(strend - s);
5973     SSize_t maxiters = slen + 10;
5974     I32 trailing_empty = 0;
5975     const char *orig;
5976     const IV origlimit = limit;
5977     I32 realarray = 0;
5978     I32 base;
5979     const U8 gimme = GIMME_V;
5980     bool gimme_scalar;
5981     I32 oldsave = PL_savestack_ix;
5982     U32 make_mortal = SVs_TEMP;
5983     bool multiline = 0;
5984     MAGIC *mg = NULL;
5985
5986     rx = PM_GETRE(pm);
5987
5988     TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
5989              (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
5990
5991     /* handle @ary = split(...) optimisation */
5992     if (PL_op->op_private & OPpSPLIT_ASSIGN) {
5993         if (!(PL_op->op_flags & OPf_STACKED)) {
5994             if (PL_op->op_private & OPpSPLIT_LEX) {
5995                 if (PL_op->op_private & OPpLVAL_INTRO)
5996                     SAVECLEARSV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff));
5997                 ary = (AV *)PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff);
5998             }
5999             else {
6000                 GV *gv =
6001 #ifdef USE_ITHREADS
6002                         MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff));
6003 #else
6004                         pm->op_pmreplrootu.op_pmtargetgv;
6005 #endif
6006                 if (PL_op->op_private & OPpLVAL_INTRO)
6007                     ary = save_ary(gv);
6008                 else
6009                     ary = GvAVn(gv);
6010             }
6011             /* skip anything pushed by OPpLVAL_INTRO above */
6012             oldsave = PL_savestack_ix;
6013         }
6014
6015         realarray = 1;
6016         PUTBACK;
6017         av_extend(ary,0);
6018         (void)sv_2mortal(SvREFCNT_inc_simple_NN(sv));
6019         av_clear(ary);
6020         SPAGAIN;
6021         if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
6022             PUSHMARK(SP);
6023             XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
6024         }
6025         else {
6026             if (!AvREAL(ary)) {
6027                 I32 i;
6028                 AvREAL_on(ary);
6029                 AvREIFY_off(ary);
6030                 for (i = AvFILLp(ary); i >= 0; i--)
6031                     AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
6032             }
6033             /* temporarily switch stacks */
6034             SAVESWITCHSTACK(PL_curstack, ary);
6035             make_mortal = 0;
6036         }
6037     }
6038
6039     base = SP - PL_stack_base;
6040     orig = s;
6041     if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
6042         if (do_utf8) {
6043             while (s < strend && isSPACE_utf8_safe(s, strend))
6044                 s += UTF8SKIP(s);
6045         }
6046         else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
6047             while (s < strend && isSPACE_LC(*s))
6048                 s++;
6049         }
6050         else if (in_uni_8_bit) {
6051             while (s < strend && isSPACE_L1(*s))
6052                 s++;
6053         }
6054         else {
6055             while (s < strend && isSPACE(*s))
6056                 s++;
6057         }
6058     }
6059     if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
6060         multiline = 1;
6061     }
6062
6063     gimme_scalar = gimme == G_SCALAR && !ary;
6064
6065     if (!limit)
6066         limit = maxiters + 2;
6067     if (RX_EXTFLAGS(rx) & RXf_WHITE) {
6068         while (--limit) {
6069             m = s;
6070             /* this one uses 'm' and is a negative test */
6071             if (do_utf8) {
6072                 while (m < strend && ! isSPACE_utf8_safe(m, strend) ) {
6073                     const int t = UTF8SKIP(m);
6074                     /* isSPACE_utf8_safe returns FALSE for malform utf8 */
6075                     if (strend - m < t)
6076                         m = strend;
6077                     else
6078                         m += t;
6079                 }
6080             }
6081             else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
6082             {
6083                 while (m < strend && !isSPACE_LC(*m))
6084                     ++m;
6085             }
6086             else if (in_uni_8_bit) {
6087                 while (m < strend && !isSPACE_L1(*m))
6088                     ++m;
6089             } else {
6090                 while (m < strend && !isSPACE(*m))
6091                     ++m;
6092             }
6093             if (m >= strend)
6094                 break;
6095
6096             if (gimme_scalar) {
6097                 iters++;
6098                 if (m-s == 0)
6099                     trailing_empty++;
6100                 else
6101                     trailing_empty = 0;
6102             } else {
6103                 dstr = newSVpvn_flags(s, m-s,
6104                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6105                 XPUSHs(dstr);
6106             }
6107
6108             /* skip the whitespace found last */
6109             if (do_utf8)
6110                 s = m + UTF8SKIP(m);
6111             else
6112                 s = m + 1;
6113
6114             /* this one uses 's' and is a positive test */
6115             if (do_utf8) {
6116                 while (s < strend && isSPACE_utf8_safe(s, strend) )
6117                     s +=  UTF8SKIP(s);
6118             }
6119             else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
6120             {
6121                 while (s < strend && isSPACE_LC(*s))
6122                     ++s;
6123             }
6124             else if (in_uni_8_bit) {
6125                 while (s < strend && isSPACE_L1(*s))
6126                     ++s;
6127             } else {
6128                 while (s < strend && isSPACE(*s))
6129                     ++s;
6130             }
6131         }
6132     }
6133     else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
6134         while (--limit) {
6135             for (m = s; m < strend && *m != '\n'; m++)
6136                 ;
6137             m++;
6138             if (m >= strend)
6139                 break;
6140
6141             if (gimme_scalar) {
6142                 iters++;
6143                 if (m-s == 0)
6144                     trailing_empty++;
6145                 else
6146                     trailing_empty = 0;
6147             } else {
6148                 dstr = newSVpvn_flags(s, m-s,
6149                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6150                 XPUSHs(dstr);
6151             }
6152             s = m;
6153         }
6154     }
6155     else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
6156         /*
6157           Pre-extend the stack, either the number of bytes or
6158           characters in the string or a limited amount, triggered by:
6159
6160           my ($x, $y) = split //, $str;
6161             or
6162           split //, $str, $i;
6163         */
6164         if (!gimme_scalar) {
6165             const IV items = limit - 1;
6166             /* setting it to -1 will trigger a panic in EXTEND() */
6167             const SSize_t sslen = slen > SSize_t_MAX ?  -1 : (SSize_t)slen;
6168             if (items >=0 && items < sslen)
6169                 EXTEND(SP, items);
6170             else
6171                 EXTEND(SP, sslen);
6172         }
6173
6174         if (do_utf8) {
6175             while (--limit) {
6176                 /* keep track of how many bytes we skip over */
6177                 m = s;
6178                 s += UTF8SKIP(s);
6179                 if (gimme_scalar) {
6180                     iters++;
6181                     if (s-m == 0)
6182                         trailing_empty++;
6183                     else
6184                         trailing_empty = 0;
6185                 } else {
6186                     dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
6187
6188                     PUSHs(dstr);
6189                 }
6190
6191                 if (s >= strend)
6192                     break;
6193             }
6194         } else {
6195             while (--limit) {
6196                 if (gimme_scalar) {
6197                     iters++;
6198                 } else {
6199                     dstr = newSVpvn(s, 1);
6200
6201
6202                     if (make_mortal)
6203                         sv_2mortal(dstr);
6204
6205                     PUSHs(dstr);
6206                 }
6207
6208                 s++;
6209
6210                 if (s >= strend)
6211                     break;
6212             }
6213         }
6214     }
6215     else if (do_utf8 == (RX_UTF8(rx) != 0) &&
6216              (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
6217              && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
6218              && !(RX_EXTFLAGS(rx) & RXf_IS_ANCHORED)) {
6219         const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
6220         SV * const csv = CALLREG_INTUIT_STRING(rx);
6221
6222         len = RX_MINLENRET(rx);
6223         if (len == 1 && !RX_UTF8(rx) && !tail) {
6224             const char c = *SvPV_nolen_const(csv);
6225             while (--limit) {
6226                 for (m = s; m < strend && *m != c; m++)
6227                     ;
6228                 if (m >= strend)
6229                     break;
6230                 if (gimme_scalar) {
6231                     iters++;
6232                     if (m-s == 0)
6233                         trailing_empty++;
6234                     else
6235                         trailing_empty = 0;
6236                 } else {
6237                     dstr = newSVpvn_flags(s, m-s,
6238                                          (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6239                     XPUSHs(dstr);
6240                 }
6241                 /* The rx->minlen is in characters but we want to step
6242                  * s ahead by bytes. */
6243                 if (do_utf8)
6244                     s = (char*)utf8_hop((U8*)m, len);
6245                 else
6246                     s = m + len; /* Fake \n at the end */
6247             }
6248         }
6249         else {
6250             while (s < strend && --limit &&
6251               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
6252                              csv, multiline ? FBMrf_MULTILINE : 0)) )
6253             {
6254                 if (gimme_scalar) {
6255                     iters++;
6256                     if (m-s == 0)
6257                         trailing_empty++;
6258                     else
6259                         trailing_empty = 0;
6260                 } else {
6261                     dstr = newSVpvn_flags(s, m-s,
6262                                          (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6263                     XPUSHs(dstr);
6264                 }
6265                 /* The rx->minlen is in characters but we want to step
6266                  * s ahead by bytes. */
6267                 if (do_utf8)
6268                     s = (char*)utf8_hop((U8*)m, len);
6269                 else
6270                     s = m + len; /* Fake \n at the end */
6271             }
6272         }
6273     }
6274     else {
6275         maxiters += slen * RX_NPARENS(rx);
6276         while (s < strend && --limit)
6277         {
6278             I32 rex_return;
6279             PUTBACK;
6280             rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1,
6281                                      sv, NULL, 0);
6282             SPAGAIN;
6283             if (rex_return == 0)
6284                 break;
6285             TAINT_IF(RX_MATCH_TAINTED(rx));
6286             /* we never pass the REXEC_COPY_STR flag, so it should
6287              * never get copied */
6288             assert(!RX_MATCH_COPIED(rx));
6289             m = RX_OFFS(rx)[0].start + orig;
6290
6291             if (gimme_scalar) {
6292                 iters++;
6293                 if (m-s == 0)
6294                     trailing_empty++;
6295                 else
6296                     trailing_empty = 0;
6297             } else {
6298                 dstr = newSVpvn_flags(s, m-s,
6299                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6300                 XPUSHs(dstr);
6301             }
6302             if (RX_NPARENS(rx)) {
6303                 I32 i;
6304                 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
6305                     s = RX_OFFS(rx)[i].start + orig;
6306                     m = RX_OFFS(rx)[i].end + orig;
6307
6308                     /* japhy (07/27/01) -- the (m && s) test doesn't catch
6309                        parens that didn't match -- they should be set to
6310                        undef, not the empty string */
6311                     if (gimme_scalar) {
6312                         iters++;
6313                         if (m-s == 0)
6314                             trailing_empty++;
6315                         else
6316                             trailing_empty = 0;
6317                     } else {
6318                         if (m >= orig && s >= orig) {
6319                             dstr = newSVpvn_flags(s, m-s,
6320                                                  (do_utf8 ? SVf_UTF8 : 0)
6321                                                   | make_mortal);
6322                         }
6323                         else
6324                             dstr = &PL_sv_undef;  /* undef, not "" */
6325                         XPUSHs(dstr);
6326                     }
6327
6328                 }
6329             }
6330             s = RX_OFFS(rx)[0].end + orig;
6331         }
6332     }
6333
6334     if (!gimme_scalar) {
6335         iters = (SP - PL_stack_base) - base;
6336     }
6337     if (iters > maxiters)
6338         DIE(aTHX_ "Split loop");
6339
6340     /* keep field after final delim? */
6341     if (s < strend || (iters && origlimit)) {
6342         if (!gimme_scalar) {
6343             const STRLEN l = strend - s;
6344             dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6345             XPUSHs(dstr);
6346         }
6347         iters++;
6348     }
6349     else if (!origlimit) {
6350         if (gimme_scalar) {
6351             iters -= trailing_empty;
6352         } else {
6353             while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
6354                 if (TOPs && !make_mortal)
6355                     sv_2mortal(TOPs);
6356                 *SP-- = NULL;
6357                 iters--;
6358             }
6359         }
6360     }
6361
6362     PUTBACK;
6363     LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
6364     SPAGAIN;
6365     if (realarray) {
6366         if (!mg) {
6367             if (SvSMAGICAL(ary)) {
6368                 PUTBACK;
6369                 mg_set(MUTABLE_SV(ary));
6370                 SPAGAIN;
6371             }
6372             if (gimme == G_ARRAY) {
6373                 EXTEND(SP, iters);
6374                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6375                 SP += iters;
6376                 RETURN;
6377             }
6378         }
6379         else {
6380             PUTBACK;
6381             ENTER_with_name("call_PUSH");
6382             call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
6383             LEAVE_with_name("call_PUSH");
6384             SPAGAIN;
6385             if (gimme == G_ARRAY) {
6386                 SSize_t i;
6387                 /* EXTEND should not be needed - we just popped them */
6388                 EXTEND(SP, iters);
6389                 for (i=0; i < iters; i++) {
6390                     SV **svp = av_fetch(ary, i, FALSE);
6391                     PUSHs((svp) ? *svp : &PL_sv_undef);
6392                 }
6393                 RETURN;
6394             }
6395         }
6396     }
6397     else {
6398         if (gimme == G_ARRAY)
6399             RETURN;
6400     }
6401
6402     GETTARGET;
6403     XPUSHi(iters);
6404     RETURN;
6405 }
6406
6407 PP(pp_once)
6408 {
6409     dSP;
6410     SV *const sv = PAD_SVl(PL_op->op_targ);
6411
6412     if (SvPADSTALE(sv)) {
6413         /* First time. */
6414         SvPADSTALE_off(sv);
6415         RETURNOP(cLOGOP->op_other);
6416     }
6417     RETURNOP(cLOGOP->op_next);
6418 }
6419
6420 PP(pp_lock)
6421 {
6422     dSP;
6423     dTOPss;
6424     SV *retsv = sv;
6425     SvLOCK(sv);
6426     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6427      || SvTYPE(retsv) == SVt_PVCV) {
6428         retsv = refto(retsv);
6429     }
6430     SETs(retsv);
6431     RETURN;
6432 }
6433
6434
6435 /* used for: pp_padany(), pp_custom(); plus any system ops
6436  * that aren't implemented on a particular platform */
6437
6438 PP(unimplemented_op)
6439 {
6440     const Optype op_type = PL_op->op_type;
6441     /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
6442        with out of range op numbers - it only "special" cases op_custom.
6443        Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
6444        if we get here for a custom op then that means that the custom op didn't
6445        have an implementation. Given that OP_NAME() looks up the custom op
6446        by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
6447        registers &PL_unimplemented_op as the address of their custom op.
6448        NULL doesn't generate a useful error message. "custom" does. */
6449     const char *const name = op_type >= OP_max
6450         ? "[out of range]" : PL_op_name[PL_op->op_type];
6451     if(OP_IS_SOCKET(op_type))
6452         DIE(aTHX_ PL_no_sock_func, name);
6453     DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name,  op_type);
6454 }
6455
6456 static void
6457 S_maybe_unwind_defav(pTHX)
6458 {
6459     if (CX_CUR()->cx_type & CXp_HASARGS) {
6460         PERL_CONTEXT *cx = CX_CUR();
6461
6462         assert(CxHASARGS(cx));
6463         cx_popsub_args(cx);
6464         cx->cx_type &= ~CXp_HASARGS;
6465     }
6466 }
6467
6468 /* For sorting out arguments passed to a &CORE:: subroutine */
6469 PP(pp_coreargs)
6470 {
6471     dSP;
6472     int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
6473     int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0;
6474     AV * const at_ = GvAV(PL_defgv);
6475     SV **svp = at_ ? AvARRAY(at_) : NULL;
6476     I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
6477     I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
6478     bool seen_question = 0;
6479     const char *err = NULL;
6480     const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
6481
6482     /* Count how many args there are first, to get some idea how far to
6483        extend the stack. */
6484     while (oa) {
6485         if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
6486         maxargs++;
6487         if (oa & OA_OPTIONAL) seen_question = 1;
6488         if (!seen_question) minargs++;
6489         oa >>= 4;
6490     }
6491
6492     if(numargs < minargs) err = "Not enough";
6493     else if(numargs > maxargs) err = "Too many";
6494     if (err)
6495         /* diag_listed_as: Too many arguments for %s */
6496         Perl_croak(aTHX_
6497           "%s arguments for %s", err,
6498            opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv)
6499         );
6500
6501     /* Reset the stack pointer.  Without this, we end up returning our own
6502        arguments in list context, in addition to the values we are supposed
6503        to return.  nextstate usually does this on sub entry, but we need
6504        to run the next op with the caller's hints, so we cannot have a
6505        nextstate. */
6506     SP = PL_stack_base + CX_CUR()->blk_oldsp;
6507
6508     if(!maxargs) RETURN;
6509
6510     /* We do this here, rather than with a separate pushmark op, as it has
6511        to come in between two things this function does (stack reset and
6512        arg pushing).  This seems the easiest way to do it. */
6513     if (pushmark) {
6514         PUTBACK;
6515         (void)Perl_pp_pushmark(aTHX);
6516     }
6517
6518     EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
6519     PUTBACK; /* The code below can die in various places. */
6520
6521     oa = PL_opargs[opnum] >> OASHIFT;
6522     for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
6523         whicharg++;
6524         switch (oa & 7) {
6525         case OA_SCALAR:
6526           try_defsv:
6527             if (!numargs && defgv && whicharg == minargs + 1) {
6528                 PUSHs(DEFSV);
6529             }
6530             else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
6531             break;
6532         case OA_LIST:
6533             while (numargs--) {
6534                 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
6535                 svp++;
6536             }
6537             RETURN;
6538         case OA_AVREF:
6539             if (!numargs) {
6540                 GV *gv;
6541                 if (CvUNIQUE(find_runcv_where(FIND_RUNCV_level_eq,1,NULL)))
6542                     gv = PL_argvgv;
6543                 else {
6544                     S_maybe_unwind_defav(aTHX);
6545                     gv = PL_defgv;
6546                 }
6547                 PUSHs((SV *)GvAVn(gv));
6548                 break;
6549             }
6550             if (!svp || !*svp || !SvROK(*svp)
6551              || SvTYPE(SvRV(*svp)) != SVt_PVAV)
6552                 DIE(aTHX_
6553                 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6554                  "Type of arg %d to &CORE::%s must be array reference",
6555                   whicharg, PL_op_desc[opnum]
6556                 );
6557             PUSHs(SvRV(*svp));
6558             break;
6559         case OA_HVREF:
6560             if (!svp || !*svp || !SvROK(*svp)
6561              || (  SvTYPE(SvRV(*svp)) != SVt_PVHV
6562                 && (  opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN
6563                    || SvTYPE(SvRV(*svp)) != SVt_PVAV  )))
6564                 DIE(aTHX_
6565                 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6566                  "Type of arg %d to &CORE::%s must be hash%s reference",
6567                   whicharg, PL_op_desc[opnum],
6568                   opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN
6569                      ? ""
6570                      : " or array"
6571                 );
6572             PUSHs(SvRV(*svp));
6573             break;
6574         case OA_FILEREF:
6575             if (!numargs) PUSHs(NULL);
6576             else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
6577                 /* no magic here, as the prototype will have added an extra
6578                    refgen and we just want what was there before that */
6579                 PUSHs(SvRV(*svp));
6580             else {
6581                 const bool constr = PL_op->op_private & whicharg;
6582                 PUSHs(S_rv2gv(aTHX_
6583                     svp && *svp ? *svp : &PL_sv_undef,
6584                     constr, cBOOL(CopHINTS_get(PL_curcop) & HINT_STRICT_REFS),
6585                     !constr
6586                 ));
6587             }
6588             break;
6589         case OA_SCALARREF:
6590           if (!numargs) goto try_defsv;
6591           else {
6592             const bool wantscalar =
6593                 PL_op->op_private & OPpCOREARGS_SCALARMOD;
6594             if (!svp || !*svp || !SvROK(*svp)
6595                 /* We have to permit globrefs even for the \$ proto, as
6596                    *foo is indistinguishable from ${\*foo}, and the proto-
6597                    type permits the latter. */
6598              || SvTYPE(SvRV(*svp)) > (
6599                      wantscalar       ? SVt_PVLV
6600                    : opnum == OP_LOCK || opnum == OP_UNDEF
6601                                       ? SVt_PVCV
6602                    :                    SVt_PVHV
6603                 )
6604                )
6605                 DIE(aTHX_
6606                  "Type of arg %d to &CORE::%s must be %s",
6607                   whicharg, PL_op_name[opnum],
6608                   wantscalar
6609                     ? "scalar reference"
6610                     : opnum == OP_LOCK || opnum == OP_UNDEF
6611                        ? "reference to one of [$@%&*]"
6612                        : "reference to one of [$@%*]"
6613                 );
6614             PUSHs(SvRV(*svp));
6615             if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv) {
6616                 /* Undo @_ localisation, so that sub exit does not undo
6617                    part of our undeffing. */
6618                 S_maybe_unwind_defav(aTHX);
6619             }
6620           }
6621           break;
6622         default:
6623             DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
6624         }
6625         oa = oa >> 4;
6626     }
6627
6628     RETURN;
6629 }
6630
6631 /* Implement CORE::keys(),values(),each().
6632  *
6633  * We won't know until run-time whether the arg is an array or hash,
6634  * so this op calls
6635  *
6636  *    pp_keys/pp_values/pp_each
6637  * or
6638  *    pp_akeys/pp_avalues/pp_aeach
6639  *
6640  * as appropriate (or whatever pp function actually implements the OP_FOO
6641  * functionality for each FOO).
6642  */
6643
6644 PP(pp_avhvswitch)
6645 {
6646     dVAR; dSP;
6647     return PL_ppaddr[
6648                 (SvTYPE(TOPs) == SVt_PVAV ? OP_AEACH : OP_EACH)
6649                     + (PL_op->op_private & OPpAVHVSWITCH_MASK)
6650            ](aTHX);
6651 }
6652
6653 PP(pp_runcv)
6654 {
6655     dSP;
6656     CV *cv;
6657     if (PL_op->op_private & OPpOFFBYONE) {
6658         cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL);
6659     }
6660     else cv = find_runcv(NULL);
6661     XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
6662     RETURN;
6663 }
6664
6665 static void
6666 S_localise_aelem_lval(pTHX_ AV * const av, SV * const keysv,
6667                             const bool can_preserve)
6668 {
6669     const SSize_t ix = SvIV(keysv);
6670     if (can_preserve ? av_exists(av, ix) : TRUE) {
6671         SV ** const svp = av_fetch(av, ix, 1);
6672         if (!svp || !*svp)
6673             Perl_croak(aTHX_ PL_no_aelem, ix);
6674         save_aelem(av, ix, svp);
6675     }
6676     else
6677         SAVEADELETE(av, ix);
6678 }
6679
6680 static void
6681 S_localise_helem_lval(pTHX_ HV * const hv, SV * const keysv,
6682                             const bool can_preserve)
6683 {
6684     if (can_preserve ? hv_exists_ent(hv, keysv, 0) : TRUE) {
6685         HE * const he = hv_fetch_ent(hv, keysv, 1, 0);
6686         SV ** const svp = he ? &HeVAL(he) : NULL;
6687         if (!svp || !*svp)
6688             Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(keysv));
6689         save_helem_flags(hv, keysv, svp, 0);
6690     }
6691     else
6692         SAVEHDELETE(hv, keysv);
6693 }
6694
6695 static void
6696 S_localise_gv_slot(pTHX_ GV *gv, U8 type)
6697 {
6698     if (type == OPpLVREF_SV) {
6699         save_pushptrptr(gv, SvREFCNT_inc_simple(GvSV(gv)), SAVEt_GVSV);
6700         GvSV(gv) = 0;
6701     }
6702     else if (type == OPpLVREF_AV)
6703         /* XXX Inefficient, as it creates a new AV, which we are
6704                about to clobber.  */
6705         save_ary(gv);
6706     else {
6707         assert(type == OPpLVREF_HV);
6708         /* XXX Likewise inefficient.  */
6709         save_hash(gv);
6710     }
6711 }
6712
6713
6714 PP(pp_refassign)
6715 {
6716     dSP;
6717     SV * const key = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6718     SV * const left = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6719     dTOPss;
6720     const char *bad = NULL;
6721     const U8 type = PL_op->op_private & OPpLVREF_TYPE;
6722     if (!SvROK(sv)) DIE(aTHX_ "Assigned value is not a reference");
6723     switch (type) {
6724     case OPpLVREF_SV:
6725         if (SvTYPE(SvRV(sv)) > SVt_PVLV)
6726             bad = " SCALAR";
6727         break;
6728     case OPpLVREF_AV:
6729         if (SvTYPE(SvRV(sv)) != SVt_PVAV)
6730             bad = "n ARRAY";
6731         break;
6732     case OPpLVREF_HV:
6733         if (SvTYPE(SvRV(sv)) != SVt_PVHV)
6734             bad = " HASH";
6735         break;
6736     case OPpLVREF_CV:
6737         if (SvTYPE(SvRV(sv)) != SVt_PVCV)
6738             bad = " CODE";
6739     }
6740     if (bad)
6741         /* diag_listed_as: Assigned value is not %s reference */
6742         DIE(aTHX_ "Assigned value is not a%s reference", bad);
6743     {
6744     MAGIC *mg;
6745     HV *stash;
6746     switch (left ? SvTYPE(left) : 0) {
6747     case 0:
6748     {
6749         SV * const old = PAD_SV(ARGTARG);
6750         PAD_SETSV(ARGTARG, SvREFCNT_inc_NN(SvRV(sv)));
6751         SvREFCNT_dec(old);
6752         if ((PL_op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
6753                 == OPpLVAL_INTRO)
6754             SAVECLEARSV(PAD_SVl(ARGTARG));
6755         break;
6756     }
6757     case SVt_PVGV:
6758         if (PL_op->op_private & OPpLVAL_INTRO) {
6759             S_localise_gv_slot(aTHX_ (GV *)left, type);
6760         }
6761         gv_setref(left, sv);
6762         SvSETMAGIC(left);
6763         break;
6764     case SVt_PVAV:
6765         assert(key);
6766         if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6767             S_localise_aelem_lval(aTHX_ (AV *)left, key,
6768                                         SvCANEXISTDELETE(left));
6769         }
6770         av_store((AV *)left, SvIV(key), SvREFCNT_inc_simple_NN(SvRV(sv)));
6771         break;
6772     case SVt_PVHV:
6773         if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6774             assert(key);
6775             S_localise_helem_lval(aTHX_ (HV *)left, key,
6776                                         SvCANEXISTDELETE(left));
6777         }
6778         (void)hv_store_ent((HV *)left, key, SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
6779     }
6780     if (PL_op->op_flags & OPf_MOD)
6781         SETs(sv_2mortal(newSVsv(sv)));
6782     /* XXX else can weak references go stale before they are read, e.g.,
6783        in leavesub?  */
6784     RETURN;
6785     }
6786 }
6787
6788 PP(pp_lvref)
6789 {
6790     dSP;
6791     SV * const ret = sv_2mortal(newSV_type(SVt_PVMG));
6792     SV * const elem = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6793     SV * const arg = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6794     MAGIC * const mg = sv_magicext(ret, arg, PERL_MAGIC_lvref,
6795                                    &PL_vtbl_lvref, (char *)elem,
6796                                    elem ? HEf_SVKEY : (I32)ARGTARG);
6797     mg->mg_private = PL_op->op_private;
6798     if (PL_op->op_private & OPpLVREF_ITER)
6799         mg->mg_flags |= MGf_PERSIST;
6800     if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6801       if (elem) {
6802         MAGIC *mg;
6803         HV *stash;
6804         assert(arg);
6805         {
6806             const bool can_preserve = SvCANEXISTDELETE(arg);
6807             if (SvTYPE(arg) == SVt_PVAV)
6808               S_localise_aelem_lval(aTHX_ (AV *)arg, elem, can_preserve);
6809             else
6810               S_localise_helem_lval(aTHX_ (HV *)arg, elem, can_preserve);
6811         }
6812       }
6813       else if (arg) {
6814         S_localise_gv_slot(aTHX_ (GV *)arg,
6815                                  PL_op->op_private & OPpLVREF_TYPE);
6816       }
6817       else if (!(PL_op->op_private & OPpPAD_STATE))
6818         SAVECLEARSV(PAD_SVl(ARGTARG));
6819     }
6820     XPUSHs(ret);
6821     RETURN;
6822 }
6823
6824 PP(pp_lvrefslice)
6825 {
6826     dSP; dMARK;
6827     AV * const av = (AV *)POPs;
6828     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
6829     bool can_preserve = FALSE;
6830
6831     if (UNLIKELY(localizing)) {
6832         MAGIC *mg;
6833         HV *stash;
6834         SV **svp;
6835
6836         can_preserve = SvCANEXISTDELETE(av);
6837
6838         if (SvTYPE(av) == SVt_PVAV) {
6839             SSize_t max = -1;
6840
6841             for (svp = MARK + 1; svp <= SP; svp++) {
6842                 const SSize_t elem = SvIV(*svp);
6843                 if (elem > max)
6844                     max = elem;
6845             }
6846             if (max > AvMAX(av))
6847                 av_extend(av, max);
6848         }
6849     }
6850
6851     while (++MARK <= SP) {
6852         SV * const elemsv = *MARK;
6853         if (UNLIKELY(localizing)) {
6854             if (SvTYPE(av) == SVt_PVAV)
6855                 S_localise_aelem_lval(aTHX_ av, elemsv, can_preserve);
6856             else
6857                 S_localise_helem_lval(aTHX_ (HV *)av, elemsv, can_preserve);
6858         }
6859         *MARK = sv_2mortal(newSV_type(SVt_PVMG));
6860         sv_magic(*MARK,(SV *)av,PERL_MAGIC_lvref,(char *)elemsv,HEf_SVKEY);
6861     }
6862     RETURN;
6863 }
6864
6865 PP(pp_lvavref)
6866 {
6867     if (PL_op->op_flags & OPf_STACKED)
6868         Perl_pp_rv2av(aTHX);
6869     else
6870         Perl_pp_padav(aTHX);
6871     {
6872         dSP;
6873         dTOPss;
6874         SETs(0); /* special alias marker that aassign recognises */
6875         XPUSHs(sv);
6876         RETURN;
6877     }
6878 }
6879
6880 PP(pp_anonconst)
6881 {
6882     dSP;
6883     dTOPss;
6884     SETs(sv_2mortal((SV *)newCONSTSUB(SvTYPE(CopSTASH(PL_curcop))==SVt_PVHV
6885                                         ? CopSTASH(PL_curcop)
6886                                         : NULL,
6887                                       NULL, SvREFCNT_inc_simple_NN(sv))));
6888     RETURN;
6889 }
6890
6891
6892 /* process one subroutine argument - typically when the sub has a signature:
6893  * introduce PL_curpad[op_targ] and assign to it the value
6894  *  for $:   (OPf_STACKED ? *sp : $_[N])
6895  *  for @/%: @_[N..$#_]
6896  *
6897  * It's equivalent to
6898  *    my $foo = $_[N];
6899  * or
6900  *    my $foo = (value-on-stack)
6901  * or
6902  *    my @foo = @_[N..$#_]
6903  * etc
6904  */
6905
6906 PP(pp_argelem)
6907 {
6908     dTARG;
6909     SV *val;
6910     SV ** padentry;
6911     OP *o = PL_op;
6912     AV *defav = GvAV(PL_defgv); /* @_ */
6913     IV ix = PTR2IV(cUNOP_AUXo->op_aux);
6914     IV argc;
6915
6916     /* do 'my $var, @var or %var' action */
6917     padentry = &(PAD_SVl(o->op_targ));
6918     save_clearsv(padentry);
6919     targ = *padentry;
6920
6921     if ((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_SV) {
6922         if (o->op_flags & OPf_STACKED) {
6923             dSP;
6924             val = POPs;
6925             PUTBACK;
6926         }
6927         else {
6928             SV **svp;
6929             /* should already have been checked */
6930             assert(ix >= 0);
6931 #if IVSIZE > PTRSIZE
6932             assert(ix <= SSize_t_MAX);
6933 #endif
6934
6935             svp = av_fetch(defav, ix, FALSE);
6936             val = svp ? *svp : &PL_sv_undef;
6937         }
6938
6939         /* $var = $val */
6940
6941         /* cargo-culted from pp_sassign */
6942         assert(TAINTING_get || !TAINT_get);
6943         if (UNLIKELY(TAINT_get) && !SvTAINTED(val))
6944             TAINT_NOT;
6945
6946         SvSetMagicSV(targ, val);
6947         return o->op_next;
6948     }
6949
6950     /* must be AV or HV */
6951
6952     assert(!(o->op_flags & OPf_STACKED));
6953     argc = ((IV)AvFILL(defav) + 1) - ix;
6954
6955     /* This is a copy of the relevant parts of pp_aassign().
6956      */
6957     if ((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_AV) {
6958         IV i;
6959
6960         if (AvFILL((AV*)targ) > -1) {
6961             /* target should usually be empty. If we get get
6962              * here, someone's been doing some weird closure tricks.
6963              * Make a copy of all args before clearing the array,
6964              * to avoid the equivalent of @a = ($a[0]) prematurely freeing
6965              * elements. See similar code in pp_aassign.
6966              */
6967             for (i = 0; i < argc; i++) {
6968                 SV **svp = av_fetch(defav, ix + i, FALSE);
6969                 SV *newsv = newSV(0);
6970                 sv_setsv_flags(newsv,
6971                                 svp ? *svp : &PL_sv_undef,
6972                                 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
6973                 if (!av_store(defav, ix + i, newsv))
6974                     SvREFCNT_dec_NN(newsv);
6975             }
6976             av_clear((AV*)targ);
6977         }
6978
6979         if (argc <= 0)
6980             return o->op_next;
6981
6982         av_extend((AV*)targ, argc);
6983
6984         i = 0;
6985         while (argc--) {
6986             SV *tmpsv;
6987             SV **svp = av_fetch(defav, ix + i, FALSE);
6988             SV *val = svp ? *svp : &PL_sv_undef;
6989             tmpsv = newSV(0);
6990             sv_setsv(tmpsv, val);
6991             av_store((AV*)targ, i++, tmpsv);
6992             TAINT_NOT;
6993         }
6994
6995     }
6996     else {
6997         IV i;
6998
6999         assert((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_HV);
7000
7001         if (SvRMAGICAL(targ) || HvUSEDKEYS((HV*)targ)) {
7002             /* see "target should usually be empty" comment above */
7003             for (i = 0; i < argc; i++) {
7004                 SV **svp = av_fetch(defav, ix + i, FALSE);
7005                 SV *newsv = newSV(0);
7006                 sv_setsv_flags(newsv,
7007                                 svp ? *svp : &PL_sv_undef,
7008                                 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
7009                 if (!av_store(defav, ix + i, newsv))
7010                     SvREFCNT_dec_NN(newsv);
7011             }
7012             hv_clear((HV*)targ);
7013         }
7014
7015         if (argc <= 0)
7016             return o->op_next;
7017         assert(argc % 2 == 0);
7018
7019         i = 0;
7020         while (argc) {
7021             SV *tmpsv;
7022             SV **svp;
7023             SV *key;
7024             SV *val;
7025
7026             svp = av_fetch(defav, ix + i++, FALSE);
7027             key = svp ? *svp : &PL_sv_undef;
7028             svp = av_fetch(defav, ix + i++, FALSE);
7029             val = svp ? *svp : &PL_sv_undef;
7030
7031             argc -= 2;
7032             if (UNLIKELY(SvGMAGICAL(key)))
7033                 key = sv_mortalcopy(key);
7034             tmpsv = newSV(0);
7035             sv_setsv(tmpsv, val);
7036             hv_store_ent((HV*)targ, key, tmpsv, 0);
7037             TAINT_NOT;
7038         }
7039     }
7040
7041     return o->op_next;
7042 }
7043
7044 /* Handle a default value for one subroutine argument (typically as part
7045  * of a subroutine signature).
7046  * It's equivalent to
7047  *    @_ > op_targ ? $_[op_targ] : result_of(op_other)
7048  *
7049  * Intended to be used where op_next is an OP_ARGELEM
7050  *
7051  * We abuse the op_targ field slightly: it's an index into @_ rather than
7052  * into PL_curpad.
7053  */
7054
7055 PP(pp_argdefelem)
7056 {
7057     OP * const o = PL_op;
7058     AV *defav = GvAV(PL_defgv); /* @_ */
7059     IV ix = (IV)o->op_targ;
7060
7061     assert(ix >= 0);
7062 #if IVSIZE > PTRSIZE
7063     assert(ix <= SSize_t_MAX);
7064 #endif
7065
7066     if (AvFILL(defav) >= ix) {
7067         dSP;
7068         SV **svp = av_fetch(defav, ix, FALSE);
7069         SV  *val = svp ? *svp : &PL_sv_undef;
7070         XPUSHs(val);
7071         RETURN;
7072     }
7073     return cLOGOPo->op_other;
7074 }
7075
7076
7077 static SV *
7078 S_find_runcv_name(void)
7079 {
7080     dTHX;
7081     CV *cv;
7082     GV *gv;
7083     SV *sv;
7084
7085     cv = find_runcv(0);
7086     if (!cv)
7087         return &PL_sv_no;
7088
7089     gv = CvGV(cv);
7090     if (!gv)
7091         return &PL_sv_no;
7092
7093     sv = sv_2mortal(newSV(0));
7094     gv_fullname4(sv, gv, NULL, TRUE);
7095     return sv;
7096 }
7097
7098 /* Check a  a subs arguments - i.e. that it has the correct number of args
7099  * (and anything else we might think of in future). Typically used with
7100  * signatured subs.
7101  */
7102
7103 PP(pp_argcheck)
7104 {
7105     OP * const o       = PL_op;
7106     UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
7107     IV   params        = aux[0].iv;
7108     IV   opt_params    = aux[1].iv;
7109     char slurpy        = (char)(aux[2].iv);
7110     AV  *defav         = GvAV(PL_defgv); /* @_ */
7111     IV   argc;
7112     bool too_few;
7113
7114     assert(!SvMAGICAL(defav));
7115     argc = (AvFILLp(defav) + 1);
7116     too_few = (argc < (params - opt_params));
7117
7118     if (UNLIKELY(too_few || (!slurpy && argc > params)))
7119         /* diag_listed_as: Too few arguments for subroutine '%s' */
7120         /* diag_listed_as: Too many arguments for subroutine '%s' */
7121         Perl_croak_caller("Too %s arguments for subroutine '%" SVf "'",
7122                           too_few ? "few" : "many", S_find_runcv_name());
7123
7124     if (UNLIKELY(slurpy == '%' && argc > params && (argc - params) % 2))
7125         /* diag_listed_as: Odd name/value argument for subroutine '%s' */
7126         Perl_croak_caller("Odd name/value argument for subroutine '%" SVf "'",
7127                           S_find_runcv_name());
7128
7129     return NORMAL;
7130 }
7131
7132 /*
7133  * ex: set ts=8 sts=4 sw=4 et:
7134  */