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