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