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