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