pp.c

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