pp.c

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