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