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