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