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