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