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