pp.c

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