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