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