pp.c

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