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     U8 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
  76     if (PL_op->op_flags & OPf_REF) {
  77         PUSHs(TARG);
  78         RETURN;
  79     }
  80     else if (PL_op->op_private & OPpMAYBE_LVSUB) {
  81         const I32 flags = is_lvalue_sub();
  82         if (flags && !(flags & OPpENTERSUB_INARGS)) {
  83             if (GIMME_V == G_SCALAR)
  84                 /* diag_listed_as: Can't return %s to lvalue scalar context */
  85                 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
  86             PUSHs(TARG);
  87             RETURN;
  88        }
  89     }
  90
  91     gimme = GIMME_V;
  92     if (gimme == G_ARRAY) {
  93         /* XXX see also S_pushav in pp_hot.c */
  94         const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
  95         EXTEND(SP, maxarg);
  96         if (SvMAGICAL(TARG)) {
  97             SSize_t i;
  98             for (i=0; i < maxarg; i++) {
  99                 SV * const * const svp = av_fetch(MUTABLE_AV(TARG), i, FALSE);
 100                 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
 101             }
 102         }
 103         else {
 104             SSize_t i;
 105             for (i=0; i < maxarg; i++) {
 106                 SV * const sv = AvARRAY((const AV *)TARG)[i];
 107                 SP[i+1] = sv ? sv : &PL_sv_undef;
 108             }
 109         }
 110         SP += maxarg;
 111     }
 112     else if (gimme == G_SCALAR) {
 113         SV* const sv = sv_newmortal();
 114         const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
 115         sv_setiv(sv, maxarg);
 116         PUSHs(sv);
 117     }
 118     RETURN;
 119 }
 120
 121 PP(pp_padhv)
 122 {
 123     dSP; dTARGET;
 124     U8 gimme;
 125
 126     assert(SvTYPE(TARG) == SVt_PVHV);
 127     XPUSHs(TARG);
 128     if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
 129         if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
 130             SAVECLEARSV(PAD_SVl(PL_op->op_targ));
 131
 132     if (PL_op->op_flags & OPf_REF)
 133         RETURN;
 134     else if (PL_op->op_private & OPpMAYBE_LVSUB) {
 135         const I32 flags = is_lvalue_sub();
 136         if (flags && !(flags & OPpENTERSUB_INARGS)) {
 137             if (GIMME_V == G_SCALAR)
 138                 /* diag_listed_as: Can't return %s to lvalue scalar context */
 139                 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
 140             RETURN;
 141         }
 142     }
 143
 144     gimme = GIMME_V;
 145     if (gimme == G_ARRAY) {
 146         RETURNOP(Perl_do_kv(aTHX));
 147     }
 148     else if ((PL_op->op_private & OPpTRUEBOOL
 149           || (  PL_op->op_private & OPpMAYBE_TRUEBOOL
 150              && block_gimme() == G_VOID  ))
 151           && (!SvRMAGICAL(TARG) || !mg_find(TARG, PERL_MAGIC_tied))
 152     )
 153         SETs(HvUSEDKEYS(TARG) ? &PL_sv_yes : &PL_sv_no);
 154     else if (gimme == G_SCALAR) {
 155         SV* const sv = Perl_hv_scalar(aTHX_ MUTABLE_HV(TARG));
 156         SETs(sv);
 157     }
 158     RETURN;
 159 }
 160
 161 PP(pp_padcv)
 162 {
 163     dSP; dTARGET;
 164     assert(SvTYPE(TARG) == SVt_PVCV);
 165     XPUSHs(TARG);
 166     RETURN;
 167 }
 168
 169 PP(pp_introcv)
 170 {
 171     dTARGET;
 172     SvPADSTALE_off(TARG);
 173     return NORMAL;
 174 }
 175
 176 PP(pp_clonecv)
 177 {
 178     dTARGET;
 179     CV * const protocv = PadnamePROTOCV(
 180         PadlistNAMESARRAY(CvPADLIST(find_runcv(NULL)))[ARGTARG]
 181     );
 182     assert(SvTYPE(TARG) == SVt_PVCV);
 183     assert(protocv);
 184     if (CvISXSUB(protocv)) { /* constant */
 185         /* XXX Should we clone it here? */
 186         /* If this changes to use SAVECLEARSV, we can move the SAVECLEARSV
 187            to introcv and remove the SvPADSTALE_off. */
 188         SAVEPADSVANDMORTALIZE(ARGTARG);
 189         PAD_SVl(ARGTARG) = SvREFCNT_inc_simple_NN(protocv);
 190     }
 191     else {
 192         if (CvROOT(protocv)) {
 193             assert(CvCLONE(protocv));
 194             assert(!CvCLONED(protocv));
 195         }
 196         cv_clone_into(protocv,(CV *)TARG);
 197         SAVECLEARSV(PAD_SVl(ARGTARG));
 198     }
 199     return NORMAL;
 200 }
 201
 202 /* Translations. */
 203
 204 /* In some cases this function inspects PL_op.  If this function is called
 205    for new op types, more bool parameters may need to be added in place of
 206    the checks.
 207
 208    When noinit is true, the absence of a gv will cause a retval of undef.
 209    This is unrelated to the cv-to-gv assignment case.
 210 */
 211
 212 static SV *
 213 S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict,
 214               const bool noinit)
 215 {
 216     if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv);
 217     if (SvROK(sv)) {
 218         if (SvAMAGIC(sv)) {
 219             sv = amagic_deref_call(sv, to_gv_amg);
 220         }
 221       wasref:
 222         sv = SvRV(sv);
 223         if (SvTYPE(sv) == SVt_PVIO) {
 224             GV * const gv = MUTABLE_GV(sv_newmortal());
 225             gv_init(gv, 0, "__ANONIO__", 10, 0);
 226             GvIOp(gv) = MUTABLE_IO(sv);
 227             SvREFCNT_inc_void_NN(sv);
 228             sv = MUTABLE_SV(gv);
 229         }
 230         else if (!isGV_with_GP(sv)) {
 231             Perl_die(aTHX_ "Not a GLOB reference");
 232         }
 233     }
 234     else {
 235         if (!isGV_with_GP(sv)) {
 236             if (!SvOK(sv)) {
 237                 /* If this is a 'my' scalar and flag is set then vivify
 238                  * NI-S 1999/05/07
 239                  */
 240                 if (vivify_sv && sv != &PL_sv_undef) {
 241                     GV *gv;
 242                     if (SvREADONLY(sv))
 243                         Perl_croak_no_modify();
 244                     if (cUNOP->op_targ) {
 245                         SV * const namesv = PAD_SV(cUNOP->op_targ);
 246                         HV *stash = CopSTASH(PL_curcop);
 247                         if (SvTYPE(stash) != SVt_PVHV) stash = NULL;
 248                         gv = MUTABLE_GV(newSV(0));
 249                         gv_init_sv(gv, stash, namesv, 0);
 250                     }
 251                     else {
 252                         const char * const name = CopSTASHPV(PL_curcop);
 253                         gv = newGVgen_flags(name,
 254                                 HvNAMEUTF8(CopSTASH(PL_curcop)) ? SVf_UTF8 : 0 );
 255                         SvREFCNT_inc_simple_void_NN(gv);
 256                     }
 257                     prepare_SV_for_RV(sv);
 258                     SvRV_set(sv, MUTABLE_SV(gv));
 259                     SvROK_on(sv);
 260                     SvSETMAGIC(sv);
 261                     goto wasref;
 262                 }
 263                 if (PL_op->op_flags & OPf_REF || strict) {
 264                     Perl_die(aTHX_ PL_no_usym, "a symbol");
 265                 }
 266                 if (ckWARN(WARN_UNINITIALIZED))
 267                     report_uninit(sv);
 268                 return &PL_sv_undef;
 269             }
 270             if (noinit)
 271             {
 272                 if (!(sv = MUTABLE_SV(gv_fetchsv_nomg(
 273                            sv, GV_ADDMG, SVt_PVGV
 274                    ))))
 275                     return &PL_sv_undef;
 276             }
 277             else {
 278                 if (strict) {
 279                     Perl_die(aTHX_
 280                              PL_no_symref_sv,
 281                              sv,
 282                              (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""),
 283                              "a symbol"
 284                              );
 285                 }
 286                 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
 287                     == OPpDONT_INIT_GV) {
 288                     /* We are the target of a coderef assignment.  Return
 289                        the scalar unchanged, and let pp_sasssign deal with
 290                        things.  */
 291                     return sv;
 292                 }
 293                 sv = MUTABLE_SV(gv_fetchsv_nomg(sv, GV_ADD, SVt_PVGV));
 294             }
 295             /* FAKE globs in the symbol table cause weird bugs (#77810) */
 296             SvFAKE_off(sv);
 297         }
 298     }
 299     if (SvFAKE(sv) && !(PL_op->op_private & OPpALLOW_FAKE)) {
 300         SV *newsv = sv_newmortal();
 301         sv_setsv_flags(newsv, sv, 0);
 302         SvFAKE_off(newsv);
 303         sv = newsv;
 304     }
 305     return sv;
 306 }
 307
 308 PP(pp_rv2gv)
 309 {
 310     dSP; dTOPss;
 311
 312     sv = S_rv2gv(aTHX_
 313           sv, PL_op->op_private & OPpDEREF,
 314           PL_op->op_private & HINT_STRICT_REFS,
 315           ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD))
 316              || PL_op->op_type == OP_READLINE
 317          );
 318     if (PL_op->op_private & OPpLVAL_INTRO)
 319         save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
 320     SETs(sv);
 321     RETURN;
 322 }
 323
 324 /* Helper function for pp_rv2sv and pp_rv2av  */
 325 GV *
 326 Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
 327                 const svtype type, SV ***spp)
 328 {
 329     GV *gv;
 330
 331     PERL_ARGS_ASSERT_SOFTREF2XV;
 332
 333     if (PL_op->op_private & HINT_STRICT_REFS) {
 334         if (SvOK(sv))
 335             Perl_die(aTHX_ PL_no_symref_sv, sv,
 336                      (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
 337         else
 338             Perl_die(aTHX_ PL_no_usym, what);
 339     }
 340     if (!SvOK(sv)) {
 341         if (
 342           PL_op->op_flags & OPf_REF
 343         )
 344             Perl_die(aTHX_ PL_no_usym, what);
 345         if (ckWARN(WARN_UNINITIALIZED))
 346             report_uninit(sv);
 347         if (type != SVt_PV && GIMME_V == G_ARRAY) {
 348             (*spp)--;
 349             return NULL;
 350         }
 351         **spp = &PL_sv_undef;
 352         return NULL;
 353     }
 354     if ((PL_op->op_flags & OPf_SPECIAL) &&
 355         !(PL_op->op_flags & OPf_MOD))
 356         {
 357             if (!(gv = gv_fetchsv_nomg(sv, GV_ADDMG, type)))
 358                 {
 359                     **spp = &PL_sv_undef;
 360                     return NULL;
 361                 }
 362         }
 363     else {
 364         gv = gv_fetchsv_nomg(sv, GV_ADD, type);
 365     }
 366     return gv;
 367 }
 368
 369 PP(pp_rv2sv)
 370 {
 371     dSP; dTOPss;
 372     GV *gv = NULL;
 373
 374     SvGETMAGIC(sv);
 375     if (SvROK(sv)) {
 376         if (SvAMAGIC(sv)) {
 377             sv = amagic_deref_call(sv, to_sv_amg);
 378         }
 379
 380         sv = SvRV(sv);
 381         if (SvTYPE(sv) >= SVt_PVAV)
 382             DIE(aTHX_ "Not a SCALAR reference");
 383     }
 384     else {
 385         gv = MUTABLE_GV(sv);
 386
 387         if (!isGV_with_GP(gv)) {
 388             gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
 389             if (!gv)
 390                 RETURN;
 391         }
 392         sv = GvSVn(gv);
 393     }
 394     if (PL_op->op_flags & OPf_MOD) {
 395         if (PL_op->op_private & OPpLVAL_INTRO) {
 396             if (cUNOP->op_first->op_type == OP_NULL)
 397                 sv = save_scalar(MUTABLE_GV(TOPs));
 398             else if (gv)
 399                 sv = save_scalar(gv);
 400             else
 401                 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
 402         }
 403         else if (PL_op->op_private & OPpDEREF)
 404             sv = vivify_ref(sv, PL_op->op_private & OPpDEREF);
 405     }
 406     SPAGAIN; /* in case chasing soft refs reallocated the stack */
 407     SETs(sv);
 408     RETURN;
 409 }
 410
 411 PP(pp_av2arylen)
 412 {
 413     dSP;
 414     AV * const av = MUTABLE_AV(TOPs);
 415     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
 416     if (lvalue) {
 417         SV ** const svp = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
 418         if (!*svp) {
 419             *svp = newSV_type(SVt_PVMG);
 420             sv_magic(*svp, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
 421         }
 422         SETs(*svp);
 423     } else {
 424         SETs(sv_2mortal(newSViv(AvFILL(MUTABLE_AV(av)))));
 425     }
 426     RETURN;
 427 }
 428
 429 PP(pp_pos)
 430 {
 431     dSP; dTOPss;
 432
 433     if (PL_op->op_flags & OPf_MOD || LVRET) {
 434         SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));/* Not TARG RT#67838 */
 435         sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
 436         LvTYPE(ret) = '.';
 437         LvTARG(ret) = SvREFCNT_inc_simple(sv);
 438         SETs(ret);    /* no SvSETMAGIC */
 439     }
 440     else {
 441             const MAGIC * const mg = mg_find_mglob(sv);
 442             if (mg && mg->mg_len != -1) {
 443                 dTARGET;
 444                 STRLEN i = mg->mg_len;
 445                 if (mg->mg_flags & MGf_BYTES && DO_UTF8(sv))
 446                     i = sv_pos_b2u_flags(sv, i, SV_GMAGIC|SV_CONST_RETURN);
 447                 SETu(i);
 448                 return NORMAL;
 449             }
 450             SETs(&PL_sv_undef);
 451     }
 452     return NORMAL;
 453 }
 454
 455 PP(pp_rv2cv)
 456 {
 457     dSP;
 458     GV *gv;
 459     HV *stash_unused;
 460     const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
 461         ? GV_ADDMG
 462         : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT))
 463                                                     == OPpMAY_RETURN_CONSTANT)
 464             ? GV_ADD|GV_NOEXPAND
 465             : GV_ADD;
 466     /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
 467     /* (But not in defined().) */
 468
 469     CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
 470     if (cv) NOOP;
 471     else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
 472         cv = SvTYPE(SvRV(gv)) == SVt_PVCV
 473             ? MUTABLE_CV(SvRV(gv))
 474             : MUTABLE_CV(gv);
 475     }
 476     else
 477         cv = MUTABLE_CV(&PL_sv_undef);
 478     SETs(MUTABLE_SV(cv));
 479     return NORMAL;
 480 }
 481
 482 PP(pp_prototype)
 483 {
 484     dSP;
 485     CV *cv;
 486     HV *stash;
 487     GV *gv;
 488     SV *ret = &PL_sv_undef;
 489
 490     if (SvGMAGICAL(TOPs)) SETs(sv_mortalcopy(TOPs));
 491     if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
 492         const char * s = SvPVX_const(TOPs);
 493         if (strnEQ(s, "CORE::", 6)) {
 494             const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
 495             if (!code)
 496                 DIE(aTHX_ "Can't find an opnumber for \"%" UTF8f "\"",
 497                    UTF8fARG(SvFLAGS(TOPs) & SVf_UTF8, SvCUR(TOPs)-6, s+6));
 498             {
 499                 SV * const sv = core_prototype(NULL, s + 6, code, NULL);
 500                 if (sv) ret = sv;
 501             }
 502             goto set;
 503         }
 504     }
 505     cv = sv_2cv(TOPs, &stash, &gv, 0);
 506     if (cv && SvPOK(cv))
 507         ret = newSVpvn_flags(
 508             CvPROTO(cv), CvPROTOLEN(cv), SVs_TEMP | SvUTF8(cv)
 509         );
 510   set:
 511     SETs(ret);
 512     RETURN;
 513 }
 514
 515 PP(pp_anoncode)
 516 {
 517     dSP;
 518     CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
 519     if (CvCLONE(cv))
 520         cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
 521     EXTEND(SP,1);
 522     PUSHs(MUTABLE_SV(cv));
 523     RETURN;
 524 }
 525
 526 PP(pp_srefgen)
 527 {
 528     dSP;
 529     *SP = refto(*SP);
 530     return NORMAL;
 531 }
 532
 533 PP(pp_refgen)
 534 {
 535     dSP; dMARK;
 536     if (GIMME_V != G_ARRAY) {
 537         if (++MARK <= SP)
 538             *MARK = *SP;
 539         else
 540         {
 541             MEXTEND(SP, 1);
 542             *MARK = &PL_sv_undef;
 543         }
 544         *MARK = refto(*MARK);
 545         SP = MARK;
 546         RETURN;
 547     }
 548     EXTEND_MORTAL(SP - MARK);
 549     while (++MARK <= SP)
 550         *MARK = refto(*MARK);
 551     RETURN;
 552 }
 553
 554 STATIC SV*
 555 S_refto(pTHX_ SV *sv)
 556 {
 557     SV* rv;
 558
 559     PERL_ARGS_ASSERT_REFTO;
 560
 561     if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
 562         if (LvTARGLEN(sv))
 563             vivify_defelem(sv);
 564         if (!(sv = LvTARG(sv)))
 565             sv = &PL_sv_undef;
 566         else
 567             SvREFCNT_inc_void_NN(sv);
 568     }
 569     else if (SvTYPE(sv) == SVt_PVAV) {
 570         if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
 571             av_reify(MUTABLE_AV(sv));
 572         SvTEMP_off(sv);
 573         SvREFCNT_inc_void_NN(sv);
 574     }
 575     else if (SvPADTMP(sv)) {
 576         sv = newSVsv(sv);
 577     }
 578     else {
 579         SvTEMP_off(sv);
 580         SvREFCNT_inc_void_NN(sv);
 581     }
 582     rv = sv_newmortal();
 583     sv_upgrade(rv, SVt_IV);
 584     SvRV_set(rv, sv);
 585     SvROK_on(rv);
 586     return rv;
 587 }
 588
 589 PP(pp_ref)
 590 {
 591     dSP;
 592     SV * const sv = TOPs;
 593
 594     SvGETMAGIC(sv);
 595     if (!SvROK(sv)) {
 596         SETs(&PL_sv_no);
 597         return NORMAL;
 598     }
 599
 600     /* op is in boolean context? */
 601     if (   (PL_op->op_private & OPpTRUEBOOL)
 602         || (   (PL_op->op_private & OPpMAYBE_TRUEBOOL)
 603             && block_gimme() == G_VOID))
 604     {
 605         /* refs are always true - unless it's to an object blessed into a
 606          * class with a false name, i.e. "0". So we have to check for
 607          * that remote possibility. The following is is basically an
 608          * unrolled SvTRUE(sv_reftype(rv)) */
 609         SV * const rv = SvRV(sv);
 610         if (SvOBJECT(rv)) {
 611             HV *stash = SvSTASH(rv);
 612             HEK *hek = HvNAME_HEK(stash);
 613             if (hek) {
 614                 I32 len = HEK_LEN(hek);
 615                 /* bail out and do it the hard way? */
 616                 if (UNLIKELY(
 617                        len == HEf_SVKEY
 618                     || (len == 1 && HEK_KEY(hek)[0] == '0')
 619                 ))
 620                     goto do_sv_ref;
 621             }
 622         }
 623         SETs(&PL_sv_yes);
 624         return NORMAL;
 625     }
 626
 627   do_sv_ref:
 628     {
 629         dTARGET;
 630         SETs(TARG);
 631         sv_ref(TARG, SvRV(sv), TRUE);
 632         assert(!SvSMAGICAL(TARG));
 633         return NORMAL;
 634     }
 635
 636 }
 637
 638
 639 PP(pp_bless)
 640 {
 641     dSP;
 642     HV *stash;
 643
 644     if (MAXARG == 1)
 645     {
 646       curstash:
 647         stash = CopSTASH(PL_curcop);
 648         if (SvTYPE(stash) != SVt_PVHV)
 649             Perl_croak(aTHX_ "Attempt to bless into a freed package");
 650     }
 651     else {
 652         SV * const ssv = POPs;
 653         STRLEN len;
 654         const char *ptr;
 655
 656         if (!ssv) goto curstash;
 657         SvGETMAGIC(ssv);
 658         if (SvROK(ssv)) {
 659           if (!SvAMAGIC(ssv)) {
 660            frog:
 661             Perl_croak(aTHX_ "Attempt to bless into a reference");
 662           }
 663           /* SvAMAGIC is on here, but it only means potentially overloaded,
 664              so after stringification: */
 665           ptr = SvPV_nomg_const(ssv,len);
 666           /* We need to check the flag again: */
 667           if (!SvAMAGIC(ssv)) goto frog;
 668         }
 669         else ptr = SvPV_nomg_const(ssv,len);
 670         if (len == 0)
 671             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
 672                            "Explicit blessing to '' (assuming package main)");
 673         stash = gv_stashpvn(ptr, len, GV_ADD|SvUTF8(ssv));
 674     }
 675
 676     (void)sv_bless(TOPs, stash);
 677     RETURN;
 678 }
 679
 680 PP(pp_gelem)
 681 {
 682     dSP;
 683
 684     SV *sv = POPs;
 685     STRLEN len;
 686     const char * const elem = SvPV_const(sv, len);
 687     GV * const gv = MUTABLE_GV(TOPs);
 688     SV * tmpRef = NULL;
 689
 690     sv = NULL;
 691     if (elem) {
 692         /* elem will always be NUL terminated.  */
 693         switch (*elem) {
 694         case 'A':
 695             if (memEQs(elem, len, "ARRAY"))
 696             {
 697                 tmpRef = MUTABLE_SV(GvAV(gv));
 698                 if (tmpRef && !AvREAL((const AV *)tmpRef)
 699                  && AvREIFY((const AV *)tmpRef))
 700                     av_reify(MUTABLE_AV(tmpRef));
 701             }
 702             break;
 703         case 'C':
 704             if (memEQs(elem, len, "CODE"))
 705                 tmpRef = MUTABLE_SV(GvCVu(gv));
 706             break;
 707         case 'F':
 708             if (memEQs(elem, len, "FILEHANDLE")) {
 709                 tmpRef = MUTABLE_SV(GvIOp(gv));
 710             }
 711             else
 712                 if (memEQs(elem, len, "FORMAT"))
 713                     tmpRef = MUTABLE_SV(GvFORM(gv));
 714             break;
 715         case 'G':
 716             if (memEQs(elem, len, "GLOB"))
 717                 tmpRef = MUTABLE_SV(gv);
 718             break;
 719         case 'H':
 720             if (memEQs(elem, len, "HASH"))
 721                 tmpRef = MUTABLE_SV(GvHV(gv));
 722             break;
 723         case 'I':
 724             if (memEQs(elem, len, "IO"))
 725                 tmpRef = MUTABLE_SV(GvIOp(gv));
 726             break;
 727         case 'N':
 728             if (memEQs(elem, len, "NAME"))
 729                 sv = newSVhek(GvNAME_HEK(gv));
 730             break;
 731         case 'P':
 732             if (memEQs(elem, len, "PACKAGE")) {
 733                 const HV * const stash = GvSTASH(gv);
 734                 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
 735                 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
 736             }
 737             break;
 738         case 'S':
 739             if (memEQs(elem, len, "SCALAR"))
 740                 tmpRef = GvSVn(gv);
 741             break;
 742         }
 743     }
 744     if (tmpRef)
 745         sv = newRV(tmpRef);
 746     if (sv)
 747         sv_2mortal(sv);
 748     else
 749         sv = &PL_sv_undef;
 750     SETs(sv);
 751     RETURN;
 752 }
 753
 754 /* Pattern matching */
 755
 756 PP(pp_study)
 757 {
 758     dSP; dTOPss;
 759     STRLEN len;
 760
 761     (void)SvPV(sv, len);
 762     if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) {
 763         /* Historically, study was skipped in these cases. */
 764         SETs(&PL_sv_no);
 765         return NORMAL;
 766     }
 767
 768     /* Make study a no-op. It's no longer useful and its existence
 769        complicates matters elsewhere. */
 770     SETs(&PL_sv_yes);
 771     return NORMAL;
 772 }
 773
 774
 775 /* also used for: pp_transr() */
 776
 777 PP(pp_trans)
 778 {
 779     dSP;
 780     SV *sv;
 781
 782     if (PL_op->op_flags & OPf_STACKED)
 783         sv = POPs;
 784     else {
 785         EXTEND(SP,1);
 786         if (ARGTARG)
 787             sv = PAD_SV(ARGTARG);
 788         else {
 789             sv = DEFSV;
 790         }
 791     }
 792     if(PL_op->op_type == OP_TRANSR) {
 793         STRLEN len;
 794         const char * const pv = SvPV(sv,len);
 795         SV * const newsv = newSVpvn_flags(pv, len, SVs_TEMP|SvUTF8(sv));
 796         do_trans(newsv);
 797         PUSHs(newsv);
 798     }
 799     else {
 800         I32 i = do_trans(sv);
 801         mPUSHi(i);
 802     }
 803     RETURN;
 804 }
 805
 806 /* Lvalue operators. */
 807
 808 static size_t
 809 S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
 810 {
 811     STRLEN len;
 812     char *s;
 813     size_t count = 0;
 814
 815     PERL_ARGS_ASSERT_DO_CHOMP;
 816
 817     if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
 818         return 0;
 819     if (SvTYPE(sv) == SVt_PVAV) {
 820         I32 i;
 821         AV *const av = MUTABLE_AV(sv);
 822         const I32 max = AvFILL(av);
 823
 824         for (i = 0; i <= max; i++) {
 825             sv = MUTABLE_SV(av_fetch(av, i, FALSE));
 826             if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
 827                 count += do_chomp(retval, sv, chomping);
 828         }
 829         return count;
 830     }
 831     else if (SvTYPE(sv) == SVt_PVHV) {
 832         HV* const hv = MUTABLE_HV(sv);
 833         HE* entry;
 834         (void)hv_iterinit(hv);
 835         while ((entry = hv_iternext(hv)))
 836             count += do_chomp(retval, hv_iterval(hv,entry), chomping);
 837         return count;
 838     }
 839     else if (SvREADONLY(sv)) {
 840             Perl_croak_no_modify();
 841     }
 842
 843     s = SvPV(sv, len);
 844     if (chomping) {
 845         if (s && len) {
 846             char *temp_buffer = NULL;
 847             SV *svrecode = NULL;
 848             s += --len;
 849             if (RsPARA(PL_rs)) {
 850                 if (*s != '\n')
 851                     goto nope_free_nothing;
 852                 ++count;
 853                 while (len && s[-1] == '\n') {
 854                     --len;
 855                     --s;
 856                     ++count;
 857                 }
 858             }
 859             else {
 860                 STRLEN rslen, rs_charlen;
 861                 const char *rsptr = SvPV_const(PL_rs, rslen);
 862
 863                 rs_charlen = SvUTF8(PL_rs)
 864                     ? sv_len_utf8(PL_rs)
 865                     : rslen;
 866
 867                 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
 868                     /* Assumption is that rs is shorter than the scalar.  */
 869                     if (SvUTF8(PL_rs)) {
 870                         /* RS is utf8, scalar is 8 bit.  */
 871                         bool is_utf8 = TRUE;
 872                         temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
 873                                                              &rslen, &is_utf8);
 874                         if (is_utf8) {
 875                             /* Cannot downgrade, therefore cannot possibly match.
 876                                At this point, temp_buffer is not alloced, and
 877                                is the buffer inside PL_rs, so dont free it.
 878                              */
 879                             assert (temp_buffer == rsptr);
 880                             goto nope_free_sv;
 881                         }
 882                         rsptr = temp_buffer;
 883                     }
 884                     else {
 885                         /* RS is 8 bit, scalar is utf8.  */
 886                         temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
 887                         rsptr = temp_buffer;
 888                     }
 889                 }
 890                 if (rslen == 1) {
 891                     if (*s != *rsptr)
 892                         goto nope_free_all;
 893                     ++count;
 894                 }
 895                 else {
 896                     if (len < rslen - 1)
 897                         goto nope_free_all;
 898                     len -= rslen - 1;
 899                     s -= rslen - 1;
 900                     if (memNE(s, rsptr, rslen))
 901                         goto nope_free_all;
 902                     count += rs_charlen;
 903                 }
 904             }
 905             SvPV_force_nomg_nolen(sv);
 906             SvCUR_set(sv, len);
 907             *SvEND(sv) = '\0';
 908             SvNIOK_off(sv);
 909             SvSETMAGIC(sv);
 910
 911             nope_free_all:
 912             Safefree(temp_buffer);
 913             nope_free_sv:
 914             SvREFCNT_dec(svrecode);
 915             nope_free_nothing: ;
 916         }
 917     } else {
 918         if (len && (!SvPOK(sv) || SvIsCOW(sv)))
 919             s = SvPV_force_nomg(sv, len);
 920         if (DO_UTF8(sv)) {
 921             if (s && len) {
 922                 char * const send = s + len;
 923                 char * const start = s;
 924                 s = send - 1;
 925                 while (s > start && UTF8_IS_CONTINUATION(*s))
 926                     s--;
 927                 if (is_utf8_string((U8*)s, send - s)) {
 928                     sv_setpvn(retval, s, send - s);
 929                     *s = '\0';
 930                     SvCUR_set(sv, s - start);
 931                     SvNIOK_off(sv);
 932                     SvUTF8_on(retval);
 933                 }
 934             }
 935             else
 936                 SvPVCLEAR(retval);
 937         }
 938         else if (s && len) {
 939             s += --len;
 940             sv_setpvn(retval, s, 1);
 941             *s = '\0';
 942             SvCUR_set(sv, len);
 943             SvUTF8_off(sv);
 944             SvNIOK_off(sv);
 945         }
 946         else
 947             SvPVCLEAR(retval);
 948         SvSETMAGIC(sv);
 949     }
 950     return count;
 951 }
 952
 953
 954 /* also used for: pp_schomp() */
 955
 956 PP(pp_schop)
 957 {
 958     dSP; dTARGET;
 959     const bool chomping = PL_op->op_type == OP_SCHOMP;
 960
 961     const size_t count = do_chomp(TARG, TOPs, chomping);
 962     if (chomping)
 963         sv_setiv(TARG, count);
 964     SETTARG;
 965     return NORMAL;
 966 }
 967
 968
 969 /* also used for: pp_chomp() */
 970
 971 PP(pp_chop)
 972 {
 973     dSP; dMARK; dTARGET; dORIGMARK;
 974     const bool chomping = PL_op->op_type == OP_CHOMP;
 975     size_t count = 0;
 976
 977     while (MARK < SP)
 978         count += do_chomp(TARG, *++MARK, chomping);
 979     if (chomping)
 980         sv_setiv(TARG, count);
 981     SP = ORIGMARK;
 982     XPUSHTARG;
 983     RETURN;
 984 }
 985
 986 PP(pp_undef)
 987 {
 988     dSP;
 989     SV *sv;
 990
 991     if (!PL_op->op_private) {
 992         EXTEND(SP, 1);
 993         RETPUSHUNDEF;
 994     }
 995
 996     sv = TOPs;
 997     if (!sv)
 998     {
 999         SETs(&PL_sv_undef);
1000         return NORMAL;
1001     }
1002
1003     if (SvTHINKFIRST(sv))
1004         sv_force_normal_flags(sv, SV_COW_DROP_PV|SV_IMMEDIATE_UNREF);
1005
1006     switch (SvTYPE(sv)) {
1007     case SVt_NULL:
1008         break;
1009     case SVt_PVAV:
1010         av_undef(MUTABLE_AV(sv));
1011         break;
1012     case SVt_PVHV:
1013         hv_undef(MUTABLE_HV(sv));
1014         break;
1015     case SVt_PVCV:
1016         if (cv_const_sv((const CV *)sv))
1017             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1018                           "Constant subroutine %" SVf " undefined",
1019                            SVfARG(CvANON((const CV *)sv)
1020                              ? newSVpvs_flags("(anonymous)", SVs_TEMP)
1021                              : sv_2mortal(newSVhek(
1022                                 CvNAMED(sv)
1023                                  ? CvNAME_HEK((CV *)sv)
1024                                  : GvENAME_HEK(CvGV((const CV *)sv))
1025                                ))
1026                            ));
1027         /* FALLTHROUGH */
1028     case SVt_PVFM:
1029             /* let user-undef'd sub keep its identity */
1030         cv_undef_flags(MUTABLE_CV(sv), CV_UNDEF_KEEP_NAME);
1031         break;
1032     case SVt_PVGV:
1033         assert(isGV_with_GP(sv));
1034         assert(!SvFAKE(sv));
1035         {
1036             GP *gp;
1037             HV *stash;
1038
1039             /* undef *Pkg::meth_name ... */
1040             bool method_changed
1041              =   GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
1042               && HvENAME_get(stash);
1043             /* undef *Foo:: */
1044             if((stash = GvHV((const GV *)sv))) {
1045                 if(HvENAME_get(stash))
1046                     SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
1047                 else stash = NULL;
1048             }
1049
1050             SvREFCNT_inc_simple_void_NN(sv_2mortal(sv));
1051             gp_free(MUTABLE_GV(sv));
1052             Newxz(gp, 1, GP);
1053             GvGP_set(sv, gp_ref(gp));
1054 #ifndef PERL_DONT_CREATE_GVSV
1055             GvSV(sv) = newSV(0);
1056 #endif
1057             GvLINE(sv) = CopLINE(PL_curcop);
1058             GvEGV(sv) = MUTABLE_GV(sv);
1059             GvMULTI_on(sv);
1060
1061             if(stash)
1062                 mro_package_moved(NULL, stash, (const GV *)sv, 0);
1063             stash = NULL;
1064             /* undef *Foo::ISA */
1065             if( strEQ(GvNAME((const GV *)sv), "ISA")
1066              && (stash = GvSTASH((const GV *)sv))
1067              && (method_changed || HvENAME(stash)) )
1068                 mro_isa_changed_in(stash);
1069             else if(method_changed)
1070                 mro_method_changed_in(
1071                  GvSTASH((const GV *)sv)
1072                 );
1073
1074             break;
1075         }
1076     default:
1077         if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
1078             SvPV_free(sv);
1079             SvPV_set(sv, NULL);
1080             SvLEN_set(sv, 0);
1081         }
1082         SvOK_off(sv);
1083         SvSETMAGIC(sv);
1084     }
1085
1086     SETs(&PL_sv_undef);
1087     return NORMAL;
1088 }
1089
1090
1091 /* common "slow" code for pp_postinc and pp_postdec */
1092
1093 static OP *
1094 S_postincdec_common(pTHX_ SV *sv, SV *targ)
1095 {
1096     dSP;
1097     const bool inc =
1098         PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC;
1099
1100     if (SvROK(sv))
1101         TARG = sv_newmortal();
1102     sv_setsv(TARG, sv);
1103     if (inc)
1104         sv_inc_nomg(sv);
1105     else
1106         sv_dec_nomg(sv);
1107     SvSETMAGIC(sv);
1108     /* special case for undef: see thread at 2003-03/msg00536.html in archive */
1109     if (inc && !SvOK(TARG))
1110         sv_setiv(TARG, 0);
1111     SETTARG;
1112     return NORMAL;
1113 }
1114
1115
1116 /* also used for: pp_i_postinc() */
1117
1118 PP(pp_postinc)
1119 {
1120     dSP; dTARGET;
1121     SV *sv = TOPs;
1122
1123     /* special-case sv being a simple integer */
1124     if (LIKELY(((sv->sv_flags &
1125                         (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1126                          SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1127                 == SVf_IOK))
1128         && SvIVX(sv) != IV_MAX)
1129     {
1130         IV iv = SvIVX(sv);
1131         SvIV_set(sv,  iv + 1);
1132         TARGi(iv, 0); /* arg not GMG, so can't be tainted */
1133         SETs(TARG);
1134         return NORMAL;
1135     }
1136
1137     return S_postincdec_common(aTHX_ sv, TARG);
1138 }
1139
1140
1141 /* also used for: pp_i_postdec() */
1142
1143 PP(pp_postdec)
1144 {
1145     dSP; dTARGET;
1146     SV *sv = TOPs;
1147
1148     /* special-case sv being a simple integer */
1149     if (LIKELY(((sv->sv_flags &
1150                         (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1151                          SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1152                 == SVf_IOK))
1153         && SvIVX(sv) != IV_MIN)
1154     {
1155         IV iv = SvIVX(sv);
1156         SvIV_set(sv,  iv - 1);
1157         TARGi(iv, 0); /* arg not GMG, so can't be tainted */
1158         SETs(TARG);
1159         return NORMAL;
1160     }
1161
1162     return S_postincdec_common(aTHX_ sv, TARG);
1163 }
1164
1165
1166 /* Ordinary operators. */
1167
1168 PP(pp_pow)
1169 {
1170     dSP; dATARGET; SV *svl, *svr;
1171 #ifdef PERL_PRESERVE_IVUV
1172     bool is_int = 0;
1173 #endif
1174     tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
1175     svr = TOPs;
1176     svl = TOPm1s;
1177 #ifdef PERL_PRESERVE_IVUV
1178     /* For integer to integer power, we do the calculation by hand wherever
1179        we're sure it is safe; otherwise we call pow() and try to convert to
1180        integer afterwards. */
1181     if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1182                 UV power;
1183                 bool baseuok;
1184                 UV baseuv;
1185
1186                 if (SvUOK(svr)) {
1187                     power = SvUVX(svr);
1188                 } else {
1189                     const IV iv = SvIVX(svr);
1190                     if (iv >= 0) {
1191                         power = iv;
1192                     } else {
1193                         goto float_it; /* Can't do negative powers this way.  */
1194                     }
1195                 }
1196
1197                 baseuok = SvUOK(svl);
1198                 if (baseuok) {
1199                     baseuv = SvUVX(svl);
1200                 } else {
1201                     const IV iv = SvIVX(svl);
1202                     if (iv >= 0) {
1203                         baseuv = iv;
1204                         baseuok = TRUE; /* effectively it's a UV now */
1205                     } else {
1206                         baseuv = -iv; /* abs, baseuok == false records sign */
1207                     }
1208                 }
1209                 /* now we have integer ** positive integer. */
1210                 is_int = 1;
1211
1212                 /* foo & (foo - 1) is zero only for a power of 2.  */
1213                 if (!(baseuv & (baseuv - 1))) {
1214                     /* We are raising power-of-2 to a positive integer.
1215                        The logic here will work for any base (even non-integer
1216                        bases) but it can be less accurate than
1217                        pow (base,power) or exp (power * log (base)) when the
1218                        intermediate values start to spill out of the mantissa.
1219                        With powers of 2 we know this can't happen.
1220                        And powers of 2 are the favourite thing for perl
1221                        programmers to notice ** not doing what they mean. */
1222                     NV result = 1.0;
1223                     NV base = baseuok ? baseuv : -(NV)baseuv;
1224
1225                     if (power & 1) {
1226                         result *= base;
1227                     }
1228                     while (power >>= 1) {
1229                         base *= base;
1230                         if (power & 1) {
1231                             result *= base;
1232                         }
1233                     }
1234                     SP--;
1235                     SETn( result );
1236                     SvIV_please_nomg(svr);
1237                     RETURN;
1238                 } else {
1239                     unsigned int highbit = 8 * sizeof(UV);
1240                     unsigned int diff = 8 * sizeof(UV);
1241                     while (diff >>= 1) {
1242                         highbit -= diff;
1243                         if (baseuv >> highbit) {
1244                             highbit += diff;
1245                         }
1246                     }
1247                     /* we now have baseuv < 2 ** highbit */
1248                     if (power * highbit <= 8 * sizeof(UV)) {
1249                         /* result will definitely fit in UV, so use UV math
1250                            on same algorithm as above */
1251                         UV result = 1;
1252                         UV base = baseuv;
1253                         const bool odd_power = cBOOL(power & 1);
1254                         if (odd_power) {
1255                             result *= base;
1256                         }
1257                         while (power >>= 1) {
1258                             base *= base;
1259                             if (power & 1) {
1260                                 result *= base;
1261                             }
1262                         }
1263                         SP--;
1264                         if (baseuok || !odd_power)
1265                             /* answer is positive */
1266                             SETu( result );
1267                         else if (result <= (UV)IV_MAX)
1268                             /* answer negative, fits in IV */
1269                             SETi( -(IV)result );
1270                         else if (result == (UV)IV_MIN)
1271                             /* 2's complement assumption: special case IV_MIN */
1272                             SETi( IV_MIN );
1273                         else
1274                             /* answer negative, doesn't fit */
1275                             SETn( -(NV)result );
1276                         RETURN;
1277                     }
1278                 }
1279     }
1280   float_it:
1281 #endif
1282     {
1283         NV right = SvNV_nomg(svr);
1284         NV left  = SvNV_nomg(svl);
1285         (void)POPs;
1286
1287 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1288     /*
1289     We are building perl with long double support and are on an AIX OS
1290     afflicted with a powl() function that wrongly returns NaNQ for any
1291     negative base.  This was reported to IBM as PMR #23047-379 on
1292     03/06/2006.  The problem exists in at least the following versions
1293     of AIX and the libm fileset, and no doubt others as well:
1294
1295         AIX 4.3.3-ML10      bos.adt.libm 4.3.3.50
1296         AIX 5.1.0-ML04      bos.adt.libm 5.1.0.29
1297         AIX 5.2.0           bos.adt.libm 5.2.0.85
1298
1299     So, until IBM fixes powl(), we provide the following workaround to
1300     handle the problem ourselves.  Our logic is as follows: for
1301     negative bases (left), we use fmod(right, 2) to check if the
1302     exponent is an odd or even integer:
1303
1304         - if odd,  powl(left, right) == -powl(-left, right)
1305         - if even, powl(left, right) ==  powl(-left, right)
1306
1307     If the exponent is not an integer, the result is rightly NaNQ, so
1308     we just return that (as NV_NAN).
1309     */
1310
1311         if (left < 0.0) {
1312             NV mod2 = Perl_fmod( right, 2.0 );
1313             if (mod2 == 1.0 || mod2 == -1.0) {  /* odd integer */
1314                 SETn( -Perl_pow( -left, right) );
1315             } else if (mod2 == 0.0) {           /* even integer */
1316                 SETn( Perl_pow( -left, right) );
1317             } else {                            /* fractional power */
1318                 SETn( NV_NAN );
1319             }
1320         } else {
1321             SETn( Perl_pow( left, right) );
1322         }
1323 #else
1324         SETn( Perl_pow( left, right) );
1325 #endif  /* HAS_AIX_POWL_NEG_BASE_BUG */
1326
1327 #ifdef PERL_PRESERVE_IVUV
1328         if (is_int)
1329             SvIV_please_nomg(svr);
1330 #endif
1331         RETURN;
1332     }
1333 }
1334
1335 PP(pp_multiply)
1336 {
1337     dSP; dATARGET; SV *svl, *svr;
1338     tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1339     svr = TOPs;
1340     svl = TOPm1s;
1341
1342 #ifdef PERL_PRESERVE_IVUV
1343
1344     /* special-case some simple common cases */
1345     if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1346         IV il, ir;
1347         U32 flags = (svl->sv_flags & svr->sv_flags);
1348         if (flags & SVf_IOK) {
1349             /* both args are simple IVs */
1350             UV topl, topr;
1351             il = SvIVX(svl);
1352             ir = SvIVX(svr);
1353           do_iv:
1354             topl = ((UV)il) >> (UVSIZE * 4 - 1);
1355             topr = ((UV)ir) >> (UVSIZE * 4 - 1);
1356
1357             /* if both are in a range that can't under/overflow, do a
1358              * simple integer multiply: if the top halves(*) of both numbers
1359              * are 00...00  or 11...11, then it's safe.
1360              * (*) for 32-bits, the "top half" is the top 17 bits,
1361              *     for 64-bits, its 33 bits */
1362             if (!(
1363                       ((topl+1) | (topr+1))
1364                     & ( (((UV)1) << (UVSIZE * 4 + 1)) - 2) /* 11..110 */
1365             )) {
1366                 SP--;
1367                 TARGi(il * ir, 0); /* args not GMG, so can't be tainted */
1368                 SETs(TARG);
1369                 RETURN;
1370             }
1371             goto generic;
1372         }
1373         else if (flags & SVf_NOK) {
1374             /* both args are NVs */
1375             NV nl = SvNVX(svl);
1376             NV nr = SvNVX(svr);
1377             NV result;
1378
1379             if (
1380 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1381                 !Perl_isnan(nl) && nl == (NV)(il = (IV)nl)
1382                 && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr)
1383 #else
1384                 nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr)
1385 #endif
1386                 )
1387                 /* nothing was lost by converting to IVs */
1388                 goto do_iv;
1389             SP--;
1390             result = nl * nr;
1391 #  if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16
1392             if (Perl_isinf(result)) {
1393                 Zero((U8*)&result + 8, 8, U8);
1394             }
1395 #  endif
1396             TARGn(result, 0); /* args not GMG, so can't be tainted */
1397             SETs(TARG);
1398             RETURN;
1399         }
1400     }
1401
1402   generic:
1403
1404     if (SvIV_please_nomg(svr)) {
1405         /* Unless the left argument is integer in range we are going to have to
1406            use NV maths. Hence only attempt to coerce the right argument if
1407            we know the left is integer.  */
1408         /* Left operand is defined, so is it IV? */
1409         if (SvIV_please_nomg(svl)) {
1410             bool auvok = SvUOK(svl);
1411             bool buvok = SvUOK(svr);
1412             const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1413             const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1414             UV alow;
1415             UV ahigh;
1416             UV blow;
1417             UV bhigh;
1418
1419             if (auvok) {
1420                 alow = SvUVX(svl);
1421             } else {
1422                 const IV aiv = SvIVX(svl);
1423                 if (aiv >= 0) {
1424                     alow = aiv;
1425                     auvok = TRUE; /* effectively it's a UV now */
1426                 } else {
1427                     /* abs, auvok == false records sign */
1428                     alow = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
1429                 }
1430             }
1431             if (buvok) {
1432                 blow = SvUVX(svr);
1433             } else {
1434                 const IV biv = SvIVX(svr);
1435                 if (biv >= 0) {
1436                     blow = biv;
1437                     buvok = TRUE; /* effectively it's a UV now */
1438                 } else {
1439                     /* abs, buvok == false records sign */
1440                     blow = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
1441                 }
1442             }
1443
1444             /* If this does sign extension on unsigned it's time for plan B  */
1445             ahigh = alow >> (4 * sizeof (UV));
1446             alow &= botmask;
1447             bhigh = blow >> (4 * sizeof (UV));
1448             blow &= botmask;
1449             if (ahigh && bhigh) {
1450                 NOOP;
1451                 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1452                    which is overflow. Drop to NVs below.  */
1453             } else if (!ahigh && !bhigh) {
1454                 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1455                    so the unsigned multiply cannot overflow.  */
1456                 const UV product = alow * blow;
1457                 if (auvok == buvok) {
1458                     /* -ve * -ve or +ve * +ve gives a +ve result.  */
1459                     SP--;
1460                     SETu( product );
1461                     RETURN;
1462                 } else if (product <= (UV)IV_MIN) {
1463                     /* 2s complement assumption that (UV)-IV_MIN is correct.  */
1464                     /* -ve result, which could overflow an IV  */
1465                     SP--;
1466                     /* can't negate IV_MIN, but there are aren't two
1467                      * integers such that !ahigh && !bhigh, where the
1468                      * product equals 0x800....000 */
1469                     assert(product != (UV)IV_MIN);
1470                     SETi( -(IV)product );
1471                     RETURN;
1472                 } /* else drop to NVs below. */
1473             } else {
1474                 /* One operand is large, 1 small */
1475                 UV product_middle;
1476                 if (bhigh) {
1477                     /* swap the operands */
1478                     ahigh = bhigh;
1479                     bhigh = blow; /* bhigh now the temp var for the swap */
1480                     blow = alow;
1481                     alow = bhigh;
1482                 }
1483                 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1484                    multiplies can't overflow. shift can, add can, -ve can.  */
1485                 product_middle = ahigh * blow;
1486                 if (!(product_middle & topmask)) {
1487                     /* OK, (ahigh * blow) won't lose bits when we shift it.  */
1488                     UV product_low;
1489                     product_middle <<= (4 * sizeof (UV));
1490                     product_low = alow * blow;
1491
1492                     /* as for pp_add, UV + something mustn't get smaller.
1493                        IIRC ANSI mandates this wrapping *behaviour* for
1494                        unsigned whatever the actual representation*/
1495                     product_low += product_middle;
1496                     if (product_low >= product_middle) {
1497                         /* didn't overflow */
1498                         if (auvok == buvok) {
1499                             /* -ve * -ve or +ve * +ve gives a +ve result.  */
1500                             SP--;
1501                             SETu( product_low );
1502                             RETURN;
1503                         } else if (product_low <= (UV)IV_MIN) {
1504                             /* 2s complement assumption again  */
1505                             /* -ve result, which could overflow an IV  */
1506                             SP--;
1507                             SETi(product_low == (UV)IV_MIN
1508                                     ? IV_MIN : -(IV)product_low);
1509                             RETURN;
1510                         } /* else drop to NVs below. */
1511                     }
1512                 } /* product_middle too large */
1513             } /* ahigh && bhigh */
1514         } /* SvIOK(svl) */
1515     } /* SvIOK(svr) */
1516 #endif
1517     {
1518       NV right = SvNV_nomg(svr);
1519       NV left  = SvNV_nomg(svl);
1520       NV result = left * right;
1521
1522       (void)POPs;
1523 #if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16
1524       if (Perl_isinf(result)) {
1525           Zero((U8*)&result + 8, 8, U8);
1526       }
1527 #endif
1528       SETn(result);
1529       RETURN;
1530     }
1531 }
1532
1533 PP(pp_divide)
1534 {
1535     dSP; dATARGET; SV *svl, *svr;
1536     tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1537     svr = TOPs;
1538     svl = TOPm1s;
1539     /* Only try to do UV divide first
1540        if ((SLOPPYDIVIDE is true) or
1541            (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1542             to preserve))
1543        The assumption is that it is better to use floating point divide
1544        whenever possible, only doing integer divide first if we can't be sure.
1545        If NV_PRESERVES_UV is true then we know at compile time that no UV
1546        can be too large to preserve, so don't need to compile the code to
1547        test the size of UVs.  */
1548
1549 #ifdef SLOPPYDIVIDE
1550 #  define PERL_TRY_UV_DIVIDE
1551     /* ensure that 20./5. == 4. */
1552 #else
1553 #  ifdef PERL_PRESERVE_IVUV
1554 #    ifndef NV_PRESERVES_UV
1555 #      define PERL_TRY_UV_DIVIDE
1556 #    endif
1557 #  endif
1558 #endif
1559
1560 #ifdef PERL_TRY_UV_DIVIDE
1561     if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1562             bool left_non_neg = SvUOK(svl);
1563             bool right_non_neg = SvUOK(svr);
1564             UV left;
1565             UV right;
1566
1567             if (right_non_neg) {
1568                 right = SvUVX(svr);
1569             }
1570             else {
1571                 const IV biv = SvIVX(svr);
1572                 if (biv >= 0) {
1573                     right = biv;
1574                     right_non_neg = TRUE; /* effectively it's a UV now */
1575                 }
1576                 else {
1577                     right = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
1578                 }
1579             }
1580             /* historically undef()/0 gives a "Use of uninitialized value"
1581                warning before dieing, hence this test goes here.
1582                If it were immediately before the second SvIV_please, then
1583                DIE() would be invoked before left was even inspected, so
1584                no inspection would give no warning.  */
1585             if (right == 0)
1586                 DIE(aTHX_ "Illegal division by zero");
1587
1588             if (left_non_neg) {
1589                 left = SvUVX(svl);
1590             }
1591             else {
1592                 const IV aiv = SvIVX(svl);
1593                 if (aiv >= 0) {
1594                     left = aiv;
1595                     left_non_neg = TRUE; /* effectively it's a UV now */
1596                 }
1597                 else {
1598                     left = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
1599                 }
1600             }
1601
1602             if (left >= right
1603 #ifdef SLOPPYDIVIDE
1604                 /* For sloppy divide we always attempt integer division.  */
1605 #else
1606                 /* Otherwise we only attempt it if either or both operands
1607                    would not be preserved by an NV.  If both fit in NVs
1608                    we fall through to the NV divide code below.  However,
1609                    as left >= right to ensure integer result here, we know that
1610                    we can skip the test on the right operand - right big
1611                    enough not to be preserved can't get here unless left is
1612                    also too big.  */
1613
1614                 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1615 #endif
1616                 ) {
1617                 /* Integer division can't overflow, but it can be imprecise.  */
1618                 const UV result = left / right;
1619                 if (result * right == left) {
1620                     SP--; /* result is valid */
1621                     if (left_non_neg == right_non_neg) {
1622                         /* signs identical, result is positive.  */
1623                         SETu( result );
1624                         RETURN;
1625                     }
1626                     /* 2s complement assumption */
1627                     if (result <= (UV)IV_MIN)
1628                         SETi(result == (UV)IV_MIN ? IV_MIN : -(IV)result);
1629                     else {
1630                         /* It's exact but too negative for IV. */
1631                         SETn( -(NV)result );
1632                     }
1633                     RETURN;
1634                 } /* tried integer divide but it was not an integer result */
1635             } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1636     } /* one operand wasn't SvIOK */
1637 #endif /* PERL_TRY_UV_DIVIDE */
1638     {
1639         NV right = SvNV_nomg(svr);
1640         NV left  = SvNV_nomg(svl);
1641         (void)POPs;(void)POPs;
1642 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1643         if (! Perl_isnan(right) && right == 0.0)
1644 #else
1645         if (right == 0.0)
1646 #endif
1647             DIE(aTHX_ "Illegal division by zero");
1648         PUSHn( left / right );
1649         RETURN;
1650     }
1651 }
1652
1653 PP(pp_modulo)
1654 {
1655     dSP; dATARGET;
1656     tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
1657     {
1658         UV left  = 0;
1659         UV right = 0;
1660         bool left_neg = FALSE;
1661         bool right_neg = FALSE;
1662         bool use_double = FALSE;
1663         bool dright_valid = FALSE;
1664         NV dright = 0.0;
1665         NV dleft  = 0.0;
1666         SV * const svr = TOPs;
1667         SV * const svl = TOPm1s;
1668         if (SvIV_please_nomg(svr)) {
1669             right_neg = !SvUOK(svr);
1670             if (!right_neg) {
1671                 right = SvUVX(svr);
1672             } else {
1673                 const IV biv = SvIVX(svr);
1674                 if (biv >= 0) {
1675                     right = biv;
1676                     right_neg = FALSE; /* effectively it's a UV now */
1677                 } else {
1678                     right = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
1679                 }
1680             }
1681         }
1682         else {
1683             dright = SvNV_nomg(svr);
1684             right_neg = dright < 0;
1685             if (right_neg)
1686                 dright = -dright;
1687             if (dright < UV_MAX_P1) {
1688                 right = U_V(dright);
1689                 dright_valid = TRUE; /* In case we need to use double below.  */
1690             } else {
1691                 use_double = TRUE;
1692             }
1693         }
1694
1695         /* At this point use_double is only true if right is out of range for
1696            a UV.  In range NV has been rounded down to nearest UV and
1697            use_double false.  */
1698         if (!use_double && SvIV_please_nomg(svl)) {
1699                 left_neg = !SvUOK(svl);
1700                 if (!left_neg) {
1701                     left = SvUVX(svl);
1702                 } else {
1703                     const IV aiv = SvIVX(svl);
1704                     if (aiv >= 0) {
1705                         left = aiv;
1706                         left_neg = FALSE; /* effectively it's a UV now */
1707                     } else {
1708                         left = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
1709                     }
1710                 }
1711         }
1712         else {
1713             dleft = SvNV_nomg(svl);
1714             left_neg = dleft < 0;
1715             if (left_neg)
1716                 dleft = -dleft;
1717
1718             /* This should be exactly the 5.6 behaviour - if left and right are
1719                both in range for UV then use U_V() rather than floor.  */
1720             if (!use_double) {
1721                 if (dleft < UV_MAX_P1) {
1722                     /* right was in range, so is dleft, so use UVs not double.
1723                      */
1724                     left = U_V(dleft);
1725                 }
1726                 /* left is out of range for UV, right was in range, so promote
1727                    right (back) to double.  */
1728                 else {
1729                     /* The +0.5 is used in 5.6 even though it is not strictly
1730                        consistent with the implicit +0 floor in the U_V()
1731                        inside the #if 1. */
1732                     dleft = Perl_floor(dleft + 0.5);
1733                     use_double = TRUE;
1734                     if (dright_valid)
1735                         dright = Perl_floor(dright + 0.5);
1736                     else
1737                         dright = right;
1738                 }
1739             }
1740         }
1741         sp -= 2;
1742         if (use_double) {
1743             NV dans;
1744
1745             if (!dright)
1746                 DIE(aTHX_ "Illegal modulus zero");
1747
1748             dans = Perl_fmod(dleft, dright);
1749             if ((left_neg != right_neg) && dans)
1750                 dans = dright - dans;
1751             if (right_neg)
1752                 dans = -dans;
1753             sv_setnv(TARG, dans);
1754         }
1755         else {
1756             UV ans;
1757
1758             if (!right)
1759                 DIE(aTHX_ "Illegal modulus zero");
1760
1761             ans = left % right;
1762             if ((left_neg != right_neg) && ans)
1763                 ans = right - ans;
1764             if (right_neg) {
1765                 /* XXX may warn: unary minus operator applied to unsigned type */
1766                 /* could change -foo to be (~foo)+1 instead     */
1767                 if (ans <= ~((UV)IV_MAX)+1)
1768                     sv_setiv(TARG, ~ans+1);
1769                 else
1770                     sv_setnv(TARG, -(NV)ans);
1771             }
1772             else
1773                 sv_setuv(TARG, ans);
1774         }
1775         PUSHTARG;
1776         RETURN;
1777     }
1778 }
1779
1780 PP(pp_repeat)
1781 {
1782     dSP; dATARGET;
1783     IV count;
1784     SV *sv;
1785     bool infnan = FALSE;
1786
1787     if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1788         /* TODO: think of some way of doing list-repeat overloading ??? */
1789         sv = POPs;
1790         SvGETMAGIC(sv);
1791     }
1792     else {
1793         if (UNLIKELY(PL_op->op_private & OPpREPEAT_DOLIST)) {
1794             /* The parser saw this as a list repeat, and there
1795                are probably several items on the stack. But we're
1796                in scalar/void context, and there's no pp_list to save us
1797                now. So drop the rest of the items -- robin@kitsite.com
1798              */
1799             dMARK;
1800             if (MARK + 1 < SP) {
1801                 MARK[1] = TOPm1s;
1802                 MARK[2] = TOPs;
1803             }
1804             else {
1805                 dTOPss;
1806                 ASSUME(MARK + 1 == SP);
1807                 XPUSHs(sv);
1808                 MARK[1] = &PL_sv_undef;
1809             }
1810             SP = MARK + 2;
1811         }
1812         tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1813         sv = POPs;
1814     }
1815
1816     if (SvIOKp(sv)) {
1817          if (SvUOK(sv)) {
1818               const UV uv = SvUV_nomg(sv);
1819               if (uv > IV_MAX)
1820                    count = IV_MAX; /* The best we can do? */
1821               else
1822                    count = uv;
1823          } else {
1824               count = SvIV_nomg(sv);
1825          }
1826     }
1827     else if (SvNOKp(sv)) {
1828         const NV nv = SvNV_nomg(sv);
1829         infnan = Perl_isinfnan(nv);
1830         if (UNLIKELY(infnan)) {
1831             count = 0;
1832         } else {
1833             if (nv < 0.0)
1834                 count = -1;   /* An arbitrary negative integer */
1835             else
1836                 count = (IV)nv;
1837         }
1838     }
1839     else
1840         count = SvIV_nomg(sv);
1841
1842     if (infnan) {
1843         Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1844                        "Non-finite repeat count does nothing");
1845     } else if (count < 0) {
1846         count = 0;
1847         Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1848                        "Negative repeat count does nothing");
1849     }
1850
1851     if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1852         dMARK;
1853         const SSize_t items = SP - MARK;
1854         const U8 mod = PL_op->op_flags & OPf_MOD;
1855
1856         if (count > 1) {
1857             SSize_t max;
1858
1859             if (  items > SSize_t_MAX / count   /* max would overflow */
1860                                                 /* repeatcpy would overflow */
1861                || items > I32_MAX / (I32)sizeof(SV *)
1862             )
1863                Perl_croak(aTHX_ "%s","Out of memory during list extend");
1864             max = items * count;
1865             MEXTEND(MARK, max);
1866
1867             while (SP > MARK) {
1868                 if (*SP) {
1869                    if (mod && SvPADTMP(*SP)) {
1870                        *SP = sv_mortalcopy(*SP);
1871                    }
1872                    SvTEMP_off((*SP));
1873                 }
1874                 SP--;
1875             }
1876             MARK++;
1877             repeatcpy((char*)(MARK + items), (char*)MARK,
1878                 items * sizeof(const SV *), count - 1);
1879             SP += max;
1880         }
1881         else if (count <= 0)
1882             SP = MARK;
1883     }
1884     else {      /* Note: mark already snarfed by pp_list */
1885         SV * const tmpstr = POPs;
1886         STRLEN len;
1887         bool isutf;
1888
1889         if (TARG != tmpstr)
1890             sv_setsv_nomg(TARG, tmpstr);
1891         SvPV_force_nomg(TARG, len);
1892         isutf = DO_UTF8(TARG);
1893         if (count != 1) {
1894             if (count < 1)
1895                 SvCUR_set(TARG, 0);
1896             else {
1897                 STRLEN max;
1898
1899                 if (   len > (MEM_SIZE_MAX-1) / (UV)count /* max would overflow */
1900                     || len > (U32)I32_MAX  /* repeatcpy would overflow */
1901                 )
1902                      Perl_croak(aTHX_ "%s",
1903                                         "Out of memory during string extend");
1904                 max = (UV)count * len + 1;
1905                 SvGROW(TARG, max);
1906
1907                 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1908                 SvCUR_set(TARG, SvCUR(TARG) * count);
1909             }
1910             *SvEND(TARG) = '\0';
1911         }
1912         if (isutf)
1913             (void)SvPOK_only_UTF8(TARG);
1914         else
1915             (void)SvPOK_only(TARG);
1916
1917         PUSHTARG;
1918     }
1919     RETURN;
1920 }
1921
1922 PP(pp_subtract)
1923 {
1924     dSP; dATARGET; bool useleft; SV *svl, *svr;
1925     tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1926     svr = TOPs;
1927     svl = TOPm1s;
1928
1929 #ifdef PERL_PRESERVE_IVUV
1930
1931     /* special-case some simple common cases */
1932     if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1933         IV il, ir;
1934         U32 flags = (svl->sv_flags & svr->sv_flags);
1935         if (flags & SVf_IOK) {
1936             /* both args are simple IVs */
1937             UV topl, topr;
1938             il = SvIVX(svl);
1939             ir = SvIVX(svr);
1940           do_iv:
1941             topl = ((UV)il) >> (UVSIZE * 8 - 2);
1942             topr = ((UV)ir) >> (UVSIZE * 8 - 2);
1943
1944             /* if both are in a range that can't under/overflow, do a
1945              * simple integer subtract: if the top of both numbers
1946              * are 00  or 11, then it's safe */
1947             if (!( ((topl+1) | (topr+1)) & 2)) {
1948                 SP--;
1949                 TARGi(il - ir, 0); /* args not GMG, so can't be tainted */
1950                 SETs(TARG);
1951                 RETURN;
1952             }
1953             goto generic;
1954         }
1955         else if (flags & SVf_NOK) {
1956             /* both args are NVs */
1957             NV nl = SvNVX(svl);
1958             NV nr = SvNVX(svr);
1959
1960             if (
1961 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1962                 !Perl_isnan(nl) && nl == (NV)(il = (IV)nl)
1963                 && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr)
1964 #else
1965                 nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr)
1966 #endif
1967                 )
1968                 /* nothing was lost by converting to IVs */
1969                 goto do_iv;
1970             SP--;
1971             TARGn(nl - nr, 0); /* args not GMG, so can't be tainted */
1972             SETs(TARG);
1973             RETURN;
1974         }
1975     }
1976
1977   generic:
1978
1979     useleft = USE_LEFT(svl);
1980     /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1981        "bad things" happen if you rely on signed integers wrapping.  */
1982     if (SvIV_please_nomg(svr)) {
1983         /* Unless the left argument is integer in range we are going to have to
1984            use NV maths. Hence only attempt to coerce the right argument if
1985            we know the left is integer.  */
1986         UV auv = 0;
1987         bool auvok = FALSE;
1988         bool a_valid = 0;
1989
1990         if (!useleft) {
1991             auv = 0;
1992             a_valid = auvok = 1;
1993             /* left operand is undef, treat as zero.  */
1994         } else {
1995             /* Left operand is defined, so is it IV? */
1996             if (SvIV_please_nomg(svl)) {
1997                 if ((auvok = SvUOK(svl)))
1998                     auv = SvUVX(svl);
1999                 else {
2000                     const IV aiv = SvIVX(svl);
2001                     if (aiv >= 0) {
2002                         auv = aiv;
2003                         auvok = 1;      /* Now acting as a sign flag.  */
2004                     } else { /* 2s complement assumption for IV_MIN */
2005                         auv = (aiv == IV_MIN) ? (UV)aiv : (UV)-aiv;
2006                     }
2007                 }
2008                 a_valid = 1;
2009             }
2010         }
2011         if (a_valid) {
2012             bool result_good = 0;
2013             UV result;
2014             UV buv;
2015             bool buvok = SvUOK(svr);
2016
2017             if (buvok)
2018                 buv = SvUVX(svr);
2019             else {
2020                 const IV biv = SvIVX(svr);
2021                 if (biv >= 0) {
2022                     buv = biv;
2023                     buvok = 1;
2024                 } else
2025                     buv = (biv == IV_MIN) ? (UV)biv : (UV)-biv;
2026             }
2027             /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
2028                else "IV" now, independent of how it came in.
2029                if a, b represents positive, A, B negative, a maps to -A etc
2030                a - b =>  (a - b)
2031                A - b => -(a + b)
2032                a - B =>  (a + b)
2033                A - B => -(a - b)
2034                all UV maths. negate result if A negative.
2035                subtract if signs same, add if signs differ. */
2036
2037             if (auvok ^ buvok) {
2038                 /* Signs differ.  */
2039                 result = auv + buv;
2040                 if (result >= auv)
2041                     result_good = 1;
2042             } else {
2043                 /* Signs same */
2044                 if (auv >= buv) {
2045                     result = auv - buv;
2046                     /* Must get smaller */
2047                     if (result <= auv)
2048                         result_good = 1;
2049                 } else {
2050                     result = buv - auv;
2051                     if (result <= buv) {
2052                         /* result really should be -(auv-buv). as its negation
2053                            of true value, need to swap our result flag  */
2054                         auvok = !auvok;
2055                         result_good = 1;
2056                     }
2057                 }
2058             }
2059             if (result_good) {
2060                 SP--;
2061                 if (auvok)
2062                     SETu( result );
2063                 else {
2064                     /* Negate result */
2065                     if (result <= (UV)IV_MIN)
2066                         SETi(result == (UV)IV_MIN
2067                                 ? IV_MIN : -(IV)result);
2068                     else {
2069                         /* result valid, but out of range for IV.  */
2070                         SETn( -(NV)result );
2071                     }
2072                 }
2073                 RETURN;
2074             } /* Overflow, drop through to NVs.  */
2075         }
2076     }
2077 #else
2078     useleft = USE_LEFT(svl);
2079 #endif
2080     {
2081         NV value = SvNV_nomg(svr);
2082         (void)POPs;
2083
2084         if (!useleft) {
2085             /* left operand is undef, treat as zero - value */
2086             SETn(-value);
2087             RETURN;
2088         }
2089         SETn( SvNV_nomg(svl) - value );
2090         RETURN;
2091     }
2092 }
2093
2094 #define IV_BITS (IVSIZE * 8)
2095
2096 static UV S_uv_shift(UV uv, int shift, bool left)
2097 {
2098    if (shift < 0) {
2099        shift = -shift;
2100        left = !left;
2101    }
2102    if (shift >= IV_BITS) {
2103        return 0;
2104    }
2105    return left ? uv << shift : uv >> shift;
2106 }
2107
2108 static IV S_iv_shift(IV iv, int shift, bool left)
2109 {
2110    if (shift < 0) {
2111        shift = -shift;
2112        left = !left;
2113    }
2114    if (shift >= IV_BITS) {
2115        return iv < 0 && !left ? -1 : 0;
2116    }
2117    return left ? iv << shift : iv >> shift;
2118 }
2119
2120 #define UV_LEFT_SHIFT(uv, shift) S_uv_shift(uv, shift, TRUE)
2121 #define UV_RIGHT_SHIFT(uv, shift) S_uv_shift(uv, shift, FALSE)
2122 #define IV_LEFT_SHIFT(iv, shift) S_iv_shift(iv, shift, TRUE)
2123 #define IV_RIGHT_SHIFT(iv, shift) S_iv_shift(iv, shift, FALSE)
2124
2125 PP(pp_left_shift)
2126 {
2127     dSP; dATARGET; SV *svl, *svr;
2128     tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
2129     svr = POPs;
2130     svl = TOPs;
2131     {
2132       const IV shift = SvIV_nomg(svr);
2133       if (PL_op->op_private & HINT_INTEGER) {
2134           SETi(IV_LEFT_SHIFT(SvIV_nomg(svl), shift));
2135       }
2136       else {
2137           SETu(UV_LEFT_SHIFT(SvUV_nomg(svl), shift));
2138       }
2139       RETURN;
2140     }
2141 }
2142
2143 PP(pp_right_shift)
2144 {
2145     dSP; dATARGET; SV *svl, *svr;
2146     tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
2147     svr = POPs;
2148     svl = TOPs;
2149     {
2150       const IV shift = SvIV_nomg(svr);
2151       if (PL_op->op_private & HINT_INTEGER) {
2152           SETi(IV_RIGHT_SHIFT(SvIV_nomg(svl), shift));
2153       }
2154       else {
2155           SETu(UV_RIGHT_SHIFT(SvUV_nomg(svl), shift));
2156       }
2157       RETURN;
2158     }
2159 }
2160
2161 PP(pp_lt)
2162 {
2163     dSP;
2164     SV *left, *right;
2165
2166     tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
2167     right = POPs;
2168     left  = TOPs;
2169     SETs(boolSV(
2170         (SvIOK_notUV(left) && SvIOK_notUV(right))
2171         ? (SvIVX(left) < SvIVX(right))
2172         : (do_ncmp(left, right) == -1)
2173     ));
2174     RETURN;
2175 }
2176
2177 PP(pp_gt)
2178 {
2179     dSP;
2180     SV *left, *right;
2181
2182     tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
2183     right = POPs;
2184     left  = TOPs;
2185     SETs(boolSV(
2186         (SvIOK_notUV(left) && SvIOK_notUV(right))
2187         ? (SvIVX(left) > SvIVX(right))
2188         : (do_ncmp(left, right) == 1)
2189     ));
2190     RETURN;
2191 }
2192
2193 PP(pp_le)
2194 {
2195     dSP;
2196     SV *left, *right;
2197
2198     tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
2199     right = POPs;
2200     left  = TOPs;
2201     SETs(boolSV(
2202         (SvIOK_notUV(left) && SvIOK_notUV(right))
2203         ? (SvIVX(left) <= SvIVX(right))
2204         : (do_ncmp(left, right) <= 0)
2205     ));
2206     RETURN;
2207 }
2208
2209 PP(pp_ge)
2210 {
2211     dSP;
2212     SV *left, *right;
2213
2214     tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
2215     right = POPs;
2216     left  = TOPs;
2217     SETs(boolSV(
2218         (SvIOK_notUV(left) && SvIOK_notUV(right))
2219         ? (SvIVX(left) >= SvIVX(right))
2220         : ( (do_ncmp(left, right) & 2) == 0)
2221     ));
2222     RETURN;
2223 }
2224
2225 PP(pp_ne)
2226 {
2227     dSP;
2228     SV *left, *right;
2229
2230     tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
2231     right = POPs;
2232     left  = TOPs;
2233     SETs(boolSV(
2234         (SvIOK_notUV(left) && SvIOK_notUV(right))
2235         ? (SvIVX(left) != SvIVX(right))
2236         : (do_ncmp(left, right) != 0)
2237     ));
2238     RETURN;
2239 }
2240
2241 /* compare left and right SVs. Returns:
2242  * -1: <
2243  *  0: ==
2244  *  1: >
2245  *  2: left or right was a NaN
2246  */
2247 I32
2248 Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
2249 {
2250     PERL_ARGS_ASSERT_DO_NCMP;
2251 #ifdef PERL_PRESERVE_IVUV
2252     /* Fortunately it seems NaN isn't IOK */
2253     if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
2254             if (!SvUOK(left)) {
2255                 const IV leftiv = SvIVX(left);
2256                 if (!SvUOK(right)) {
2257                     /* ## IV <=> IV ## */
2258                     const IV rightiv = SvIVX(right);
2259                     return (leftiv > rightiv) - (leftiv < rightiv);
2260                 }
2261                 /* ## IV <=> UV ## */
2262                 if (leftiv < 0)
2263                     /* As (b) is a UV, it's >=0, so it must be < */
2264                     return -1;
2265                 {
2266                     const UV rightuv = SvUVX(right);
2267                     return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
2268                 }
2269             }
2270
2271             if (SvUOK(right)) {
2272                 /* ## UV <=> UV ## */
2273                 const UV leftuv = SvUVX(left);
2274                 const UV rightuv = SvUVX(right);
2275                 return (leftuv > rightuv) - (leftuv < rightuv);
2276             }
2277             /* ## UV <=> IV ## */
2278             {
2279                 const IV rightiv = SvIVX(right);
2280                 if (rightiv < 0)
2281                     /* As (a) is a UV, it's >=0, so it cannot be < */
2282                     return 1;
2283                 {
2284                     const UV leftuv = SvUVX(left);
2285                     return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
2286                 }
2287             }
2288             NOT_REACHED; /* NOTREACHED */
2289     }
2290 #endif
2291     {
2292       NV const rnv = SvNV_nomg(right);
2293       NV const lnv = SvNV_nomg(left);
2294
2295 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2296       if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2297           return 2;
2298        }
2299       return (lnv > rnv) - (lnv < rnv);
2300 #else
2301       if (lnv < rnv)
2302         return -1;
2303       if (lnv > rnv)
2304         return 1;
2305       if (lnv == rnv)
2306         return 0;
2307       return 2;
2308 #endif
2309     }
2310 }
2311
2312
2313 PP(pp_ncmp)
2314 {
2315     dSP;
2316     SV *left, *right;
2317     I32 value;
2318     tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
2319     right = POPs;
2320     left  = TOPs;
2321     value = do_ncmp(left, right);
2322     if (value == 2) {
2323         SETs(&PL_sv_undef);
2324     }
2325     else {
2326         dTARGET;
2327         SETi(value);
2328     }
2329     RETURN;
2330 }
2331
2332
2333 /* also used for: pp_sge() pp_sgt() pp_slt() */
2334
2335 PP(pp_sle)
2336 {
2337     dSP;
2338
2339     int amg_type = sle_amg;
2340     int multiplier = 1;
2341     int rhs = 1;
2342
2343     switch (PL_op->op_type) {
2344     case OP_SLT:
2345         amg_type = slt_amg;
2346         /* cmp < 0 */
2347         rhs = 0;
2348         break;
2349     case OP_SGT:
2350         amg_type = sgt_amg;
2351         /* cmp > 0 */
2352         multiplier = -1;
2353         rhs = 0;
2354         break;
2355     case OP_SGE:
2356         amg_type = sge_amg;
2357         /* cmp >= 0 */
2358         multiplier = -1;
2359         break;
2360     }
2361
2362     tryAMAGICbin_MG(amg_type, AMGf_set);
2363     {
2364       dPOPTOPssrl;
2365       const int cmp =
2366 #ifdef USE_LOCALE_COLLATE
2367                       (IN_LC_RUNTIME(LC_COLLATE))
2368                       ? sv_cmp_locale_flags(left, right, 0)
2369                       :
2370 #endif
2371                         sv_cmp_flags(left, right, 0);
2372       SETs(boolSV(cmp * multiplier < rhs));
2373       RETURN;
2374     }
2375 }
2376
2377 PP(pp_seq)
2378 {
2379     dSP;
2380     tryAMAGICbin_MG(seq_amg, AMGf_set);
2381     {
2382       dPOPTOPssrl;
2383       SETs(boolSV(sv_eq_flags(left, right, 0)));
2384       RETURN;
2385     }
2386 }
2387
2388 PP(pp_sne)
2389 {
2390     dSP;
2391     tryAMAGICbin_MG(sne_amg, AMGf_set);
2392     {
2393       dPOPTOPssrl;
2394       SETs(boolSV(!sv_eq_flags(left, right, 0)));
2395       RETURN;
2396     }
2397 }
2398
2399 PP(pp_scmp)
2400 {
2401     dSP; dTARGET;
2402     tryAMAGICbin_MG(scmp_amg, 0);
2403     {
2404       dPOPTOPssrl;
2405       const int cmp =
2406 #ifdef USE_LOCALE_COLLATE
2407                       (IN_LC_RUNTIME(LC_COLLATE))
2408                       ? sv_cmp_locale_flags(left, right, 0)
2409                       :
2410 #endif
2411                         sv_cmp_flags(left, right, 0);
2412       SETi( cmp );
2413       RETURN;
2414     }
2415 }
2416
2417 PP(pp_bit_and)
2418 {
2419     dSP; dATARGET;
2420     tryAMAGICbin_MG(band_amg, AMGf_assign);
2421     {
2422       dPOPTOPssrl;
2423       if (SvNIOKp(left) || SvNIOKp(right)) {
2424         const bool left_ro_nonnum  = !SvNIOKp(left) && SvREADONLY(left);
2425         const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2426         if (PL_op->op_private & HINT_INTEGER) {
2427           const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2428           SETi(i);
2429         }
2430         else {
2431           const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2432           SETu(u);
2433         }
2434         if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2435         if (right_ro_nonnum) SvNIOK_off(right);
2436       }
2437       else {
2438         do_vop(PL_op->op_type, TARG, left, right);
2439         SETTARG;
2440       }
2441       RETURN;
2442     }
2443 }
2444
2445 PP(pp_nbit_and)
2446 {
2447     dSP;
2448     tryAMAGICbin_MG(band_amg, AMGf_assign|AMGf_numarg);
2449     {
2450         dATARGET; dPOPTOPssrl;
2451         if (PL_op->op_private & HINT_INTEGER) {
2452           const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2453           SETi(i);
2454         }
2455         else {
2456           const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2457           SETu(u);
2458         }
2459     }
2460     RETURN;
2461 }
2462
2463 PP(pp_sbit_and)
2464 {
2465     dSP;
2466     tryAMAGICbin_MG(sband_amg, AMGf_assign);
2467     {
2468         dATARGET; dPOPTOPssrl;
2469         do_vop(OP_BIT_AND, TARG, left, right);
2470         RETSETTARG;
2471     }
2472 }
2473
2474 /* also used for: pp_bit_xor() */
2475
2476 PP(pp_bit_or)
2477 {
2478     dSP; dATARGET;
2479     const int op_type = PL_op->op_type;
2480
2481     tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2482     {
2483       dPOPTOPssrl;
2484       if (SvNIOKp(left) || SvNIOKp(right)) {
2485         const bool left_ro_nonnum  = !SvNIOKp(left) && SvREADONLY(left);
2486         const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2487         if (PL_op->op_private & HINT_INTEGER) {
2488           const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2489           const IV r = SvIV_nomg(right);
2490           const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2491           SETi(result);
2492         }
2493         else {
2494           const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2495           const UV r = SvUV_nomg(right);
2496           const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2497           SETu(result);
2498         }
2499         if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2500         if (right_ro_nonnum) SvNIOK_off(right);
2501       }
2502       else {
2503         do_vop(op_type, TARG, left, right);
2504         SETTARG;
2505       }
2506       RETURN;
2507     }
2508 }
2509
2510 /* also used for: pp_nbit_xor() */
2511
2512 PP(pp_nbit_or)
2513 {
2514     dSP;
2515     const int op_type = PL_op->op_type;
2516
2517     tryAMAGICbin_MG((op_type == OP_NBIT_OR ? bor_amg : bxor_amg),
2518                     AMGf_assign|AMGf_numarg);
2519     {
2520         dATARGET; dPOPTOPssrl;
2521         if (PL_op->op_private & HINT_INTEGER) {
2522           const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2523           const IV r = SvIV_nomg(right);
2524           const IV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2525           SETi(result);
2526         }
2527         else {
2528           const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2529           const UV r = SvUV_nomg(right);
2530           const UV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2531           SETu(result);
2532         }
2533     }
2534     RETURN;
2535 }
2536
2537 /* also used for: pp_sbit_xor() */
2538
2539 PP(pp_sbit_or)
2540 {
2541     dSP;
2542     const int op_type = PL_op->op_type;
2543
2544     tryAMAGICbin_MG((op_type == OP_SBIT_OR ? sbor_amg : sbxor_amg),
2545                     AMGf_assign);
2546     {
2547         dATARGET; dPOPTOPssrl;
2548         do_vop(op_type == OP_SBIT_OR ? OP_BIT_OR : OP_BIT_XOR, TARG, left,
2549                right);
2550         RETSETTARG;
2551     }
2552 }
2553
2554 PERL_STATIC_INLINE bool
2555 S_negate_string(pTHX)
2556 {
2557     dTARGET; dSP;
2558     STRLEN len;
2559     const char *s;
2560     SV * const sv = TOPs;
2561     if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2562         return FALSE;
2563     s = SvPV_nomg_const(sv, len);
2564     if (isIDFIRST(*s)) {
2565         sv_setpvs(TARG, "-");
2566         sv_catsv(TARG, sv);
2567     }
2568     else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2569         sv_setsv_nomg(TARG, sv);
2570         *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2571     }
2572     else return FALSE;
2573     SETTARG;
2574     return TRUE;
2575 }
2576
2577 PP(pp_negate)
2578 {
2579     dSP; dTARGET;
2580     tryAMAGICun_MG(neg_amg, AMGf_numeric);
2581     if (S_negate_string(aTHX)) return NORMAL;
2582     {
2583         SV * const sv = TOPs;
2584
2585         if (SvIOK(sv)) {
2586             /* It's publicly an integer */
2587         oops_its_an_int:
2588             if (SvIsUV(sv)) {
2589                 if (SvIVX(sv) == IV_MIN) {
2590                     /* 2s complement assumption. */
2591                     SETi(SvIVX(sv));    /* special case: -((UV)IV_MAX+1) ==
2592                                            IV_MIN */
2593                     return NORMAL;
2594                 }
2595                 else if (SvUVX(sv) <= IV_MAX) {
2596                     SETi(-SvIVX(sv));
2597                     return NORMAL;
2598                 }
2599             }
2600             else if (SvIVX(sv) != IV_MIN) {
2601                 SETi(-SvIVX(sv));
2602                 return NORMAL;
2603             }
2604 #ifdef PERL_PRESERVE_IVUV
2605             else {
2606                 SETu((UV)IV_MIN);
2607                 return NORMAL;
2608             }
2609 #endif
2610         }
2611         if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
2612             SETn(-SvNV_nomg(sv));
2613         else if (SvPOKp(sv) && SvIV_please_nomg(sv))
2614                   goto oops_its_an_int;
2615         else
2616             SETn(-SvNV_nomg(sv));
2617     }
2618     return NORMAL;
2619 }
2620
2621 PP(pp_not)
2622 {
2623     dSP;
2624     tryAMAGICun_MG(not_amg, AMGf_set);
2625     *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
2626     return NORMAL;
2627 }
2628
2629 static void
2630 S_scomplement(pTHX_ SV *targ, SV *sv)
2631 {
2632         U8 *tmps;
2633         I32 anum;
2634         STRLEN len;
2635
2636         sv_copypv_nomg(TARG, sv);
2637         tmps = (U8*)SvPV_nomg(TARG, len);
2638
2639         if (SvUTF8(TARG)) {
2640             if (len && ! utf8_to_bytes(tmps, &len)) {
2641                 Perl_croak(aTHX_ fatal_above_ff_msg, PL_op_desc[PL_op->op_type]);
2642             }
2643             SvCUR(TARG) = len;
2644             SvUTF8_off(TARG);
2645         }
2646
2647         anum = len;
2648
2649 #ifdef LIBERAL
2650         {
2651             long *tmpl;
2652             for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2653                 *tmps = ~*tmps;
2654             tmpl = (long*)tmps;
2655             for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2656                 *tmpl = ~*tmpl;
2657             tmps = (U8*)tmpl;
2658         }
2659 #endif
2660         for ( ; anum > 0; anum--, tmps++)
2661             *tmps = ~*tmps;
2662 }
2663
2664 PP(pp_complement)
2665 {
2666     dSP; dTARGET;
2667     tryAMAGICun_MG(compl_amg, AMGf_numeric);
2668     {
2669       dTOPss;
2670       if (SvNIOKp(sv)) {
2671         if (PL_op->op_private & HINT_INTEGER) {
2672           const IV i = ~SvIV_nomg(sv);
2673           SETi(i);
2674         }
2675         else {
2676           const UV u = ~SvUV_nomg(sv);
2677           SETu(u);
2678         }
2679       }
2680       else {
2681         S_scomplement(aTHX_ TARG, sv);
2682         SETTARG;
2683       }
2684       return NORMAL;
2685     }
2686 }
2687
2688 PP(pp_ncomplement)
2689 {
2690     dSP;
2691     tryAMAGICun_MG(compl_amg, AMGf_numeric|AMGf_numarg);
2692     {
2693         dTARGET; dTOPss;
2694         if (PL_op->op_private & HINT_INTEGER) {
2695           const IV i = ~SvIV_nomg(sv);
2696           SETi(i);
2697         }
2698         else {
2699           const UV u = ~SvUV_nomg(sv);
2700           SETu(u);
2701         }
2702     }
2703     return NORMAL;
2704 }
2705
2706 PP(pp_scomplement)
2707 {
2708     dSP;
2709     tryAMAGICun_MG(scompl_amg, AMGf_numeric);
2710     {
2711         dTARGET; dTOPss;
2712         S_scomplement(aTHX_ TARG, sv);
2713         SETTARG;
2714         return NORMAL;
2715     }
2716 }
2717
2718 /* integer versions of some of the above */
2719
2720 PP(pp_i_multiply)
2721 {
2722     dSP; dATARGET;
2723     tryAMAGICbin_MG(mult_amg, AMGf_assign);
2724     {
2725       dPOPTOPiirl_nomg;
2726       SETi( left * right );
2727       RETURN;
2728     }
2729 }
2730
2731 PP(pp_i_divide)
2732 {
2733     IV num;
2734     dSP; dATARGET;
2735     tryAMAGICbin_MG(div_amg, AMGf_assign);
2736     {
2737       dPOPTOPssrl;
2738       IV value = SvIV_nomg(right);
2739       if (value == 0)
2740           DIE(aTHX_ "Illegal division by zero");
2741       num = SvIV_nomg(left);
2742
2743       /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2744       if (value == -1)
2745           value = - num;
2746       else
2747           value = num / value;
2748       SETi(value);
2749       RETURN;
2750     }
2751 }
2752
2753 PP(pp_i_modulo)
2754 {
2755      /* This is the vanilla old i_modulo. */
2756      dSP; dATARGET;
2757      tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2758      {
2759           dPOPTOPiirl_nomg;
2760           if (!right)
2761                DIE(aTHX_ "Illegal modulus zero");
2762           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2763           if (right == -1)
2764               SETi( 0 );
2765           else
2766               SETi( left % right );
2767           RETURN;
2768      }
2769 }
2770
2771 #if defined(__GLIBC__) && IVSIZE == 8 \
2772     && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
2773
2774 PP(pp_i_modulo_glibc_bugfix)
2775 {
2776      /* This is the i_modulo with the workaround for the _moddi3 bug
2777       * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2778       * See below for pp_i_modulo. */
2779      dSP; dATARGET;
2780      tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2781      {
2782           dPOPTOPiirl_nomg;
2783           if (!right)
2784                DIE(aTHX_ "Illegal modulus zero");
2785           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2786           if (right == -1)
2787               SETi( 0 );
2788           else
2789               SETi( left % PERL_ABS(right) );
2790           RETURN;
2791      }
2792 }
2793 #endif
2794
2795 PP(pp_i_add)
2796 {
2797     dSP; dATARGET;
2798     tryAMAGICbin_MG(add_amg, AMGf_assign);
2799     {
2800       dPOPTOPiirl_ul_nomg;
2801       SETi( left + right );
2802       RETURN;
2803     }
2804 }
2805
2806 PP(pp_i_subtract)
2807 {
2808     dSP; dATARGET;
2809     tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2810     {
2811       dPOPTOPiirl_ul_nomg;
2812       SETi( left - right );
2813       RETURN;
2814     }
2815 }
2816
2817 PP(pp_i_lt)
2818 {
2819     dSP;
2820     tryAMAGICbin_MG(lt_amg, AMGf_set);
2821     {
2822       dPOPTOPiirl_nomg;
2823       SETs(boolSV(left < right));
2824       RETURN;
2825     }
2826 }
2827
2828 PP(pp_i_gt)
2829 {
2830     dSP;
2831     tryAMAGICbin_MG(gt_amg, AMGf_set);
2832     {
2833       dPOPTOPiirl_nomg;
2834       SETs(boolSV(left > right));
2835       RETURN;
2836     }
2837 }
2838
2839 PP(pp_i_le)
2840 {
2841     dSP;
2842     tryAMAGICbin_MG(le_amg, AMGf_set);
2843     {
2844       dPOPTOPiirl_nomg;
2845       SETs(boolSV(left <= right));
2846       RETURN;
2847     }
2848 }
2849
2850 PP(pp_i_ge)
2851 {
2852     dSP;
2853     tryAMAGICbin_MG(ge_amg, AMGf_set);
2854     {
2855       dPOPTOPiirl_nomg;
2856       SETs(boolSV(left >= right));
2857       RETURN;
2858     }
2859 }
2860
2861 PP(pp_i_eq)
2862 {
2863     dSP;
2864     tryAMAGICbin_MG(eq_amg, AMGf_set);
2865     {
2866       dPOPTOPiirl_nomg;
2867       SETs(boolSV(left == right));
2868       RETURN;
2869     }
2870 }
2871
2872 PP(pp_i_ne)
2873 {
2874     dSP;
2875     tryAMAGICbin_MG(ne_amg, AMGf_set);
2876     {
2877       dPOPTOPiirl_nomg;
2878       SETs(boolSV(left != right));
2879       RETURN;
2880     }
2881 }
2882
2883 PP(pp_i_ncmp)
2884 {
2885     dSP; dTARGET;
2886     tryAMAGICbin_MG(ncmp_amg, 0);
2887     {
2888       dPOPTOPiirl_nomg;
2889       I32 value;
2890
2891       if (left > right)
2892         value = 1;
2893       else if (left < right)
2894         value = -1;
2895       else
2896         value = 0;
2897       SETi(value);
2898       RETURN;
2899     }
2900 }
2901
2902 PP(pp_i_negate)
2903 {
2904     dSP; dTARGET;
2905     tryAMAGICun_MG(neg_amg, 0);
2906     if (S_negate_string(aTHX)) return NORMAL;
2907     {
2908         SV * const sv = TOPs;
2909         IV const i = SvIV_nomg(sv);
2910         SETi(-i);
2911         return NORMAL;
2912     }
2913 }
2914
2915 /* High falutin' math. */
2916
2917 PP(pp_atan2)
2918 {
2919     dSP; dTARGET;
2920     tryAMAGICbin_MG(atan2_amg, 0);
2921     {
2922       dPOPTOPnnrl_nomg;
2923       SETn(Perl_atan2(left, right));
2924       RETURN;
2925     }
2926 }
2927
2928
2929 /* also used for: pp_cos() pp_exp() pp_log() pp_sqrt() */
2930
2931 PP(pp_sin)
2932 {
2933     dSP; dTARGET;
2934     int amg_type = fallback_amg;
2935     const char *neg_report = NULL;
2936     const int op_type = PL_op->op_type;
2937
2938     switch (op_type) {
2939     case OP_SIN:  amg_type = sin_amg; break;
2940     case OP_COS:  amg_type = cos_amg; break;
2941     case OP_EXP:  amg_type = exp_amg; break;
2942     case OP_LOG:  amg_type = log_amg;  neg_report = "log";  break;
2943     case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break;
2944     }
2945
2946     assert(amg_type != fallback_amg);
2947
2948     tryAMAGICun_MG(amg_type, 0);
2949     {
2950       SV * const arg = TOPs;
2951       const NV value = SvNV_nomg(arg);
2952 #ifdef NV_NAN
2953       NV result = NV_NAN;
2954 #else
2955       NV result = 0.0;
2956 #endif
2957       if (neg_report) { /* log or sqrt */
2958           if (
2959 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2960               ! Perl_isnan(value) &&
2961 #endif
2962               (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0))) {
2963               SET_NUMERIC_STANDARD();
2964               /* diag_listed_as: Can't take log of %g */
2965               DIE(aTHX_ "Can't take %s of %" NVgf, neg_report, value);
2966           }
2967       }
2968       switch (op_type) {
2969       default:
2970       case OP_SIN:  result = Perl_sin(value);  break;
2971       case OP_COS:  result = Perl_cos(value);  break;
2972       case OP_EXP:  result = Perl_exp(value);  break;
2973       case OP_LOG:  result = Perl_log(value);  break;
2974       case OP_SQRT: result = Perl_sqrt(value); break;
2975       }
2976       SETn(result);
2977       return NORMAL;
2978     }
2979 }
2980
2981 /* Support Configure command-line overrides for rand() functions.
2982    After 5.005, perhaps we should replace this by Configure support
2983    for drand48(), random(), or rand().  For 5.005, though, maintain
2984    compatibility by calling rand() but allow the user to override it.
2985    See INSTALL for details.  --Andy Dougherty  15 July 1998
2986 */
2987 /* Now it's after 5.005, and Configure supports drand48() and random(),
2988    in addition to rand().  So the overrides should not be needed any more.
2989    --Jarkko Hietaniemi  27 September 1998
2990  */
2991
2992 PP(pp_rand)
2993 {
2994     if (!PL_srand_called) {
2995         (void)seedDrand01((Rand_seed_t)seed());
2996         PL_srand_called = TRUE;
2997     }
2998     {
2999         dSP;
3000         NV value;
3001
3002         if (MAXARG < 1)
3003         {
3004             EXTEND(SP, 1);
3005             value = 1.0;
3006         }
3007         else {
3008             SV * const sv = POPs;
3009             if(!sv)
3010                 value = 1.0;
3011             else
3012                 value = SvNV(sv);
3013         }
3014     /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
3015 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
3016         if (! Perl_isnan(value) && value == 0.0)
3017 #else
3018         if (value == 0.0)
3019 #endif
3020             value = 1.0;
3021         {
3022             dTARGET;
3023             PUSHs(TARG);
3024             PUTBACK;
3025             value *= Drand01();
3026             sv_setnv_mg(TARG, value);
3027         }
3028     }
3029     return NORMAL;
3030 }
3031
3032 PP(pp_srand)
3033 {
3034     dSP; dTARGET;
3035     UV anum;
3036
3037     if (MAXARG >= 1 && (TOPs || POPs)) {
3038         SV *top;
3039         char *pv;
3040         STRLEN len;
3041         int flags;
3042
3043         top = POPs;
3044         pv = SvPV(top, len);
3045         flags = grok_number(pv, len, &anum);
3046
3047         if (!(flags & IS_NUMBER_IN_UV)) {
3048             Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
3049                              "Integer overflow in srand");
3050             anum = UV_MAX;
3051         }
3052     }
3053     else {
3054         anum = seed();
3055     }
3056
3057     (void)seedDrand01((Rand_seed_t)anum);
3058     PL_srand_called = TRUE;
3059     if (anum)
3060         XPUSHu(anum);
3061     else {
3062         /* Historically srand always returned true. We can avoid breaking
3063            that like this:  */
3064         sv_setpvs(TARG, "0 but true");
3065         XPUSHTARG;
3066     }
3067     RETURN;
3068 }
3069
3070 PP(pp_int)
3071 {
3072     dSP; dTARGET;
3073     tryAMAGICun_MG(int_amg, AMGf_numeric);
3074     {
3075       SV * const sv = TOPs;
3076       const IV iv = SvIV_nomg(sv);
3077       /* XXX it's arguable that compiler casting to IV might be subtly
3078          different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
3079          else preferring IV has introduced a subtle behaviour change bug. OTOH
3080          relying on floating point to be accurate is a bug.  */
3081
3082       if (!SvOK(sv)) {
3083         SETu(0);
3084       }
3085       else if (SvIOK(sv)) {
3086         if (SvIsUV(sv))
3087             SETu(SvUV_nomg(sv));
3088         else
3089             SETi(iv);
3090       }
3091       else {
3092           const NV value = SvNV_nomg(sv);
3093           if (UNLIKELY(Perl_isinfnan(value)))
3094               SETn(value);
3095           else if (value >= 0.0) {
3096               if (value < (NV)UV_MAX + 0.5) {
3097                   SETu(U_V(value));
3098               } else {
3099                   SETn(Perl_floor(value));
3100               }
3101           }
3102           else {
3103               if (value > (NV)IV_MIN - 0.5) {
3104                   SETi(I_V(value));
3105               } else {
3106                   SETn(Perl_ceil(value));
3107               }
3108           }
3109       }
3110     }
3111     return NORMAL;
3112 }
3113
3114 PP(pp_abs)
3115 {
3116     dSP; dTARGET;
3117     tryAMAGICun_MG(abs_amg, AMGf_numeric);
3118     {
3119       SV * const sv = TOPs;
3120       /* This will cache the NV value if string isn't actually integer  */
3121       const IV iv = SvIV_nomg(sv);
3122
3123       if (!SvOK(sv)) {
3124         SETu(0);
3125       }
3126       else if (SvIOK(sv)) {
3127         /* IVX is precise  */
3128         if (SvIsUV(sv)) {
3129           SETu(SvUV_nomg(sv));  /* force it to be numeric only */
3130         } else {
3131           if (iv >= 0) {
3132             SETi(iv);
3133           } else {
3134             if (iv != IV_MIN) {
3135               SETi(-iv);
3136             } else {
3137               /* 2s complement assumption. Also, not really needed as
3138                  IV_MIN and -IV_MIN should both be %100...00 and NV-able  */
3139               SETu((UV)IV_MIN);
3140             }
3141           }
3142         }
3143       } else{
3144         const NV value = SvNV_nomg(sv);
3145         if (value < 0.0)
3146           SETn(-value);
3147         else
3148           SETn(value);
3149       }
3150     }
3151     return NORMAL;
3152 }
3153
3154
3155 /* also used for: pp_hex() */
3156
3157 PP(pp_oct)
3158 {
3159     dSP; dTARGET;
3160     const char *tmps;
3161     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
3162     STRLEN len;
3163     NV result_nv;
3164     UV result_uv;
3165     SV* const sv = TOPs;
3166
3167     tmps = (SvPV_const(sv, len));
3168     if (DO_UTF8(sv)) {
3169          /* If Unicode, try to downgrade
3170           * If not possible, croak. */
3171          SV* const tsv = sv_2mortal(newSVsv(sv));
3172
3173          SvUTF8_on(tsv);
3174          sv_utf8_downgrade(tsv, FALSE);
3175          tmps = SvPV_const(tsv, len);
3176     }
3177     if (PL_op->op_type == OP_HEX)
3178         goto hex;
3179
3180     while (*tmps && len && isSPACE(*tmps))
3181         tmps++, len--;
3182     if (*tmps == '0')
3183         tmps++, len--;
3184     if (isALPHA_FOLD_EQ(*tmps, 'x')) {
3185     hex:
3186         result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3187     }
3188     else if (isALPHA_FOLD_EQ(*tmps, 'b'))
3189         result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3190     else
3191         result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3192
3193     if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3194         SETn(result_nv);
3195     }
3196     else {
3197         SETu(result_uv);
3198     }
3199     return NORMAL;
3200 }
3201
3202 /* String stuff. */
3203
3204 PP(pp_length)
3205 {
3206     dSP; dTARGET;
3207     SV * const sv = TOPs;
3208
3209     U32 in_bytes = IN_BYTES;
3210     /* simplest case shortcut */
3211     /* turn off SVf_UTF8 in tmp flags if HINT_BYTES on*/
3212     U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8);
3213     STATIC_ASSERT_STMT(HINT_BYTES == 0x00000008 && SVf_UTF8 == 0x20000000 && (SVf_UTF8 == HINT_BYTES << 26));
3214     SETs(TARG);
3215
3216     if(LIKELY(svflags == SVf_POK))
3217         goto simple_pv;
3218     if(svflags & SVs_GMG)
3219         mg_get(sv);
3220     if (SvOK(sv)) {
3221         if (!IN_BYTES) /* reread to avoid using an C auto/register */
3222             sv_setiv(TARG, (IV)sv_len_utf8_nomg(sv));
3223         else
3224         {
3225             STRLEN len;
3226             /* unrolled SvPV_nomg_const(sv,len) */
3227             if(SvPOK_nog(sv)){
3228                 simple_pv:
3229                 len = SvCUR(sv);
3230             } else  {
3231                 (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN);
3232             }
3233             sv_setiv(TARG, (IV)(len));
3234         }
3235     } else {
3236         if (!SvPADTMP(TARG)) {
3237             sv_set_undef(TARG);
3238         } else { /* TARG is on stack at this point and is overwriten by SETs.
3239                    This branch is the odd one out, so put TARG by default on
3240                    stack earlier to let local SP go out of liveness sooner */
3241             SETs(&PL_sv_undef);
3242             goto no_set_magic;
3243         }
3244     }
3245     SvSETMAGIC(TARG);
3246     no_set_magic:
3247     return NORMAL; /* no putback, SP didn't move in this opcode */
3248 }
3249
3250 /* Returns false if substring is completely outside original string.
3251    No length is indicated by len_iv = 0 and len_is_uv = 0.  len_is_uv must
3252    always be true for an explicit 0.
3253 */
3254 bool
3255 Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv,
3256                                 bool pos1_is_uv, IV len_iv,
3257                                 bool len_is_uv, STRLEN *posp,
3258                                 STRLEN *lenp)
3259 {
3260     IV pos2_iv;
3261     int    pos2_is_uv;
3262
3263     PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
3264
3265     if (!pos1_is_uv && pos1_iv < 0 && curlen) {
3266         pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3267         pos1_iv += curlen;
3268     }
3269     if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
3270         return FALSE;
3271
3272     if (len_iv || len_is_uv) {
3273         if (!len_is_uv && len_iv < 0) {
3274             pos2_iv = curlen + len_iv;
3275             if (curlen)
3276                 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3277             else
3278                 pos2_is_uv = 0;
3279         } else {  /* len_iv >= 0 */
3280             if (!pos1_is_uv && pos1_iv < 0) {
3281                 pos2_iv = pos1_iv + len_iv;
3282                 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3283             } else {
3284                 if ((UV)len_iv > curlen-(UV)pos1_iv)
3285                     pos2_iv = curlen;
3286                 else
3287                     pos2_iv = pos1_iv+len_iv;
3288                 pos2_is_uv = 1;
3289             }
3290         }
3291     }
3292     else {
3293         pos2_iv = curlen;
3294         pos2_is_uv = 1;
3295     }
3296
3297     if (!pos2_is_uv && pos2_iv < 0) {
3298         if (!pos1_is_uv && pos1_iv < 0)
3299             return FALSE;
3300         pos2_iv = 0;
3301     }
3302     else if (!pos1_is_uv && pos1_iv < 0)
3303         pos1_iv = 0;
3304
3305     if ((UV)pos2_iv < (UV)pos1_iv)
3306         pos2_iv = pos1_iv;
3307     if ((UV)pos2_iv > curlen)
3308         pos2_iv = curlen;
3309
3310     /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3311     *posp = (STRLEN)( (UV)pos1_iv );
3312     *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3313
3314     return TRUE;
3315 }
3316
3317 PP(pp_substr)
3318 {
3319     dSP; dTARGET;
3320     SV *sv;
3321     STRLEN curlen;
3322     STRLEN utf8_curlen;
3323     SV *   pos_sv;
3324     IV     pos1_iv;
3325     int    pos1_is_uv;
3326     SV *   len_sv;
3327     IV     len_iv = 0;
3328     int    len_is_uv = 0;
3329     I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3330     const bool rvalue = (GIMME_V != G_VOID);
3331     const char *tmps;
3332     SV *repl_sv = NULL;
3333     const char *repl = NULL;
3334     STRLEN repl_len;
3335     int num_args = PL_op->op_private & 7;
3336     bool repl_need_utf8_upgrade = FALSE;
3337
3338     if (num_args > 2) {
3339         if (num_args > 3) {
3340           if(!(repl_sv = POPs)) num_args--;
3341         }
3342         if ((len_sv = POPs)) {
3343             len_iv    = SvIV(len_sv);
3344             len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
3345         }
3346         else num_args--;
3347     }
3348     pos_sv     = POPs;
3349     pos1_iv    = SvIV(pos_sv);
3350     pos1_is_uv = SvIOK_UV(pos_sv);
3351     sv = POPs;
3352     if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3353         assert(!repl_sv);
3354         repl_sv = POPs;
3355     }
3356     if (lvalue && !repl_sv) {
3357         SV * ret;
3358         ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
3359         sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3360         LvTYPE(ret) = 'x';
3361         LvTARG(ret) = SvREFCNT_inc_simple(sv);
3362         LvTARGOFF(ret) =
3363             pos1_is_uv || pos1_iv >= 0
3364                 ? (STRLEN)(UV)pos1_iv
3365                 : (LvFLAGS(ret) |= LVf_NEG_OFF, (STRLEN)(UV)-pos1_iv);
3366         LvTARGLEN(ret) =
3367             len_is_uv || len_iv > 0
3368                 ? (STRLEN)(UV)len_iv
3369                 : (LvFLAGS(ret) |= LVf_NEG_LEN, (STRLEN)(UV)-len_iv);
3370
3371         PUSHs(ret);    /* avoid SvSETMAGIC here */
3372         RETURN;
3373     }
3374     if (repl_sv) {
3375         repl = SvPV_const(repl_sv, repl_len);
3376         SvGETMAGIC(sv);
3377         if (SvROK(sv))
3378             Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3379                             "Attempt to use reference as lvalue in substr"
3380             );
3381         tmps = SvPV_force_nomg(sv, curlen);
3382         if (DO_UTF8(repl_sv) && repl_len) {
3383             if (!DO_UTF8(sv)) {
3384                 /* Upgrade the dest, and recalculate tmps in case the buffer
3385                  * got reallocated; curlen may also have been changed */
3386                 sv_utf8_upgrade_nomg(sv);
3387                 tmps = SvPV_nomg(sv, curlen);
3388             }
3389         }
3390         else if (DO_UTF8(sv))
3391             repl_need_utf8_upgrade = TRUE;
3392     }
3393     else tmps = SvPV_const(sv, curlen);
3394     if (DO_UTF8(sv)) {
3395         utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
3396         if (utf8_curlen == curlen)
3397             utf8_curlen = 0;
3398         else
3399             curlen = utf8_curlen;
3400     }
3401     else
3402         utf8_curlen = 0;
3403
3404     {
3405         STRLEN pos, len, byte_len, byte_pos;
3406
3407         if (!translate_substr_offsets(
3408                 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3409         )) goto bound_fail;
3410
3411         byte_len = len;
3412         byte_pos = utf8_curlen
3413             ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
3414
3415         tmps += byte_pos;
3416
3417         if (rvalue) {
3418             SvTAINTED_off(TARG);                        /* decontaminate */
3419             SvUTF8_off(TARG);                   /* decontaminate */
3420             sv_setpvn(TARG, tmps, byte_len);
3421 #ifdef USE_LOCALE_COLLATE
3422             sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3423 #endif
3424             if (utf8_curlen)
3425                 SvUTF8_on(TARG);
3426         }
3427
3428         if (repl) {
3429             SV* repl_sv_copy = NULL;
3430
3431             if (repl_need_utf8_upgrade) {
3432                 repl_sv_copy = newSVsv(repl_sv);
3433                 sv_utf8_upgrade(repl_sv_copy);
3434                 repl = SvPV_const(repl_sv_copy, repl_len);
3435             }
3436             if (!SvOK(sv))
3437                 SvPVCLEAR(sv);
3438             sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3439             SvREFCNT_dec(repl_sv_copy);
3440         }
3441     }
3442     if (PL_op->op_private & OPpSUBSTR_REPL_FIRST)
3443         SP++;
3444     else if (rvalue) {
3445         SvSETMAGIC(TARG);
3446         PUSHs(TARG);
3447     }
3448     RETURN;
3449
3450   bound_fail:
3451     if (repl)
3452         Perl_croak(aTHX_ "substr outside of string");
3453     Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3454     RETPUSHUNDEF;
3455 }
3456
3457 PP(pp_vec)
3458 {
3459     dSP;
3460     const IV size   = POPi;
3461     SV* offsetsv   = POPs;
3462     SV * const src = POPs;
3463     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3464     SV * ret;
3465     UV   retuv;
3466     STRLEN offset = 0;
3467     char errflags = 0;
3468
3469     /* extract a STRLEN-ranged integer value from offsetsv into offset,
3470      * or flag that its out of range */
3471     {
3472         IV iv = SvIV(offsetsv);
3473
3474         /* avoid a large UV being wrapped to a negative value */
3475         if (SvIOK_UV(offsetsv) && SvUVX(offsetsv) > (UV)IV_MAX)
3476             errflags = LVf_OUT_OF_RANGE;
3477         else if (iv < 0)
3478             errflags = (LVf_NEG_OFF|LVf_OUT_OF_RANGE);
3479 #if PTRSIZE < IVSIZE
3480         else if (iv > Size_t_MAX)
3481             errflags = LVf_OUT_OF_RANGE;
3482 #endif
3483         else
3484             offset = (STRLEN)iv;
3485     }
3486
3487     retuv = errflags ? 0 : do_vecget(src, offset, size);
3488
3489     if (lvalue) {                       /* it's an lvalue! */
3490         ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
3491         sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3492         LvTYPE(ret) = 'v';
3493         LvTARG(ret) = SvREFCNT_inc_simple(src);
3494         LvTARGOFF(ret) = offset;
3495         LvTARGLEN(ret) = size;
3496         LvFLAGS(ret)   = errflags;
3497     }
3498     else {
3499         dTARGET;
3500         SvTAINTED_off(TARG);            /* decontaminate */
3501         ret = TARG;
3502     }
3503
3504     sv_setuv(ret, retuv);
3505     if (!lvalue)
3506         SvSETMAGIC(ret);
3507     PUSHs(ret);
3508     RETURN;
3509 }
3510
3511
3512 /* also used for: pp_rindex() */
3513
3514 PP(pp_index)
3515 {
3516     dSP; dTARGET;
3517     SV *big;
3518     SV *little;
3519     SV *temp = NULL;
3520     STRLEN biglen;
3521     STRLEN llen = 0;
3522     SSize_t offset = 0;
3523     SSize_t retval;
3524     const char *big_p;
3525     const char *little_p;
3526     bool big_utf8;
3527     bool little_utf8;
3528     const bool is_index = PL_op->op_type == OP_INDEX;
3529     const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
3530
3531     if (threeargs)
3532         offset = POPi;
3533     little = POPs;
3534     big = POPs;
3535     big_p = SvPV_const(big, biglen);
3536     little_p = SvPV_const(little, llen);
3537
3538     big_utf8 = DO_UTF8(big);
3539     little_utf8 = DO_UTF8(little);
3540     if (big_utf8 ^ little_utf8) {
3541         /* One needs to be upgraded.  */
3542         if (little_utf8) {
3543             /* Well, maybe instead we might be able to downgrade the small
3544                string?  */
3545             char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3546                                                      &little_utf8);
3547             if (little_utf8) {
3548                 /* If the large string is ISO-8859-1, and it's not possible to
3549                    convert the small string to ISO-8859-1, then there is no
3550                    way that it could be found anywhere by index.  */
3551                 retval = -1;
3552                 goto fail;
3553             }
3554
3555             /* At this point, pv is a malloc()ed string. So donate it to temp
3556                to ensure it will get free()d  */
3557             little = temp = newSV(0);
3558             sv_usepvn(temp, pv, llen);
3559             little_p = SvPVX(little);
3560         } else {
3561             temp = newSVpvn(little_p, llen);
3562
3563             sv_utf8_upgrade(temp);
3564             little = temp;
3565             little_p = SvPV_const(little, llen);
3566         }
3567     }
3568     if (SvGAMAGIC(big)) {
3569         /* Life just becomes a lot easier if I use a temporary here.
3570            Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3571            will trigger magic and overloading again, as will fbm_instr()
3572         */
3573         big = newSVpvn_flags(big_p, biglen,
3574                              SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3575         big_p = SvPVX(big);
3576     }
3577     if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3578         /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3579            warn on undef, and we've already triggered a warning with the
3580            SvPV_const some lines above. We can't remove that, as we need to
3581            call some SvPV to trigger overloading early and find out if the
3582            string is UTF-8.
3583            This is all getting too messy. The API isn't quite clean enough,
3584            because data access has side effects.
3585         */
3586         little = newSVpvn_flags(little_p, llen,
3587                                 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3588         little_p = SvPVX(little);
3589     }
3590
3591     if (!threeargs)
3592         offset = is_index ? 0 : biglen;
3593     else {
3594         if (big_utf8 && offset > 0)
3595             offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
3596         if (!is_index)
3597             offset += llen;
3598     }
3599     if (offset < 0)
3600         offset = 0;
3601     else if (offset > (SSize_t)biglen)
3602         offset = biglen;
3603     if (!(little_p = is_index
3604           ? fbm_instr((unsigned char*)big_p + offset,
3605                       (unsigned char*)big_p + biglen, little, 0)
3606           : rninstr(big_p,  big_p  + offset,
3607                     little_p, little_p + llen)))
3608         retval = -1;
3609     else {
3610         retval = little_p - big_p;
3611         if (retval > 1 && big_utf8)
3612             retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
3613     }
3614     SvREFCNT_dec(temp);
3615  fail:
3616     PUSHi(retval);
3617     RETURN;
3618 }
3619
3620 PP(pp_sprintf)
3621 {
3622     dSP; dMARK; dORIGMARK; dTARGET;
3623     SvTAINTED_off(TARG);
3624     do_sprintf(TARG, SP-MARK, MARK+1);
3625     TAINT_IF(SvTAINTED(TARG));
3626     SP = ORIGMARK;
3627     PUSHTARG;
3628     RETURN;
3629 }
3630
3631 PP(pp_ord)
3632 {
3633     dSP; dTARGET;
3634
3635     SV *argsv = TOPs;
3636     STRLEN len;
3637     const U8 *s = (U8*)SvPV_const(argsv, len);
3638
3639     SETu(DO_UTF8(argsv)
3640            ? (len ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV) : 0)
3641            : (UV)(*s));
3642
3643     return NORMAL;
3644 }
3645
3646 PP(pp_chr)
3647 {
3648     dSP; dTARGET;
3649     char *tmps;
3650     UV value;
3651     SV *top = TOPs;
3652
3653     SvGETMAGIC(top);
3654     if (UNLIKELY(SvAMAGIC(top)))
3655         top = sv_2num(top);
3656     if (UNLIKELY(isinfnansv(top)))
3657         Perl_croak(aTHX_ "Cannot chr %" NVgf, SvNV(top));
3658     else {
3659         if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3660             && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3661                 ||
3662                 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3663                  && SvNV_nomg(top) < 0.0)))
3664         {
3665             if (ckWARN(WARN_UTF8)) {
3666                 if (SvGMAGICAL(top)) {
3667                     SV *top2 = sv_newmortal();
3668                     sv_setsv_nomg(top2, top);
3669                     top = top2;
3670                 }
3671                 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3672                             "Invalid negative number (%" SVf ") in chr", SVfARG(top));
3673             }
3674             value = UNICODE_REPLACEMENT;
3675         } else {
3676             value = SvUV_nomg(top);
3677         }
3678     }
3679
3680     SvUPGRADE(TARG,SVt_PV);
3681
3682     if (value > 255 && !IN_BYTES) {
3683         SvGROW(TARG, (STRLEN)UVCHR_SKIP(value)+1);
3684         tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3685         SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3686         *tmps = '\0';
3687         (void)SvPOK_only(TARG);
3688         SvUTF8_on(TARG);
3689         SETTARG;
3690         return NORMAL;
3691     }
3692
3693     SvGROW(TARG,2);
3694     SvCUR_set(TARG, 1);
3695     tmps = SvPVX(TARG);
3696     *tmps++ = (char)value;
3697     *tmps = '\0';
3698     (void)SvPOK_only(TARG);
3699
3700     SETTARG;
3701     return NORMAL;
3702 }
3703
3704 PP(pp_crypt)
3705 {
3706 #ifdef HAS_CRYPT
3707     dSP; dTARGET;
3708     dPOPTOPssrl;
3709     STRLEN len;
3710     const char *tmps = SvPV_const(left, len);
3711
3712     if (DO_UTF8(left)) {
3713          /* If Unicode, try to downgrade.
3714           * If not possible, croak.
3715           * Yes, we made this up.  */
3716          SV* const tsv = newSVpvn_flags(tmps, len, SVf_UTF8|SVs_TEMP);
3717
3718          sv_utf8_downgrade(tsv, FALSE);
3719          tmps = SvPV_const(tsv, len);
3720     }
3721 #   ifdef USE_ITHREADS
3722 #     ifdef HAS_CRYPT_R
3723     if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3724       /* This should be threadsafe because in ithreads there is only
3725        * one thread per interpreter.  If this would not be true,
3726        * we would need a mutex to protect this malloc. */
3727         PL_reentrant_buffer->_crypt_struct_buffer =
3728           (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3729 #if defined(__GLIBC__) || defined(__EMX__)
3730         if (PL_reentrant_buffer->_crypt_struct_buffer) {
3731             PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3732             /* work around glibc-2.2.5 bug */
3733             PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3734         }
3735 #endif
3736     }
3737 #     endif /* HAS_CRYPT_R */
3738 #   endif /* USE_ITHREADS */
3739 #   ifdef FCRYPT
3740     sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3741 #   else
3742     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3743 #   endif
3744     SvUTF8_off(TARG);
3745     SETTARG;
3746     RETURN;
3747 #else
3748     DIE(aTHX_
3749       "The crypt() function is unimplemented due to excessive paranoia.");
3750 #endif
3751 }
3752
3753 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level.  So
3754  * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3755
3756
3757 /* also used for: pp_lcfirst() */
3758
3759 PP(pp_ucfirst)
3760 {
3761     /* Actually is both lcfirst() and ucfirst().  Only the first character
3762      * changes.  This means that possibly we can change in-place, ie., just
3763      * take the source and change that one character and store it back, but not
3764      * if read-only etc, or if the length changes */
3765
3766     dSP;
3767     SV *source = TOPs;
3768     STRLEN slen; /* slen is the byte length of the whole SV. */
3769     STRLEN need;
3770     SV *dest;
3771     bool inplace;   /* ? Convert first char only, in-place */
3772     bool doing_utf8 = FALSE;               /* ? using utf8 */
3773     bool convert_source_to_utf8 = FALSE;   /* ? need to convert */
3774     const int op_type = PL_op->op_type;
3775     const U8 *s;
3776     U8 *d;
3777     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3778     STRLEN ulen;    /* ulen is the byte length of the original Unicode character
3779                      * stored as UTF-8 at s. */
3780     STRLEN tculen;  /* tculen is the byte length of the freshly titlecased (or
3781                      * lowercased) character stored in tmpbuf.  May be either
3782                      * UTF-8 or not, but in either case is the number of bytes */
3783
3784     s = (const U8*)SvPV_const(source, slen);
3785
3786     /* We may be able to get away with changing only the first character, in
3787      * place, but not if read-only, etc.  Later we may discover more reasons to
3788      * not convert in-place. */
3789     inplace = !SvREADONLY(source) && SvPADTMP(source);
3790
3791     /* First calculate what the changed first character should be.  This affects
3792      * whether we can just swap it out, leaving the rest of the string unchanged,
3793      * or even if have to convert the dest to UTF-8 when the source isn't */
3794
3795     if (! slen) {   /* If empty */
3796         need = 1; /* still need a trailing NUL */
3797         ulen = 0;
3798     }
3799     else if (DO_UTF8(source)) { /* Is the source utf8? */
3800         doing_utf8 = TRUE;
3801         ulen = UTF8SKIP(s);
3802         if (op_type == OP_UCFIRST) {
3803 #ifdef USE_LOCALE_CTYPE
3804             _toTITLE_utf8_flags(s, s +slen, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3805 #else
3806             _toTITLE_utf8_flags(s, s +slen, tmpbuf, &tculen, 0);
3807 #endif
3808         }
3809         else {
3810 #ifdef USE_LOCALE_CTYPE
3811             _toLOWER_utf8_flags(s, s + slen, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3812 #else
3813             _toLOWER_utf8_flags(s, s + slen, tmpbuf, &tculen, 0);
3814 #endif
3815         }
3816
3817         /* we can't do in-place if the length changes.  */
3818         if (ulen != tculen) inplace = FALSE;
3819         need = slen + 1 - ulen + tculen;
3820     }
3821     else { /* Non-zero length, non-UTF-8,  Need to consider locale and if
3822             * latin1 is treated as caseless.  Note that a locale takes
3823             * precedence */
3824         ulen = 1;       /* Original character is 1 byte */
3825         tculen = 1;     /* Most characters will require one byte, but this will
3826                          * need to be overridden for the tricky ones */
3827         need = slen + 1;
3828
3829         if (op_type == OP_LCFIRST) {
3830
3831             /* lower case the first letter: no trickiness for any character */
3832 #ifdef USE_LOCALE_CTYPE
3833             if (IN_LC_RUNTIME(LC_CTYPE)) {
3834                 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3835                 *tmpbuf = toLOWER_LC(*s);
3836             }
3837             else
3838 #endif
3839             {
3840                 *tmpbuf = (IN_UNI_8_BIT)
3841                           ? toLOWER_LATIN1(*s)
3842                           : toLOWER(*s);
3843             }
3844         }
3845 #ifdef USE_LOCALE_CTYPE
3846         /* is ucfirst() */
3847         else if (IN_LC_RUNTIME(LC_CTYPE)) {
3848             if (IN_UTF8_CTYPE_LOCALE) {
3849                 goto do_uni_rules;
3850             }
3851
3852             _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3853             *tmpbuf = (U8) toUPPER_LC(*s); /* This would be a bug if any
3854                                               locales have upper and title case
3855                                               different */
3856         }
3857 #endif
3858         else if (! IN_UNI_8_BIT) {
3859             *tmpbuf = toUPPER(*s);      /* Returns caseless for non-ascii, or
3860                                          * on EBCDIC machines whatever the
3861                                          * native function does */
3862         }
3863         else {
3864             /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is
3865              * UTF-8, which we treat as not in locale), and cased latin1 */
3866             UV title_ord;
3867 #ifdef USE_LOCALE_CTYPE
3868       do_uni_rules:
3869 #endif
3870
3871             title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3872             if (tculen > 1) {
3873                 assert(tculen == 2);
3874
3875                 /* If the result is an upper Latin1-range character, it can
3876                  * still be represented in one byte, which is its ordinal */
3877                 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3878                     *tmpbuf = (U8) title_ord;
3879                     tculen = 1;
3880                 }
3881                 else {
3882                     /* Otherwise it became more than one ASCII character (in
3883                      * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3884                      * beyond Latin1, so the number of bytes changed, so can't
3885                      * replace just the first character in place. */
3886                     inplace = FALSE;
3887
3888                     /* If the result won't fit in a byte, the entire result
3889                      * will have to be in UTF-8.  Assume worst case sizing in
3890                      * conversion. (all latin1 characters occupy at most two
3891                      * bytes in utf8) */
3892                     if (title_ord > 255) {
3893                         doing_utf8 = TRUE;
3894                         convert_source_to_utf8 = TRUE;
3895                         need = slen * 2 + 1;
3896
3897                         /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3898                          * (both) characters whose title case is above 255 is
3899                          * 2. */
3900                         ulen = 2;
3901                     }
3902                     else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3903                         need = slen + 1 + 1;
3904                     }
3905                 }
3906             }
3907         } /* End of use Unicode (Latin1) semantics */
3908     } /* End of changing the case of the first character */
3909
3910     /* Here, have the first character's changed case stored in tmpbuf.  Ready to
3911      * generate the result */
3912     if (inplace) {
3913
3914         /* We can convert in place.  This means we change just the first
3915          * character without disturbing the rest; no need to grow */
3916         dest = source;
3917         s = d = (U8*)SvPV_force_nomg(source, slen);
3918     } else {
3919         dTARGET;
3920
3921         dest = TARG;
3922
3923         /* Here, we can't convert in place; we earlier calculated how much
3924          * space we will need, so grow to accommodate that */
3925         SvUPGRADE(dest, SVt_PV);
3926         d = (U8*)SvGROW(dest, need);
3927         (void)SvPOK_only(dest);
3928
3929         SETs(dest);
3930     }
3931
3932     if (doing_utf8) {
3933         if (! inplace) {
3934             if (! convert_source_to_utf8) {
3935
3936                 /* Here  both source and dest are in UTF-8, but have to create
3937                  * the entire output.  We initialize the result to be the
3938                  * title/lower cased first character, and then append the rest
3939                  * of the string. */
3940                 sv_setpvn(dest, (char*)tmpbuf, tculen);
3941                 if (slen > ulen) {
3942                     sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3943                 }
3944             }
3945             else {
3946                 const U8 *const send = s + slen;
3947
3948                 /* Here the dest needs to be in UTF-8, but the source isn't,
3949                  * except we earlier UTF-8'd the first character of the source
3950                  * into tmpbuf.  First put that into dest, and then append the
3951                  * rest of the source, converting it to UTF-8 as we go. */
3952
3953                 /* Assert tculen is 2 here because the only two characters that
3954                  * get to this part of the code have 2-byte UTF-8 equivalents */
3955                 *d++ = *tmpbuf;
3956                 *d++ = *(tmpbuf + 1);
3957                 s++;    /* We have just processed the 1st char */
3958
3959                 for (; s < send; s++) {
3960                     d = uvchr_to_utf8(d, *s);
3961                 }
3962                 *d = '\0';
3963                 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3964             }
3965             SvUTF8_on(dest);
3966         }
3967         else {   /* in-place UTF-8.  Just overwrite the first character */
3968             Copy(tmpbuf, d, tculen, U8);
3969             SvCUR_set(dest, need - 1);
3970         }
3971
3972     }
3973     else {  /* Neither source nor dest are in or need to be UTF-8 */
3974         if (slen) {
3975             if (inplace) {  /* in-place, only need to change the 1st char */
3976                 *d = *tmpbuf;
3977             }
3978             else {      /* Not in-place */
3979
3980                 /* Copy the case-changed character(s) from tmpbuf */
3981                 Copy(tmpbuf, d, tculen, U8);
3982                 d += tculen - 1; /* Code below expects d to point to final
3983                                   * character stored */
3984             }
3985         }
3986         else {  /* empty source */
3987             /* See bug #39028: Don't taint if empty  */
3988             *d = *s;
3989         }
3990
3991         /* In a "use bytes" we don't treat the source as UTF-8, but, still want
3992          * the destination to retain that flag */
3993         if (SvUTF8(source) && ! IN_BYTES)
3994             SvUTF8_on(dest);
3995
3996         if (!inplace) { /* Finish the rest of the string, unchanged */
3997             /* This will copy the trailing NUL  */
3998             Copy(s + 1, d + 1, slen, U8);
3999             SvCUR_set(dest, need - 1);
4000         }
4001     }
4002 #ifdef USE_LOCALE_CTYPE
4003     if (IN_LC_RUNTIME(LC_CTYPE)) {
4004         TAINT;
4005         SvTAINTED_on(dest);
4006     }
4007 #endif
4008     if (dest != source && SvTAINTED(source))
4009         SvTAINT(dest);
4010     SvSETMAGIC(dest);
4011     return NORMAL;
4012 }
4013
4014 /* There's so much setup/teardown code common between uc and lc, I wonder if
4015    it would be worth merging the two, and just having a switch outside each
4016    of the three tight loops.  There is less and less commonality though */
4017 PP(pp_uc)
4018 {
4019     dSP;
4020     SV *source = TOPs;
4021     STRLEN len;
4022     STRLEN min;
4023     SV *dest;
4024     const U8 *s;
4025     U8 *d;
4026
4027     SvGETMAGIC(source);
4028
4029     if (   SvPADTMP(source)
4030         && !SvREADONLY(source) && SvPOK(source)
4031         && !DO_UTF8(source)
4032         && (
4033 #ifdef USE_LOCALE_CTYPE
4034             (IN_LC_RUNTIME(LC_CTYPE))
4035             ? ! IN_UTF8_CTYPE_LOCALE
4036             :
4037 #endif
4038               ! IN_UNI_8_BIT))
4039     {
4040
4041         /* We can convert in place.  The reason we can't if in UNI_8_BIT is to
4042          * make the loop tight, so we overwrite the source with the dest before
4043          * looking at it, and we need to look at the original source
4044          * afterwards.  There would also need to be code added to handle
4045          * switching to not in-place in midstream if we run into characters
4046          * that change the length.  Since being in locale overrides UNI_8_BIT,
4047          * that latter becomes irrelevant in the above test; instead for
4048          * locale, the size can't normally change, except if the locale is a
4049          * UTF-8 one */
4050         dest = source;
4051         s = d = (U8*)SvPV_force_nomg(source, len);
4052         min = len + 1;
4053     } else {
4054         dTARGET;
4055
4056         dest = TARG;
4057
4058         s = (const U8*)SvPV_nomg_const(source, len);
4059         min = len + 1;
4060
4061         SvUPGRADE(dest, SVt_PV);
4062         d = (U8*)SvGROW(dest, min);
4063         (void)SvPOK_only(dest);
4064
4065         SETs(dest);
4066     }
4067
4068     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4069        to check DO_UTF8 again here.  */
4070
4071     if (DO_UTF8(source)) {
4072         const U8 *const send = s + len;
4073         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4074
4075         /* All occurrences of these are to be moved to follow any other marks.
4076          * This is context-dependent.  We may not be passed enough context to
4077          * move the iota subscript beyond all of them, but we do the best we can
4078          * with what we're given.  The result is always better than if we
4079          * hadn't done this.  And, the problem would only arise if we are
4080          * passed a character without all its combining marks, which would be
4081          * the caller's mistake.  The information this is based on comes from a
4082          * comment in Unicode SpecialCasing.txt, (and the Standard's text
4083          * itself) and so can't be checked properly to see if it ever gets
4084          * revised.  But the likelihood of it changing is remote */
4085         bool in_iota_subscript = FALSE;
4086
4087         while (s < send) {
4088             STRLEN u;
4089             STRLEN ulen;
4090             UV uv;
4091             if (in_iota_subscript && ! _is_utf8_mark(s)) {
4092
4093                 /* A non-mark.  Time to output the iota subscript */
4094                 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
4095                 d += capital_iota_len;
4096                 in_iota_subscript = FALSE;
4097             }
4098
4099             /* Then handle the current character.  Get the changed case value
4100              * and copy it to the output buffer */
4101
4102             u = UTF8SKIP(s);
4103 #ifdef USE_LOCALE_CTYPE
4104             uv = _toUPPER_utf8_flags(s, send, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4105 #else
4106             uv = _toUPPER_utf8_flags(s, send, tmpbuf, &ulen, 0);
4107 #endif
4108 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
4109 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
4110             if (uv == GREEK_CAPITAL_LETTER_IOTA
4111                 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
4112             {
4113                 in_iota_subscript = TRUE;
4114             }
4115             else {
4116                 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4117                     /* If the eventually required minimum size outgrows the
4118                      * available space, we need to grow. */
4119                     const UV o = d - (U8*)SvPVX_const(dest);
4120
4121                     /* If someone uppercases one million U+03B0s we SvGROW()
4122                      * one million times.  Or we could try guessing how much to
4123                      * allocate without allocating too much.  Such is life.
4124                      * See corresponding comment in lc code for another option
4125                      * */
4126                     d = o + (U8*) SvGROW(dest, min);
4127                 }
4128                 Copy(tmpbuf, d, ulen, U8);
4129                 d += ulen;
4130             }
4131             s += u;
4132         }
4133         if (in_iota_subscript) {
4134             Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
4135             d += capital_iota_len;
4136         }
4137         SvUTF8_on(dest);
4138         *d = '\0';
4139
4140         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4141     }
4142     else {      /* Not UTF-8 */
4143         if (len) {
4144             const U8 *const send = s + len;
4145
4146             /* Use locale casing if in locale; regular style if not treating
4147              * latin1 as having case; otherwise the latin1 casing.  Do the
4148              * whole thing in a tight loop, for speed, */
4149 #ifdef USE_LOCALE_CTYPE
4150             if (IN_LC_RUNTIME(LC_CTYPE)) {
4151                 if (IN_UTF8_CTYPE_LOCALE) {
4152                     goto do_uni_rules;
4153                 }
4154                 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4155                 for (; s < send; d++, s++)
4156                     *d = (U8) toUPPER_LC(*s);
4157             }
4158             else
4159 #endif
4160                  if (! IN_UNI_8_BIT) {
4161                 for (; s < send; d++, s++) {
4162                     *d = toUPPER(*s);
4163                 }
4164             }
4165             else {
4166 #ifdef USE_LOCALE_CTYPE
4167           do_uni_rules:
4168 #endif
4169                 for (; s < send; d++, s++) {
4170                     *d = toUPPER_LATIN1_MOD(*s);
4171                     if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
4172                         continue;
4173                     }
4174
4175                     /* The mainstream case is the tight loop above.  To avoid
4176                      * extra tests in that, all three characters that require
4177                      * special handling are mapped by the MOD to the one tested
4178                      * just above.
4179                      * Use the source to distinguish between the three cases */
4180
4181 #if    UNICODE_MAJOR_VERSION > 2                                        \
4182    || (UNICODE_MAJOR_VERSION == 2 && UNICODE_DOT_VERSION >= 1           \
4183                                   && UNICODE_DOT_DOT_VERSION >= 8)
4184                     if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4185
4186                         /* uc() of this requires 2 characters, but they are
4187                          * ASCII.  If not enough room, grow the string */
4188                         if (SvLEN(dest) < ++min) {
4189                             const UV o = d - (U8*)SvPVX_const(dest);
4190                             d = o + (U8*) SvGROW(dest, min);
4191                         }
4192                         *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
4193                         continue;   /* Back to the tight loop; still in ASCII */
4194                     }
4195 #endif
4196
4197                     /* The other two special handling characters have their
4198                      * upper cases outside the latin1 range, hence need to be
4199                      * in UTF-8, so the whole result needs to be in UTF-8.  So,
4200                      * here we are somewhere in the middle of processing a
4201                      * non-UTF-8 string, and realize that we will have to convert
4202                      * the whole thing to UTF-8.  What to do?  There are
4203                      * several possibilities.  The simplest to code is to
4204                      * convert what we have so far, set a flag, and continue on
4205                      * in the loop.  The flag would be tested each time through
4206                      * the loop, and if set, the next character would be
4207                      * converted to UTF-8 and stored.  But, I (khw) didn't want
4208                      * to slow down the mainstream case at all for this fairly
4209                      * rare case, so I didn't want to add a test that didn't
4210                      * absolutely have to be there in the loop, besides the
4211                      * possibility that it would get too complicated for
4212                      * optimizers to deal with.  Another possibility is to just
4213                      * give up, convert the source to UTF-8, and restart the
4214                      * function that way.  Another possibility is to convert
4215                      * both what has already been processed and what is yet to
4216                      * come separately to UTF-8, then jump into the loop that
4217                      * handles UTF-8.  But the most efficient time-wise of the
4218                      * ones I could think of is what follows, and turned out to
4219                      * not require much extra code.  */
4220
4221                     /* Convert what we have so far into UTF-8, telling the
4222                      * function that we know it should be converted, and to
4223                      * allow extra space for what we haven't processed yet.
4224                      * Assume the worst case space requirements for converting
4225                      * what we haven't processed so far: that it will require
4226                      * two bytes for each remaining source character, plus the
4227                      * NUL at the end.  This may cause the string pointer to
4228                      * move, so re-find it. */
4229
4230                     len = d - (U8*)SvPVX_const(dest);
4231                     SvCUR_set(dest, len);
4232                     len = sv_utf8_upgrade_flags_grow(dest,
4233                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4234                                                 (send -s) * 2 + 1);
4235                     d = (U8*)SvPVX(dest) + len;
4236
4237                     /* Now process the remainder of the source, converting to
4238                      * upper and UTF-8.  If a resulting byte is invariant in
4239                      * UTF-8, output it as-is, otherwise convert to UTF-8 and
4240                      * append it to the output. */
4241                     for (; s < send; s++) {
4242                         (void) _to_upper_title_latin1(*s, d, &len, 'S');
4243                         d += len;
4244                     }
4245
4246                     /* Here have processed the whole source; no need to continue
4247                      * with the outer loop.  Each character has been converted
4248                      * to upper case and converted to UTF-8 */
4249
4250                     break;
4251                 } /* End of processing all latin1-style chars */
4252             } /* End of processing all chars */
4253         } /* End of source is not empty */
4254
4255         if (source != dest) {
4256             *d = '\0';  /* Here d points to 1 after last char, add NUL */
4257             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4258         }
4259     } /* End of isn't utf8 */
4260 #ifdef USE_LOCALE_CTYPE
4261     if (IN_LC_RUNTIME(LC_CTYPE)) {
4262         TAINT;
4263         SvTAINTED_on(dest);
4264     }
4265 #endif
4266     if (dest != source && SvTAINTED(source))
4267         SvTAINT(dest);
4268     SvSETMAGIC(dest);
4269     return NORMAL;
4270 }
4271
4272 PP(pp_lc)
4273 {
4274     dSP;
4275     SV *source = TOPs;
4276     STRLEN len;
4277     STRLEN min;
4278     SV *dest;
4279     const U8 *s;
4280     U8 *d;
4281
4282     SvGETMAGIC(source);
4283
4284     if (   SvPADTMP(source)
4285         && !SvREADONLY(source) && SvPOK(source)
4286         && !DO_UTF8(source)) {
4287
4288         /* We can convert in place, as lowercasing anything in the latin1 range
4289          * (or else DO_UTF8 would have been on) doesn't lengthen it */
4290         dest = source;
4291         s = d = (U8*)SvPV_force_nomg(source, len);
4292         min = len + 1;
4293     } else {
4294         dTARGET;
4295
4296         dest = TARG;
4297
4298         s = (const U8*)SvPV_nomg_const(source, len);
4299         min = len + 1;
4300
4301         SvUPGRADE(dest, SVt_PV);
4302         d = (U8*)SvGROW(dest, min);
4303         (void)SvPOK_only(dest);
4304
4305         SETs(dest);
4306     }
4307
4308     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4309        to check DO_UTF8 again here.  */
4310
4311     if (DO_UTF8(source)) {
4312         const U8 *const send = s + len;
4313         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4314
4315         while (s < send) {
4316             const STRLEN u = UTF8SKIP(s);
4317             STRLEN ulen;
4318
4319 #ifdef USE_LOCALE_CTYPE
4320             _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4321 #else
4322             _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, 0);
4323 #endif
4324
4325             /* Here is where we would do context-sensitive actions.  See the
4326              * commit message for 86510fb15 for why there isn't any */
4327
4328             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4329
4330                 /* If the eventually required minimum size outgrows the
4331                  * available space, we need to grow. */
4332                 const UV o = d - (U8*)SvPVX_const(dest);
4333
4334                 /* If someone lowercases one million U+0130s we SvGROW() one
4335                  * million times.  Or we could try guessing how much to
4336                  * allocate without allocating too much.  Such is life.
4337                  * Another option would be to grow an extra byte or two more
4338                  * each time we need to grow, which would cut down the million
4339                  * to 500K, with little waste */
4340                 d = o + (U8*) SvGROW(dest, min);
4341             }
4342
4343             /* Copy the newly lowercased letter to the output buffer we're
4344              * building */
4345             Copy(tmpbuf, d, ulen, U8);
4346             d += ulen;
4347             s += u;
4348         }   /* End of looping through the source string */
4349         SvUTF8_on(dest);
4350         *d = '\0';
4351         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4352     } else {    /* Not utf8 */
4353         if (len) {
4354             const U8 *const send = s + len;
4355
4356             /* Use locale casing if in locale; regular style if not treating
4357              * latin1 as having case; otherwise the latin1 casing.  Do the
4358              * whole thing in a tight loop, for speed, */
4359 #ifdef USE_LOCALE_CTYPE
4360             if (IN_LC_RUNTIME(LC_CTYPE)) {
4361                 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4362                 for (; s < send; d++, s++)
4363                     *d = toLOWER_LC(*s);
4364             }
4365             else
4366 #endif
4367             if (! IN_UNI_8_BIT) {
4368                 for (; s < send; d++, s++) {
4369                     *d = toLOWER(*s);
4370                 }
4371             }
4372             else {
4373                 for (; s < send; d++, s++) {
4374                     *d = toLOWER_LATIN1(*s);
4375                 }
4376             }
4377         }
4378         if (source != dest) {
4379             *d = '\0';
4380             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4381         }
4382     }
4383 #ifdef USE_LOCALE_CTYPE
4384     if (IN_LC_RUNTIME(LC_CTYPE)) {
4385         TAINT;
4386         SvTAINTED_on(dest);
4387     }
4388 #endif
4389     if (dest != source && SvTAINTED(source))
4390         SvTAINT(dest);
4391     SvSETMAGIC(dest);
4392     return NORMAL;
4393 }
4394
4395 PP(pp_quotemeta)
4396 {
4397     dSP; dTARGET;
4398     SV * const sv = TOPs;
4399     STRLEN len;
4400     const char *s = SvPV_const(sv,len);
4401
4402     SvUTF8_off(TARG);                           /* decontaminate */
4403     if (len) {
4404         char *d;
4405         SvUPGRADE(TARG, SVt_PV);
4406         SvGROW(TARG, (len * 2) + 1);
4407         d = SvPVX(TARG);
4408         if (DO_UTF8(sv)) {
4409             while (len) {
4410                 STRLEN ulen = UTF8SKIP(s);
4411                 bool to_quote = FALSE;
4412
4413                 if (UTF8_IS_INVARIANT(*s)) {
4414                     if (_isQUOTEMETA(*s)) {
4415                         to_quote = TRUE;
4416                     }
4417                 }
4418                 else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(s, s + len)) {
4419                     if (
4420 #ifdef USE_LOCALE_CTYPE
4421                     /* In locale, we quote all non-ASCII Latin1 chars.
4422                      * Otherwise use the quoting rules */
4423
4424                     IN_LC_RUNTIME(LC_CTYPE)
4425                         ||
4426 #endif
4427                         _isQUOTEMETA(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s + 1))))
4428                     {
4429                         to_quote = TRUE;
4430                     }
4431                 }
4432                 else if (is_QUOTEMETA_high(s)) {
4433                     to_quote = TRUE;
4434                 }
4435
4436                 if (to_quote) {
4437                     *d++ = '\\';
4438                 }
4439                 if (ulen > len)
4440                     ulen = len;
4441                 len -= ulen;
4442                 while (ulen--)
4443                     *d++ = *s++;
4444             }
4445             SvUTF8_on(TARG);
4446         }
4447         else if (IN_UNI_8_BIT) {
4448             while (len--) {
4449                 if (_isQUOTEMETA(*s))
4450                     *d++ = '\\';
4451                 *d++ = *s++;
4452             }
4453         }
4454         else {
4455             /* For non UNI_8_BIT (and hence in locale) just quote all \W
4456              * including everything above ASCII */
4457             while (len--) {
4458                 if (!isWORDCHAR_A(*s))
4459                     *d++ = '\\';
4460                 *d++ = *s++;
4461             }
4462         }
4463         *d = '\0';
4464         SvCUR_set(TARG, d - SvPVX_const(TARG));
4465         (void)SvPOK_only_UTF8(TARG);
4466     }
4467     else
4468         sv_setpvn(TARG, s, len);
4469     SETTARG;
4470     return NORMAL;
4471 }
4472
4473 PP(pp_fc)
4474 {
4475     dTARGET;
4476     dSP;
4477     SV *source = TOPs;
4478     STRLEN len;
4479     STRLEN min;
4480     SV *dest;
4481     const U8 *s;
4482     const U8 *send;
4483     U8 *d;
4484     U8 tmpbuf[UTF8_MAXBYTES_CASE + 1];
4485 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
4486    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
4487                                       || UNICODE_DOT_DOT_VERSION > 0)
4488     const bool full_folding = TRUE; /* This variable is here so we can easily
4489                                        move to more generality later */
4490 #else
4491     const bool full_folding = FALSE;
4492 #endif
4493     const U8 flags = ( full_folding      ? FOLD_FLAGS_FULL   : 0 )
4494 #ifdef USE_LOCALE_CTYPE
4495                    | ( IN_LC_RUNTIME(LC_CTYPE) ? FOLD_FLAGS_LOCALE : 0 )
4496 #endif
4497     ;
4498
4499     /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4500      * You are welcome(?) -Hugmeir
4501      */
4502
4503     SvGETMAGIC(source);
4504
4505     dest = TARG;
4506
4507     if (SvOK(source)) {
4508         s = (const U8*)SvPV_nomg_const(source, len);
4509     } else {
4510         if (ckWARN(WARN_UNINITIALIZED))
4511             report_uninit(source);
4512         s = (const U8*)"";
4513         len = 0;
4514     }
4515
4516     min = len + 1;
4517
4518     SvUPGRADE(dest, SVt_PV);
4519     d = (U8*)SvGROW(dest, min);
4520     (void)SvPOK_only(dest);
4521
4522     SETs(dest);
4523
4524     send = s + len;
4525     if (DO_UTF8(source)) { /* UTF-8 flagged string. */
4526         while (s < send) {
4527             const STRLEN u = UTF8SKIP(s);
4528             STRLEN ulen;
4529
4530             _toFOLD_utf8_flags(s, send, tmpbuf, &ulen, flags);
4531
4532             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4533                 const UV o = d - (U8*)SvPVX_const(dest);
4534                 d = o + (U8*) SvGROW(dest, min);
4535             }
4536
4537             Copy(tmpbuf, d, ulen, U8);
4538             d += ulen;
4539             s += u;
4540         }
4541         SvUTF8_on(dest);
4542     } /* Unflagged string */
4543     else if (len) {
4544 #ifdef USE_LOCALE_CTYPE
4545         if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
4546             if (IN_UTF8_CTYPE_LOCALE) {
4547                 goto do_uni_folding;
4548             }
4549             _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4550             for (; s < send; d++, s++)
4551                 *d = (U8) toFOLD_LC(*s);
4552         }
4553         else
4554 #endif
4555         if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
4556             for (; s < send; d++, s++)
4557                 *d = toFOLD(*s);
4558         }
4559         else {
4560 #ifdef USE_LOCALE_CTYPE
4561       do_uni_folding:
4562 #endif
4563             /* For ASCII and the Latin-1 range, there's only two troublesome
4564              * folds, \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
4565              * casefolding becomes 'ss'; and \x{B5} (\N{MICRO SIGN}), which
4566              * under any fold becomes \x{3BC} (\N{GREEK SMALL LETTER MU}) --
4567              * For the rest, the casefold is their lowercase.  */
4568             for (; s < send; d++, s++) {
4569                 if (*s == MICRO_SIGN) {
4570                     /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
4571                      * which is outside of the latin-1 range. There's a couple
4572                      * of ways to deal with this -- khw discusses them in
4573                      * pp_lc/uc, so go there :) What we do here is upgrade what
4574                      * we had already casefolded, then enter an inner loop that
4575                      * appends the rest of the characters as UTF-8. */
4576                     len = d - (U8*)SvPVX_const(dest);
4577                     SvCUR_set(dest, len);
4578                     len = sv_utf8_upgrade_flags_grow(dest,
4579                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4580                                                 /* The max expansion for latin1
4581                                                  * chars is 1 byte becomes 2 */
4582                                                 (send -s) * 2 + 1);
4583                     d = (U8*)SvPVX(dest) + len;
4584
4585                     Copy(GREEK_SMALL_LETTER_MU_UTF8, d, small_mu_len, U8);
4586                     d += small_mu_len;
4587                     s++;
4588                     for (; s < send; s++) {
4589                         STRLEN ulen;
4590                         UV fc = _to_uni_fold_flags(*s, tmpbuf, &ulen, flags);
4591                         if UVCHR_IS_INVARIANT(fc) {
4592                             if (full_folding
4593                                 && *s == LATIN_SMALL_LETTER_SHARP_S)
4594                             {
4595                                 *d++ = 's';
4596                                 *d++ = 's';
4597                             }
4598                             else
4599                                 *d++ = (U8)fc;
4600                         }
4601                         else {
4602                             Copy(tmpbuf, d, ulen, U8);
4603                             d += ulen;
4604                         }
4605                     }
4606                     break;
4607                 }
4608                 else if (full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) {
4609                     /* Under full casefolding, LATIN SMALL LETTER SHARP S
4610                      * becomes "ss", which may require growing the SV. */
4611                     if (SvLEN(dest) < ++min) {
4612                         const UV o = d - (U8*)SvPVX_const(dest);
4613                         d = o + (U8*) SvGROW(dest, min);
4614                      }
4615                     *(d)++ = 's';
4616                     *d = 's';
4617                 }
4618                 else { /* If it's not one of those two, the fold is their lower
4619                           case */
4620                     *d = toLOWER_LATIN1(*s);
4621                 }
4622              }
4623         }
4624     }
4625     *d = '\0';
4626     SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4627
4628 #ifdef USE_LOCALE_CTYPE
4629     if (IN_LC_RUNTIME(LC_CTYPE)) {
4630         TAINT;
4631         SvTAINTED_on(dest);
4632     }
4633 #endif
4634     if (SvTAINTED(source))
4635         SvTAINT(dest);
4636     SvSETMAGIC(dest);
4637     RETURN;
4638 }
4639
4640 /* Arrays. */
4641
4642 PP(pp_aslice)
4643 {
4644     dSP; dMARK; dORIGMARK;
4645     AV *const av = MUTABLE_AV(POPs);
4646     const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4647
4648     if (SvTYPE(av) == SVt_PVAV) {
4649         const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4650         bool can_preserve = FALSE;
4651
4652         if (localizing) {
4653             MAGIC *mg;
4654             HV *stash;
4655
4656             can_preserve = SvCANEXISTDELETE(av);
4657         }
4658
4659         if (lval && localizing) {
4660             SV **svp;
4661             SSize_t max = -1;
4662             for (svp = MARK + 1; svp <= SP; svp++) {
4663                 const SSize_t elem = SvIV(*svp);
4664                 if (elem > max)
4665                     max = elem;
4666             }
4667             if (max > AvMAX(av))
4668                 av_extend(av, max);
4669         }
4670
4671         while (++MARK <= SP) {
4672             SV **svp;
4673             SSize_t elem = SvIV(*MARK);
4674             bool preeminent = TRUE;
4675
4676             if (localizing && can_preserve) {
4677                 /* If we can determine whether the element exist,
4678                  * Try to preserve the existenceness of a tied array
4679                  * element by using EXISTS and DELETE if possible.
4680