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