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