pp.c

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