pp.c

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