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