pp.c

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