pp.c

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