pp.c

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