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