pp.c

   1 /*    pp.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
   4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  * 'It's a big house this, and very peculiar.  Always a bit more
  13  *  to discover, and no knowing what you'll find round a corner.
  14  *  And Elves, sir!'                            --Samwise Gamgee
  15  *
  16  *     [p.225 of _The Lord of the Rings_, II/i: "Many Meetings"]
  17  */
  18
  19 /* This file contains general pp ("push/pop") functions that execute the
  20  * opcodes that make up a perl program. A typical pp function expects to
  21  * find its arguments on the stack, and usually pushes its results onto
  22  * the stack, hence the 'pp' terminology. Each OP structure contains
  23  * a pointer to the relevant pp_foo() function.
  24  */
  25
  26 #include "EXTERN.h"
  27 #define PERL_IN_PP_C
  28 #include "perl.h"
  29 #include "keywords.h"
  30
  31 #include "reentr.h"
  32
  33 /* XXX I can't imagine anyone who doesn't have this actually _needs_
  34    it, since pid_t is an integral type.
  35    --AD  2/20/1998
  36 */
  37 #ifdef NEED_GETPID_PROTO
  38 extern Pid_t getpid (void);
  39 #endif
  40
  41 /*
  42  * Some BSDs and Cygwin default to POSIX math instead of IEEE.
  43  * This switches them over to IEEE.
  44  */
  45 #if defined(LIBM_LIB_VERSION)
  46     _LIB_VERSION_TYPE _LIB_VERSION = _IEEE_;
  47 #endif
  48
  49 /* variations on pp_null */
  50
  51 PP(pp_stub)
  52 {
  53     dVAR;
  54     dSP;
  55     if (GIMME_V == G_SCALAR)
  56         XPUSHs(&PL_sv_undef);
  57     RETURN;
  58 }
  59
  60 /* Pushy stuff. */
  61
  62 PP(pp_padav)
  63 {
  64     dVAR; dSP; dTARGET;
  65     I32 gimme;
  66     assert(SvTYPE(TARG) == SVt_PVAV);
  67     if (PL_op->op_private & OPpLVAL_INTRO)
  68         if (!(PL_op->op_private & OPpPAD_STATE))
  69             SAVECLEARSV(PAD_SVl(PL_op->op_targ));
  70     EXTEND(SP, 1);
  71     if (PL_op->op_flags & OPf_REF) {
  72         PUSHs(TARG);
  73         RETURN;
  74     } else if (PL_op->op_private & OPpMAYBE_LVSUB) {
  75        const I32 flags = is_lvalue_sub();
  76        if (flags && !(flags & OPpENTERSUB_INARGS)) {
  77         if (GIMME == G_SCALAR)
  78             /* diag_listed_as: Can't return %s to lvalue scalar context */
  79             Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
  80         PUSHs(TARG);
  81         RETURN;
  82        }
  83     }
  84     gimme = GIMME_V;
  85     if (gimme == G_ARRAY) {
  86         const I32 maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
  87         EXTEND(SP, maxarg);
  88         if (SvMAGICAL(TARG)) {
  89             U32 i;
  90             for (i=0; i < (U32)maxarg; i++) {
  91                 SV * const * const svp = av_fetch(MUTABLE_AV(TARG), i, FALSE);
  92                 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
  93             }
  94         }
  95         else {
  96             Copy(AvARRAY((const AV *)TARG), SP+1, maxarg, SV*);
  97         }
  98         SP += maxarg;
  99     }
 100     else if (gimme == G_SCALAR) {
 101         SV* const sv = sv_newmortal();
 102         const I32 maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
 103         sv_setiv(sv, maxarg);
 104         PUSHs(sv);
 105     }
 106     RETURN;
 107 }
 108
 109 PP(pp_padhv)
 110 {
 111     dVAR; dSP; dTARGET;
 112     I32 gimme;
 113
 114     assert(SvTYPE(TARG) == SVt_PVHV);
 115     XPUSHs(TARG);
 116     if (PL_op->op_private & OPpLVAL_INTRO)
 117         if (!(PL_op->op_private & OPpPAD_STATE))
 118             SAVECLEARSV(PAD_SVl(PL_op->op_targ));
 119     if (PL_op->op_flags & OPf_REF)
 120         RETURN;
 121     else if (PL_op->op_private & OPpMAYBE_LVSUB) {
 122       const I32 flags = is_lvalue_sub();
 123       if (flags && !(flags & OPpENTERSUB_INARGS)) {
 124         if (GIMME == G_SCALAR)
 125             /* diag_listed_as: Can't return %s to lvalue scalar context */
 126             Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
 127         RETURN;
 128       }
 129     }
 130     gimme = GIMME_V;
 131     if (gimme == G_ARRAY) {
 132         RETURNOP(Perl_do_kv(aTHX));
 133     }
 134     else if (PL_op->op_private & OpMAYBE_TRUEBOOL
 135           && block_gimme() == G_VOID)
 136         SETs(boolSV(HvUSEDKEYS(TARG)));
 137     else if (gimme == G_SCALAR) {
 138         SV* const sv = Perl_hv_scalar(aTHX_ MUTABLE_HV(TARG));
 139         SETs(sv);
 140     }
 141     RETURN;
 142 }
 143
 144 /* Translations. */
 145
 146 static const char S_no_symref_sv[] =
 147     "Can't use string (\"%" SVf32 "\"%s) as %s ref while \"strict refs\" in use";
 148
 149 /* In some cases this function inspects PL_op.  If this function is called
 150    for new op types, more bool parameters may need to be added in place of
 151    the checks.
 152
 153    When noinit is true, the absence of a gv will cause a retval of undef.
 154    This is unrelated to the cv-to-gv assignment case.
 155 */
 156
 157 static SV *
 158 S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict,
 159               const bool noinit)
 160 {
 161     dVAR;
 162     if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv);
 163     if (SvROK(sv)) {
 164         if (SvAMAGIC(sv)) {
 165             sv = amagic_deref_call(sv, to_gv_amg);
 166         }
 167       wasref:
 168         sv = SvRV(sv);
 169         if (SvTYPE(sv) == SVt_PVIO) {
 170             GV * const gv = MUTABLE_GV(sv_newmortal());
 171             gv_init(gv, 0, "__ANONIO__", 10, 0);
 172             GvIOp(gv) = MUTABLE_IO(sv);
 173             SvREFCNT_inc_void_NN(sv);
 174             sv = MUTABLE_SV(gv);
 175         }
 176         else if (!isGV_with_GP(sv))
 177             return (SV *)Perl_die(aTHX_ "Not a GLOB reference");
 178     }
 179     else {
 180         if (!isGV_with_GP(sv)) {
 181             if (!SvOK(sv)) {
 182                 /* If this is a 'my' scalar and flag is set then vivify
 183                  * NI-S 1999/05/07
 184                  */
 185                 if (vivify_sv && sv != &PL_sv_undef) {
 186                     GV *gv;
 187                     if (SvREADONLY(sv))
 188                         Perl_croak_no_modify(aTHX);
 189                     if (cUNOP->op_targ) {
 190                         SV * const namesv = PAD_SV(cUNOP->op_targ);
 191                         gv = MUTABLE_GV(newSV(0));
 192                         gv_init_sv(gv, CopSTASH(PL_curcop), namesv, 0);
 193                     }
 194                     else {
 195                         const char * const name = CopSTASHPV(PL_curcop);
 196                         gv = newGVgen_flags(name,
 197                                         HvNAMEUTF8(CopSTASH(PL_curcop)) ? SVf_UTF8 : 0 );
 198                     }
 199                     prepare_SV_for_RV(sv);
 200                     SvRV_set(sv, MUTABLE_SV(gv));
 201                     SvROK_on(sv);
 202                     SvSETMAGIC(sv);
 203                     goto wasref;
 204                 }
 205                 if (PL_op->op_flags & OPf_REF || strict)
 206                     return (SV *)Perl_die(aTHX_ PL_no_usym, "a symbol");
 207                 if (ckWARN(WARN_UNINITIALIZED))
 208                     report_uninit(sv);
 209                 return &PL_sv_undef;
 210             }
 211             if (noinit)
 212             {
 213                 if (!(sv = MUTABLE_SV(gv_fetchsv_nomg(
 214                            sv, GV_ADDMG, SVt_PVGV
 215                    ))))
 216                     return &PL_sv_undef;
 217             }
 218             else {
 219                 if (strict)
 220                     return
 221                      (SV *)Perl_die(aTHX_
 222                             S_no_symref_sv,
 223                             sv,
 224                             (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""),
 225                             "a symbol"
 226                            );
 227                 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
 228                     == OPpDONT_INIT_GV) {
 229                     /* We are the target of a coderef assignment.  Return
 230                        the scalar unchanged, and let pp_sasssign deal with
 231                        things.  */
 232                     return sv;
 233                 }
 234                 sv = MUTABLE_SV(gv_fetchsv_nomg(sv, GV_ADD, SVt_PVGV));
 235             }
 236             /* FAKE globs in the symbol table cause weird bugs (#77810) */
 237             SvFAKE_off(sv);
 238         }
 239     }
 240     if (SvFAKE(sv) && !(PL_op->op_private & OPpALLOW_FAKE)) {
 241         SV *newsv = sv_newmortal();
 242         sv_setsv_flags(newsv, sv, 0);
 243         SvFAKE_off(newsv);
 244         sv = newsv;
 245     }
 246     return sv;
 247 }
 248
 249 PP(pp_rv2gv)
 250 {
 251     dVAR; dSP; dTOPss;
 252
 253     sv = S_rv2gv(aTHX_
 254           sv, PL_op->op_private & OPpDEREF,
 255           PL_op->op_private & HINT_STRICT_REFS,
 256           ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD))
 257              || PL_op->op_type == OP_READLINE
 258          );
 259     if (PL_op->op_private & OPpLVAL_INTRO)
 260         save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
 261     SETs(sv);
 262     RETURN;
 263 }
 264
 265 /* Helper function for pp_rv2sv and pp_rv2av  */
 266 GV *
 267 Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
 268                 const svtype type, SV ***spp)
 269 {
 270     dVAR;
 271     GV *gv;
 272
 273     PERL_ARGS_ASSERT_SOFTREF2XV;
 274
 275     if (PL_op->op_private & HINT_STRICT_REFS) {
 276         if (SvOK(sv))
 277             Perl_die(aTHX_ S_no_symref_sv, sv,
 278                      (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
 279         else
 280             Perl_die(aTHX_ PL_no_usym, what);
 281     }
 282     if (!SvOK(sv)) {
 283         if (
 284           PL_op->op_flags & OPf_REF &&
 285           PL_op->op_next->op_type != OP_BOOLKEYS
 286         )
 287             Perl_die(aTHX_ PL_no_usym, what);
 288         if (ckWARN(WARN_UNINITIALIZED))
 289             report_uninit(sv);
 290         if (type != SVt_PV && GIMME_V == G_ARRAY) {
 291             (*spp)--;
 292             return NULL;
 293         }
 294         **spp = &PL_sv_undef;
 295         return NULL;
 296     }
 297     if ((PL_op->op_flags & OPf_SPECIAL) &&
 298         !(PL_op->op_flags & OPf_MOD))
 299         {
 300             if (!(gv = gv_fetchsv_nomg(sv, GV_ADDMG, type)))
 301                 {
 302                     **spp = &PL_sv_undef;
 303                     return NULL;
 304                 }
 305         }
 306     else {
 307         gv = gv_fetchsv_nomg(sv, GV_ADD, type);
 308     }
 309     return gv;
 310 }
 311
 312 PP(pp_rv2sv)
 313 {
 314     dVAR; dSP; dTOPss;
 315     GV *gv = NULL;
 316
 317     SvGETMAGIC(sv);
 318     if (SvROK(sv)) {
 319         if (SvAMAGIC(sv)) {
 320             sv = amagic_deref_call(sv, to_sv_amg);
 321         }
 322
 323         sv = SvRV(sv);
 324         switch (SvTYPE(sv)) {
 325         case SVt_PVAV:
 326         case SVt_PVHV:
 327         case SVt_PVCV:
 328         case SVt_PVFM:
 329         case SVt_PVIO:
 330             DIE(aTHX_ "Not a SCALAR reference");
 331         default: NOOP;
 332         }
 333     }
 334     else {
 335         gv = MUTABLE_GV(sv);
 336
 337         if (!isGV_with_GP(gv)) {
 338             gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
 339             if (!gv)
 340                 RETURN;
 341         }
 342         sv = GvSVn(gv);
 343     }
 344     if (PL_op->op_flags & OPf_MOD) {
 345         if (PL_op->op_private & OPpLVAL_INTRO) {
 346             if (cUNOP->op_first->op_type == OP_NULL)
 347                 sv = save_scalar(MUTABLE_GV(TOPs));
 348             else if (gv)
 349                 sv = save_scalar(gv);
 350             else
 351                 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
 352         }
 353         else if (PL_op->op_private & OPpDEREF)
 354             sv = vivify_ref(sv, PL_op->op_private & OPpDEREF);
 355     }
 356     SETs(sv);
 357     RETURN;
 358 }
 359
 360 PP(pp_av2arylen)
 361 {
 362     dVAR; dSP;
 363     AV * const av = MUTABLE_AV(TOPs);
 364     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
 365     if (lvalue) {
 366         SV ** const sv = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
 367         if (!*sv) {
 368             *sv = newSV_type(SVt_PVMG);
 369             sv_magic(*sv, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
 370         }
 371         SETs(*sv);
 372     } else {
 373         SETs(sv_2mortal(newSViv(AvFILL(MUTABLE_AV(av)))));
 374     }
 375     RETURN;
 376 }
 377
 378 PP(pp_pos)
 379 {
 380     dVAR; dSP; dPOPss;
 381
 382     if (PL_op->op_flags & OPf_MOD || LVRET) {
 383         SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
 384         sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
 385         LvTYPE(ret) = '.';
 386         LvTARG(ret) = SvREFCNT_inc_simple(sv);
 387         PUSHs(ret);    /* no SvSETMAGIC */
 388         RETURN;
 389     }
 390     else {
 391         if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
 392             const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
 393             if (mg && mg->mg_len >= 0) {
 394                 dTARGET;
 395                 I32 i = mg->mg_len;
 396                 if (DO_UTF8(sv))
 397                     sv_pos_b2u(sv, &i);
 398                 PUSHi(i);
 399                 RETURN;
 400             }
 401         }
 402         RETPUSHUNDEF;
 403     }
 404 }
 405
 406 PP(pp_rv2cv)
 407 {
 408     dVAR; dSP;
 409     GV *gv;
 410     HV *stash_unused;
 411     const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
 412         ? GV_ADDMG
 413         : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT)) == OPpMAY_RETURN_CONSTANT)
 414             ? GV_ADD|GV_NOEXPAND
 415             : GV_ADD;
 416     /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
 417     /* (But not in defined().) */
 418
 419     CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
 420     if (cv) NOOP;
 421     else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
 422         cv = MUTABLE_CV(gv);
 423     }
 424     else
 425         cv = MUTABLE_CV(&PL_sv_undef);
 426     SETs(MUTABLE_SV(cv));
 427     RETURN;
 428 }
 429
 430 PP(pp_prototype)
 431 {
 432     dVAR; dSP;
 433     CV *cv;
 434     HV *stash;
 435     GV *gv;
 436     SV *ret = &PL_sv_undef;
 437
 438     if (SvGMAGICAL(TOPs)) SETs(sv_mortalcopy(TOPs));
 439     if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
 440         const char * s = SvPVX_const(TOPs);
 441         if (strnEQ(s, "CORE::", 6)) {
 442             const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
 443             if (!code || code == -KEY_CORE)
 444                 DIE(aTHX_ "Can't find an opnumber for \"%"SVf"\"",
 445                     SVfARG(newSVpvn_flags(
 446                         s+6, SvCUR(TOPs)-6, SvFLAGS(TOPs) & SVf_UTF8
 447                     )));
 448             {
 449                 SV * const sv = core_prototype(NULL, s + 6, code, NULL);
 450                 if (sv) ret = sv;
 451             }
 452             goto set;
 453         }
 454     }
 455     cv = sv_2cv(TOPs, &stash, &gv, 0);
 456     if (cv && SvPOK(cv))
 457         ret = newSVpvn_flags(
 458             CvPROTO(cv), CvPROTOLEN(cv), SVs_TEMP | SvUTF8(cv)
 459         );
 460   set:
 461     SETs(ret);
 462     RETURN;
 463 }
 464
 465 PP(pp_anoncode)
 466 {
 467     dVAR; dSP;
 468     CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
 469     if (CvCLONE(cv))
 470         cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
 471     EXTEND(SP,1);
 472     PUSHs(MUTABLE_SV(cv));
 473     RETURN;
 474 }
 475
 476 PP(pp_srefgen)
 477 {
 478     dVAR; dSP;
 479     *SP = refto(*SP);
 480     RETURN;
 481 }
 482
 483 PP(pp_refgen)
 484 {
 485     dVAR; dSP; dMARK;
 486     if (GIMME != G_ARRAY) {
 487         if (++MARK <= SP)
 488             *MARK = *SP;
 489         else
 490             *MARK = &PL_sv_undef;
 491         *MARK = refto(*MARK);
 492         SP = MARK;
 493         RETURN;
 494     }
 495     EXTEND_MORTAL(SP - MARK);
 496     while (++MARK <= SP)
 497         *MARK = refto(*MARK);
 498     RETURN;
 499 }
 500
 501 STATIC SV*
 502 S_refto(pTHX_ SV *sv)
 503 {
 504     dVAR;
 505     SV* rv;
 506
 507     PERL_ARGS_ASSERT_REFTO;
 508
 509     if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
 510         if (LvTARGLEN(sv))
 511             vivify_defelem(sv);
 512         if (!(sv = LvTARG(sv)))
 513             sv = &PL_sv_undef;
 514         else
 515             SvREFCNT_inc_void_NN(sv);
 516     }
 517     else if (SvTYPE(sv) == SVt_PVAV) {
 518         if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
 519             av_reify(MUTABLE_AV(sv));
 520         SvTEMP_off(sv);
 521         SvREFCNT_inc_void_NN(sv);
 522     }
 523     else if (SvPADTMP(sv) && !IS_PADGV(sv))
 524         sv = newSVsv(sv);
 525     else {
 526         SvTEMP_off(sv);
 527         SvREFCNT_inc_void_NN(sv);
 528     }
 529     rv = sv_newmortal();
 530     sv_upgrade(rv, SVt_IV);
 531     SvRV_set(rv, sv);
 532     SvROK_on(rv);
 533     return rv;
 534 }
 535
 536 PP(pp_ref)
 537 {
 538     dVAR; dSP; dTARGET;
 539     SV * const sv = POPs;
 540
 541     if (sv)
 542         SvGETMAGIC(sv);
 543
 544     if (!sv || !SvROK(sv))
 545         RETPUSHNO;
 546
 547     (void)sv_ref(TARG,SvRV(sv),TRUE);
 548     PUSHTARG;
 549     RETURN;
 550 }
 551
 552 PP(pp_bless)
 553 {
 554     dVAR; dSP;
 555     HV *stash;
 556
 557     if (MAXARG == 1)
 558       curstash:
 559         stash = CopSTASH(PL_curcop);
 560     else {
 561         SV * const ssv = POPs;
 562         STRLEN len;
 563         const char *ptr;
 564
 565         if (!ssv) goto curstash;
 566         if (!SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
 567             Perl_croak(aTHX_ "Attempt to bless into a reference");
 568         ptr = SvPV_const(ssv,len);
 569         if (len == 0)
 570             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
 571                            "Explicit blessing to '' (assuming package main)");
 572         stash = gv_stashpvn(ptr, len, GV_ADD|SvUTF8(ssv));
 573     }
 574
 575     (void)sv_bless(TOPs, stash);
 576     RETURN;
 577 }
 578
 579 PP(pp_gelem)
 580 {
 581     dVAR; dSP;
 582
 583     SV *sv = POPs;
 584     STRLEN len;
 585     const char * const elem = SvPV_const(sv, len);
 586     GV * const gv = MUTABLE_GV(POPs);
 587     SV * tmpRef = NULL;
 588
 589     sv = NULL;
 590     if (elem) {
 591         /* elem will always be NUL terminated.  */
 592         const char * const second_letter = elem + 1;
 593         switch (*elem) {
 594         case 'A':
 595             if (len == 5 && strEQ(second_letter, "RRAY"))
 596                 tmpRef = MUTABLE_SV(GvAV(gv));
 597             break;
 598         case 'C':
 599             if (len == 4 && strEQ(second_letter, "ODE"))
 600                 tmpRef = MUTABLE_SV(GvCVu(gv));
 601             break;
 602         case 'F':
 603             if (len == 10 && strEQ(second_letter, "ILEHANDLE")) {
 604                 /* finally deprecated in 5.8.0 */
 605                 deprecate("*glob{FILEHANDLE}");
 606                 tmpRef = MUTABLE_SV(GvIOp(gv));
 607             }
 608             else
 609                 if (len == 6 && strEQ(second_letter, "ORMAT"))
 610                     tmpRef = MUTABLE_SV(GvFORM(gv));
 611             break;
 612         case 'G':
 613             if (len == 4 && strEQ(second_letter, "LOB"))
 614                 tmpRef = MUTABLE_SV(gv);
 615             break;
 616         case 'H':
 617             if (len == 4 && strEQ(second_letter, "ASH"))
 618                 tmpRef = MUTABLE_SV(GvHV(gv));
 619             break;
 620         case 'I':
 621             if (*second_letter == 'O' && !elem[2] && len == 2)
 622                 tmpRef = MUTABLE_SV(GvIOp(gv));
 623             break;
 624         case 'N':
 625             if (len == 4 && strEQ(second_letter, "AME"))
 626                 sv = newSVhek(GvNAME_HEK(gv));
 627             break;
 628         case 'P':
 629             if (len == 7 && strEQ(second_letter, "ACKAGE")) {
 630                 const HV * const stash = GvSTASH(gv);
 631                 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
 632                 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
 633             }
 634             break;
 635         case 'S':
 636             if (len == 6 && strEQ(second_letter, "CALAR"))
 637                 tmpRef = GvSVn(gv);
 638             break;
 639         }
 640     }
 641     if (tmpRef)
 642         sv = newRV(tmpRef);
 643     if (sv)
 644         sv_2mortal(sv);
 645     else
 646         sv = &PL_sv_undef;
 647     XPUSHs(sv);
 648     RETURN;
 649 }
 650
 651 /* Pattern matching */
 652
 653 PP(pp_study)
 654 {
 655     dVAR; dSP; dPOPss;
 656     STRLEN len;
 657
 658     (void)SvPV(sv, len);
 659     if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) {
 660         /* Historically, study was skipped in these cases. */
 661         RETPUSHNO;
 662     }
 663
 664     /* Make study a no-op. It's no longer useful and its existence
 665        complicates matters elsewhere. */
 666     RETPUSHYES;
 667 }
 668
 669 PP(pp_trans)
 670 {
 671     dVAR; dSP; dTARG;
 672     SV *sv;
 673
 674     if (PL_op->op_flags & OPf_STACKED)
 675         sv = POPs;
 676     else if (PL_op->op_private & OPpTARGET_MY)
 677         sv = GETTARGET;
 678     else {
 679         sv = DEFSV;
 680         EXTEND(SP,1);
 681     }
 682     if(PL_op->op_type == OP_TRANSR) {
 683         STRLEN len;
 684         const char * const pv = SvPV(sv,len);
 685         SV * const newsv = newSVpvn_flags(pv, len, SVs_TEMP|SvUTF8(sv));
 686         do_trans(newsv);
 687         PUSHs(newsv);
 688     }
 689     else {
 690         TARG = sv_newmortal();
 691         PUSHi(do_trans(sv));
 692     }
 693     RETURN;
 694 }
 695
 696 /* Lvalue operators. */
 697
 698 static void
 699 S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
 700 {
 701     dVAR;
 702     STRLEN len;
 703     char *s;
 704
 705     PERL_ARGS_ASSERT_DO_CHOMP;
 706
 707     if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
 708         return;
 709     if (SvTYPE(sv) == SVt_PVAV) {
 710         I32 i;
 711         AV *const av = MUTABLE_AV(sv);
 712         const I32 max = AvFILL(av);
 713
 714         for (i = 0; i <= max; i++) {
 715             sv = MUTABLE_SV(av_fetch(av, i, FALSE));
 716             if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
 717                 do_chomp(retval, sv, chomping);
 718         }
 719         return;
 720     }
 721     else if (SvTYPE(sv) == SVt_PVHV) {
 722         HV* const hv = MUTABLE_HV(sv);
 723         HE* entry;
 724         (void)hv_iterinit(hv);
 725         while ((entry = hv_iternext(hv)))
 726             do_chomp(retval, hv_iterval(hv,entry), chomping);
 727         return;
 728     }
 729     else if (SvREADONLY(sv)) {
 730         if (SvFAKE(sv)) {
 731             /* SV is copy-on-write */
 732             sv_force_normal_flags(sv, 0);
 733         }
 734         else
 735             Perl_croak_no_modify(aTHX);
 736     }
 737
 738     if (PL_encoding) {
 739         if (!SvUTF8(sv)) {
 740             /* XXX, here sv is utf8-ized as a side-effect!
 741                If encoding.pm is used properly, almost string-generating
 742                operations, including literal strings, chr(), input data, etc.
 743                should have been utf8-ized already, right?
 744             */
 745             sv_recode_to_utf8(sv, PL_encoding);
 746         }
 747     }
 748
 749     s = SvPV(sv, len);
 750     if (chomping) {
 751         char *temp_buffer = NULL;
 752         SV *svrecode = NULL;
 753
 754         if (s && len) {
 755             s += --len;
 756             if (RsPARA(PL_rs)) {
 757                 if (*s != '\n')
 758                     goto nope;
 759                 ++SvIVX(retval);
 760                 while (len && s[-1] == '\n') {
 761                     --len;
 762                     --s;
 763                     ++SvIVX(retval);
 764                 }
 765             }
 766             else {
 767                 STRLEN rslen, rs_charlen;
 768                 const char *rsptr = SvPV_const(PL_rs, rslen);
 769
 770                 rs_charlen = SvUTF8(PL_rs)
 771                     ? sv_len_utf8(PL_rs)
 772                     : rslen;
 773
 774                 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
 775                     /* Assumption is that rs is shorter than the scalar.  */
 776                     if (SvUTF8(PL_rs)) {
 777                         /* RS is utf8, scalar is 8 bit.  */
 778                         bool is_utf8 = TRUE;
 779                         temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
 780                                                              &rslen, &is_utf8);
 781                         if (is_utf8) {
 782                             /* Cannot downgrade, therefore cannot possibly match
 783                              */
 784                             assert (temp_buffer == rsptr);
 785                             temp_buffer = NULL;
 786                             goto nope;
 787                         }
 788                         rsptr = temp_buffer;
 789                     }
 790                     else if (PL_encoding) {
 791                         /* RS is 8 bit, encoding.pm is used.
 792                          * Do not recode PL_rs as a side-effect. */
 793                         svrecode = newSVpvn(rsptr, rslen);
 794                         sv_recode_to_utf8(svrecode, PL_encoding);
 795                         rsptr = SvPV_const(svrecode, rslen);
 796                         rs_charlen = sv_len_utf8(svrecode);
 797                     }
 798                     else {
 799                         /* RS is 8 bit, scalar is utf8.  */
 800                         temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
 801                         rsptr = temp_buffer;
 802                     }
 803                 }
 804                 if (rslen == 1) {
 805                     if (*s != *rsptr)
 806                         goto nope;
 807                     ++SvIVX(retval);
 808                 }
 809                 else {
 810                     if (len < rslen - 1)
 811                         goto nope;
 812                     len -= rslen - 1;
 813                     s -= rslen - 1;
 814                     if (memNE(s, rsptr, rslen))
 815                         goto nope;
 816                     SvIVX(retval) += rs_charlen;
 817                 }
 818             }
 819             s = SvPV_force_nomg_nolen(sv);
 820             SvCUR_set(sv, len);
 821             *SvEND(sv) = '\0';
 822             SvNIOK_off(sv);
 823             SvSETMAGIC(sv);
 824         }
 825     nope:
 826
 827         SvREFCNT_dec(svrecode);
 828
 829         Safefree(temp_buffer);
 830     } else {
 831         if (len && !SvPOK(sv))
 832             s = SvPV_force_nomg(sv, len);
 833         if (DO_UTF8(sv)) {
 834             if (s && len) {
 835                 char * const send = s + len;
 836                 char * const start = s;
 837                 s = send - 1;
 838                 while (s > start && UTF8_IS_CONTINUATION(*s))
 839                     s--;
 840                 if (is_utf8_string((U8*)s, send - s)) {
 841                     sv_setpvn(retval, s, send - s);
 842                     *s = '\0';
 843                     SvCUR_set(sv, s - start);
 844                     SvNIOK_off(sv);
 845                     SvUTF8_on(retval);
 846                 }
 847             }
 848             else
 849                 sv_setpvs(retval, "");
 850         }
 851         else if (s && len) {
 852             s += --len;
 853             sv_setpvn(retval, s, 1);
 854             *s = '\0';
 855             SvCUR_set(sv, len);
 856             SvUTF8_off(sv);
 857             SvNIOK_off(sv);
 858         }
 859         else
 860             sv_setpvs(retval, "");
 861         SvSETMAGIC(sv);
 862     }
 863 }
 864
 865 PP(pp_schop)
 866 {
 867     dVAR; dSP; dTARGET;
 868     const bool chomping = PL_op->op_type == OP_SCHOMP;
 869
 870     if (chomping)
 871         sv_setiv(TARG, 0);
 872     do_chomp(TARG, TOPs, chomping);
 873     SETTARG;
 874     RETURN;
 875 }
 876
 877 PP(pp_chop)
 878 {
 879     dVAR; dSP; dMARK; dTARGET; dORIGMARK;
 880     const bool chomping = PL_op->op_type == OP_CHOMP;
 881
 882     if (chomping)
 883         sv_setiv(TARG, 0);
 884     while (MARK < SP)
 885         do_chomp(TARG, *++MARK, chomping);
 886     SP = ORIGMARK;
 887     XPUSHTARG;
 888     RETURN;
 889 }
 890
 891 PP(pp_undef)
 892 {
 893     dVAR; dSP;
 894     SV *sv;
 895
 896     if (!PL_op->op_private) {
 897         EXTEND(SP, 1);
 898         RETPUSHUNDEF;
 899     }
 900
 901     sv = POPs;
 902     if (!sv)
 903         RETPUSHUNDEF;
 904
 905     SV_CHECK_THINKFIRST_COW_DROP(sv);
 906
 907     switch (SvTYPE(sv)) {
 908     case SVt_NULL:
 909         break;
 910     case SVt_PVAV:
 911         av_undef(MUTABLE_AV(sv));
 912         break;
 913     case SVt_PVHV:
 914         hv_undef(MUTABLE_HV(sv));
 915         break;
 916     case SVt_PVCV:
 917         if (cv_const_sv((const CV *)sv))
 918             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
 919                           "Constant subroutine %"SVf" undefined",
 920                            SVfARG(CvANON((const CV *)sv)
 921                              ? newSVpvs_flags("(anonymous)", SVs_TEMP)
 922                              : sv_2mortal(newSVhek(GvENAME_HEK(CvGV((const CV *)sv))))));
 923         /* FALLTHROUGH */
 924     case SVt_PVFM:
 925         {
 926             /* let user-undef'd sub keep its identity */
 927             GV* const gv = CvGV((const CV *)sv);
 928             cv_undef(MUTABLE_CV(sv));
 929             CvGV_set(MUTABLE_CV(sv), gv);
 930         }
 931         break;
 932     case SVt_PVGV:
 933         if (SvFAKE(sv)) {
 934             SvSetMagicSV(sv, &PL_sv_undef);
 935             break;
 936         }
 937         else if (isGV_with_GP(sv)) {
 938             GP *gp;
 939             HV *stash;
 940
 941             /* undef *Pkg::meth_name ... */
 942             bool method_changed
 943              =   GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
 944               && HvENAME_get(stash);
 945             /* undef *Foo:: */
 946             if((stash = GvHV((const GV *)sv))) {
 947                 if(HvENAME_get(stash))
 948                     SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
 949                 else stash = NULL;
 950             }
 951
 952             gp_free(MUTABLE_GV(sv));
 953             Newxz(gp, 1, GP);
 954             GvGP_set(sv, gp_ref(gp));
 955             GvSV(sv) = newSV(0);
 956             GvLINE(sv) = CopLINE(PL_curcop);
 957             GvEGV(sv) = MUTABLE_GV(sv);
 958             GvMULTI_on(sv);
 959
 960             if(stash)
 961                 mro_package_moved(NULL, stash, (const GV *)sv, 0);
 962             stash = NULL;
 963             /* undef *Foo::ISA */
 964             if( strEQ(GvNAME((const GV *)sv), "ISA")
 965              && (stash = GvSTASH((const GV *)sv))
 966              && (method_changed || HvENAME(stash)) )
 967                 mro_isa_changed_in(stash);
 968             else if(method_changed)
 969                 mro_method_changed_in(
 970                  GvSTASH((const GV *)sv)
 971                 );
 972
 973             break;
 974         }
 975         /* FALL THROUGH */
 976     default:
 977         if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
 978             SvPV_free(sv);
 979             SvPV_set(sv, NULL);
 980             SvLEN_set(sv, 0);
 981         }
 982         SvOK_off(sv);
 983         SvSETMAGIC(sv);
 984     }
 985
 986     RETPUSHUNDEF;
 987 }
 988
 989 PP(pp_postinc)
 990 {
 991     dVAR; dSP; dTARGET;
 992     const bool inc =
 993         PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC;
 994     if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))
 995         Perl_croak_no_modify(aTHX);
 996     if (SvROK(TOPs))
 997         TARG = sv_newmortal();
 998     sv_setsv(TARG, TOPs);
 999     if (!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
1000         && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
1001     {
1002         SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
1003         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
1004     }
1005     else if (inc)
1006         sv_inc_nomg(TOPs);
1007     else sv_dec_nomg(TOPs);
1008     SvSETMAGIC(TOPs);
1009     /* special case for undef: see thread at 2003-03/msg00536.html in archive */
1010     if (inc && !SvOK(TARG))
1011         sv_setiv(TARG, 0);
1012     SETs(TARG);
1013     return NORMAL;
1014 }
1015
1016 /* Ordinary operators. */
1017
1018 PP(pp_pow)
1019 {
1020     dVAR; dSP; dATARGET; SV *svl, *svr;
1021 #ifdef PERL_PRESERVE_IVUV
1022     bool is_int = 0;
1023 #endif
1024     tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
1025     svr = TOPs;
1026     svl = TOPm1s;
1027 #ifdef PERL_PRESERVE_IVUV
1028     /* For integer to integer power, we do the calculation by hand wherever
1029        we're sure it is safe; otherwise we call pow() and try to convert to
1030        integer afterwards. */
1031     if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1032                 UV power;
1033                 bool baseuok;
1034                 UV baseuv;
1035
1036                 if (SvUOK(svr)) {
1037                     power = SvUVX(svr);
1038                 } else {
1039                     const IV iv = SvIVX(svr);
1040                     if (iv >= 0) {
1041                         power = iv;
1042                     } else {
1043                         goto float_it; /* Can't do negative powers this way.  */
1044                     }
1045                 }
1046
1047                 baseuok = SvUOK(svl);
1048                 if (baseuok) {
1049                     baseuv = SvUVX(svl);
1050                 } else {
1051                     const IV iv = SvIVX(svl);
1052                     if (iv >= 0) {
1053                         baseuv = iv;
1054                         baseuok = TRUE; /* effectively it's a UV now */
1055                     } else {
1056                         baseuv = -iv; /* abs, baseuok == false records sign */
1057                     }
1058                 }
1059                 /* now we have integer ** positive integer. */
1060                 is_int = 1;
1061
1062                 /* foo & (foo - 1) is zero only for a power of 2.  */
1063                 if (!(baseuv & (baseuv - 1))) {
1064                     /* We are raising power-of-2 to a positive integer.
1065                        The logic here will work for any base (even non-integer
1066                        bases) but it can be less accurate than
1067                        pow (base,power) or exp (power * log (base)) when the
1068                        intermediate values start to spill out of the mantissa.
1069                        With powers of 2 we know this can't happen.
1070                        And powers of 2 are the favourite thing for perl
1071                        programmers to notice ** not doing what they mean. */
1072                     NV result = 1.0;
1073                     NV base = baseuok ? baseuv : -(NV)baseuv;
1074
1075                     if (power & 1) {
1076                         result *= base;
1077                     }
1078                     while (power >>= 1) {
1079                         base *= base;
1080                         if (power & 1) {
1081                             result *= base;
1082                         }
1083                     }
1084                     SP--;
1085                     SETn( result );
1086                     SvIV_please_nomg(svr);
1087                     RETURN;
1088                 } else {
1089                     unsigned int highbit = 8 * sizeof(UV);
1090                     unsigned int diff = 8 * sizeof(UV);
1091                     while (diff >>= 1) {
1092                         highbit -= diff;
1093                         if (baseuv >> highbit) {
1094                             highbit += diff;
1095                         }
1096                     }
1097                     /* we now have baseuv < 2 ** highbit */
1098                     if (power * highbit <= 8 * sizeof(UV)) {
1099                         /* result will definitely fit in UV, so use UV math
1100                            on same algorithm as above */
1101                         UV result = 1;
1102                         UV base = baseuv;
1103                         const bool odd_power = cBOOL(power & 1);
1104                         if (odd_power) {
1105                             result *= base;
1106                         }
1107                         while (power >>= 1) {
1108                             base *= base;
1109                             if (power & 1) {
1110                                 result *= base;
1111                             }
1112                         }
1113                         SP--;
1114                         if (baseuok || !odd_power)
1115                             /* answer is positive */
1116                             SETu( result );
1117                         else if (result <= (UV)IV_MAX)
1118                             /* answer negative, fits in IV */
1119                             SETi( -(IV)result );
1120                         else if (result == (UV)IV_MIN)
1121                             /* 2's complement assumption: special case IV_MIN */
1122                             SETi( IV_MIN );
1123                         else
1124                             /* answer negative, doesn't fit */
1125                             SETn( -(NV)result );
1126                         RETURN;
1127                     }
1128                 }
1129     }
1130   float_it:
1131 #endif
1132     {
1133         NV right = SvNV_nomg(svr);
1134         NV left  = SvNV_nomg(svl);
1135         (void)POPs;
1136
1137 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1138     /*
1139     We are building perl with long double support and are on an AIX OS
1140     afflicted with a powl() function that wrongly returns NaNQ for any
1141     negative base.  This was reported to IBM as PMR #23047-379 on
1142     03/06/2006.  The problem exists in at least the following versions
1143     of AIX and the libm fileset, and no doubt others as well:
1144
1145         AIX 4.3.3-ML10      bos.adt.libm 4.3.3.50
1146         AIX 5.1.0-ML04      bos.adt.libm 5.1.0.29
1147         AIX 5.2.0           bos.adt.libm 5.2.0.85
1148
1149     So, until IBM fixes powl(), we provide the following workaround to
1150     handle the problem ourselves.  Our logic is as follows: for
1151     negative bases (left), we use fmod(right, 2) to check if the
1152     exponent is an odd or even integer:
1153
1154         - if odd,  powl(left, right) == -powl(-left, right)
1155         - if even, powl(left, right) ==  powl(-left, right)
1156
1157     If the exponent is not an integer, the result is rightly NaNQ, so
1158     we just return that (as NV_NAN).
1159     */
1160
1161         if (left < 0.0) {
1162             NV mod2 = Perl_fmod( right, 2.0 );
1163             if (mod2 == 1.0 || mod2 == -1.0) {  /* odd integer */
1164                 SETn( -Perl_pow( -left, right) );
1165             } else if (mod2 == 0.0) {           /* even integer */
1166                 SETn( Perl_pow( -left, right) );
1167             } else {                            /* fractional power */
1168                 SETn( NV_NAN );
1169             }
1170         } else {
1171             SETn( Perl_pow( left, right) );
1172         }
1173 #else
1174         SETn( Perl_pow( left, right) );
1175 #endif  /* HAS_AIX_POWL_NEG_BASE_BUG */
1176
1177 #ifdef PERL_PRESERVE_IVUV
1178         if (is_int)
1179             SvIV_please_nomg(svr);
1180 #endif
1181         RETURN;
1182     }
1183 }
1184
1185 PP(pp_multiply)
1186 {
1187     dVAR; dSP; dATARGET; SV *svl, *svr;
1188     tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1189     svr = TOPs;
1190     svl = TOPm1s;
1191 #ifdef PERL_PRESERVE_IVUV
1192     if (SvIV_please_nomg(svr)) {
1193         /* Unless the left argument is integer in range we are going to have to
1194            use NV maths. Hence only attempt to coerce the right argument if
1195            we know the left is integer.  */
1196         /* Left operand is defined, so is it IV? */
1197         if (SvIV_please_nomg(svl)) {
1198             bool auvok = SvUOK(svl);
1199             bool buvok = SvUOK(svr);
1200             const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1201             const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1202             UV alow;
1203             UV ahigh;
1204             UV blow;
1205             UV bhigh;
1206
1207             if (auvok) {
1208                 alow = SvUVX(svl);
1209             } else {
1210                 const IV aiv = SvIVX(svl);
1211                 if (aiv >= 0) {
1212                     alow = aiv;
1213                     auvok = TRUE; /* effectively it's a UV now */
1214                 } else {
1215                     alow = -aiv; /* abs, auvok == false records sign */
1216                 }
1217             }
1218             if (buvok) {
1219                 blow = SvUVX(svr);
1220             } else {
1221                 const IV biv = SvIVX(svr);
1222                 if (biv >= 0) {
1223                     blow = biv;
1224                     buvok = TRUE; /* effectively it's a UV now */
1225                 } else {
1226                     blow = -biv; /* abs, buvok == false records sign */
1227                 }
1228             }
1229
1230             /* If this does sign extension on unsigned it's time for plan B  */
1231             ahigh = alow >> (4 * sizeof (UV));
1232             alow &= botmask;
1233             bhigh = blow >> (4 * sizeof (UV));
1234             blow &= botmask;
1235             if (ahigh && bhigh) {
1236                 NOOP;
1237                 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1238                    which is overflow. Drop to NVs below.  */
1239             } else if (!ahigh && !bhigh) {
1240                 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1241                    so the unsigned multiply cannot overflow.  */
1242                 const UV product = alow * blow;
1243                 if (auvok == buvok) {
1244                     /* -ve * -ve or +ve * +ve gives a +ve result.  */
1245                     SP--;
1246                     SETu( product );
1247                     RETURN;
1248                 } else if (product <= (UV)IV_MIN) {
1249                     /* 2s complement assumption that (UV)-IV_MIN is correct.  */
1250                     /* -ve result, which could overflow an IV  */
1251                     SP--;
1252                     SETi( -(IV)product );
1253                     RETURN;
1254                 } /* else drop to NVs below. */
1255             } else {
1256                 /* One operand is large, 1 small */
1257                 UV product_middle;
1258                 if (bhigh) {
1259                     /* swap the operands */
1260                     ahigh = bhigh;
1261                     bhigh = blow; /* bhigh now the temp var for the swap */
1262                     blow = alow;
1263                     alow = bhigh;
1264                 }
1265                 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1266                    multiplies can't overflow. shift can, add can, -ve can.  */
1267                 product_middle = ahigh * blow;
1268                 if (!(product_middle & topmask)) {
1269                     /* OK, (ahigh * blow) won't lose bits when we shift it.  */
1270                     UV product_low;
1271                     product_middle <<= (4 * sizeof (UV));
1272                     product_low = alow * blow;
1273
1274                     /* as for pp_add, UV + something mustn't get smaller.
1275                        IIRC ANSI mandates this wrapping *behaviour* for
1276                        unsigned whatever the actual representation*/
1277                     product_low += product_middle;
1278                     if (product_low >= product_middle) {
1279                         /* didn't overflow */
1280                         if (auvok == buvok) {
1281                             /* -ve * -ve or +ve * +ve gives a +ve result.  */
1282                             SP--;
1283                             SETu( product_low );
1284                             RETURN;
1285                         } else if (product_low <= (UV)IV_MIN) {
1286                             /* 2s complement assumption again  */
1287                             /* -ve result, which could overflow an IV  */
1288                             SP--;
1289                             SETi( -(IV)product_low );
1290                             RETURN;
1291                         } /* else drop to NVs below. */
1292                     }
1293                 } /* product_middle too large */
1294             } /* ahigh && bhigh */
1295         } /* SvIOK(svl) */
1296     } /* SvIOK(svr) */
1297 #endif
1298     {
1299       NV right = SvNV_nomg(svr);
1300       NV left  = SvNV_nomg(svl);
1301       (void)POPs;
1302       SETn( left * right );
1303       RETURN;
1304     }
1305 }
1306
1307 PP(pp_divide)
1308 {
1309     dVAR; dSP; dATARGET; SV *svl, *svr;
1310     tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1311     svr = TOPs;
1312     svl = TOPm1s;
1313     /* Only try to do UV divide first
1314        if ((SLOPPYDIVIDE is true) or
1315            (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1316             to preserve))
1317        The assumption is that it is better to use floating point divide
1318        whenever possible, only doing integer divide first if we can't be sure.
1319        If NV_PRESERVES_UV is true then we know at compile time that no UV
1320        can be too large to preserve, so don't need to compile the code to
1321        test the size of UVs.  */
1322
1323 #ifdef SLOPPYDIVIDE
1324 #  define PERL_TRY_UV_DIVIDE
1325     /* ensure that 20./5. == 4. */
1326 #else
1327 #  ifdef PERL_PRESERVE_IVUV
1328 #    ifndef NV_PRESERVES_UV
1329 #      define PERL_TRY_UV_DIVIDE
1330 #    endif
1331 #  endif
1332 #endif
1333
1334 #ifdef PERL_TRY_UV_DIVIDE
1335     if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1336             bool left_non_neg = SvUOK(svl);
1337             bool right_non_neg = SvUOK(svr);
1338             UV left;
1339             UV right;
1340
1341             if (right_non_neg) {
1342                 right = SvUVX(svr);
1343             }
1344             else {
1345                 const IV biv = SvIVX(svr);
1346                 if (biv >= 0) {
1347                     right = biv;
1348                     right_non_neg = TRUE; /* effectively it's a UV now */
1349                 }
1350                 else {
1351                     right = -biv;
1352                 }
1353             }
1354             /* historically undef()/0 gives a "Use of uninitialized value"
1355                warning before dieing, hence this test goes here.
1356                If it were immediately before the second SvIV_please, then
1357                DIE() would be invoked before left was even inspected, so
1358                no inspection would give no warning.  */
1359             if (right == 0)
1360                 DIE(aTHX_ "Illegal division by zero");
1361
1362             if (left_non_neg) {
1363                 left = SvUVX(svl);
1364             }
1365             else {
1366                 const IV aiv = SvIVX(svl);
1367                 if (aiv >= 0) {
1368                     left = aiv;
1369                     left_non_neg = TRUE; /* effectively it's a UV now */
1370                 }
1371                 else {
1372                     left = -aiv;
1373                 }
1374             }
1375
1376             if (left >= right
1377 #ifdef SLOPPYDIVIDE
1378                 /* For sloppy divide we always attempt integer division.  */
1379 #else
1380                 /* Otherwise we only attempt it if either or both operands
1381                    would not be preserved by an NV.  If both fit in NVs
1382                    we fall through to the NV divide code below.  However,
1383                    as left >= right to ensure integer result here, we know that
1384                    we can skip the test on the right operand - right big
1385                    enough not to be preserved can't get here unless left is
1386                    also too big.  */
1387
1388                 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1389 #endif
1390                 ) {
1391                 /* Integer division can't overflow, but it can be imprecise.  */
1392                 const UV result = left / right;
1393                 if (result * right == left) {
1394                     SP--; /* result is valid */
1395                     if (left_non_neg == right_non_neg) {
1396                         /* signs identical, result is positive.  */
1397                         SETu( result );
1398                         RETURN;
1399                     }
1400                     /* 2s complement assumption */
1401                     if (result <= (UV)IV_MIN)
1402                         SETi( -(IV)result );
1403                     else {
1404                         /* It's exact but too negative for IV. */
1405                         SETn( -(NV)result );
1406                     }
1407                     RETURN;
1408                 } /* tried integer divide but it was not an integer result */
1409             } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1410     } /* one operand wasn't SvIOK */
1411 #endif /* PERL_TRY_UV_DIVIDE */
1412     {
1413         NV right = SvNV_nomg(svr);
1414         NV left  = SvNV_nomg(svl);
1415         (void)POPs;(void)POPs;
1416 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1417         if (! Perl_isnan(right) && right == 0.0)
1418 #else
1419         if (right == 0.0)
1420 #endif
1421             DIE(aTHX_ "Illegal division by zero");
1422         PUSHn( left / right );
1423         RETURN;
1424     }
1425 }
1426
1427 PP(pp_modulo)
1428 {
1429     dVAR; dSP; dATARGET;
1430     tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
1431     {
1432         UV left  = 0;
1433         UV right = 0;
1434         bool left_neg = FALSE;
1435         bool right_neg = FALSE;
1436         bool use_double = FALSE;
1437         bool dright_valid = FALSE;
1438         NV dright = 0.0;
1439         NV dleft  = 0.0;
1440         SV * const svr = TOPs;
1441         SV * const svl = TOPm1s;
1442         if (SvIV_please_nomg(svr)) {
1443             right_neg = !SvUOK(svr);
1444             if (!right_neg) {
1445                 right = SvUVX(svr);
1446             } else {
1447                 const IV biv = SvIVX(svr);
1448                 if (biv >= 0) {
1449                     right = biv;
1450                     right_neg = FALSE; /* effectively it's a UV now */
1451                 } else {
1452                     right = -biv;
1453                 }
1454             }
1455         }
1456         else {
1457             dright = SvNV_nomg(svr);
1458             right_neg = dright < 0;
1459             if (right_neg)
1460                 dright = -dright;
1461             if (dright < UV_MAX_P1) {
1462                 right = U_V(dright);
1463                 dright_valid = TRUE; /* In case we need to use double below.  */
1464             } else {
1465                 use_double = TRUE;
1466             }
1467         }
1468
1469         /* At this point use_double is only true if right is out of range for
1470            a UV.  In range NV has been rounded down to nearest UV and
1471            use_double false.  */
1472         if (!use_double && SvIV_please_nomg(svl)) {
1473                 left_neg = !SvUOK(svl);
1474                 if (!left_neg) {
1475                     left = SvUVX(svl);
1476                 } else {
1477                     const IV aiv = SvIVX(svl);
1478                     if (aiv >= 0) {
1479                         left = aiv;
1480                         left_neg = FALSE; /* effectively it's a UV now */
1481                     } else {
1482                         left = -aiv;
1483                     }
1484                 }
1485         }
1486         else {
1487             dleft = SvNV_nomg(svl);
1488             left_neg = dleft < 0;
1489             if (left_neg)
1490                 dleft = -dleft;
1491
1492             /* This should be exactly the 5.6 behaviour - if left and right are
1493                both in range for UV then use U_V() rather than floor.  */
1494             if (!use_double) {
1495                 if (dleft < UV_MAX_P1) {
1496                     /* right was in range, so is dleft, so use UVs not double.
1497                      */
1498                     left = U_V(dleft);
1499                 }
1500                 /* left is out of range for UV, right was in range, so promote
1501                    right (back) to double.  */
1502                 else {
1503                     /* The +0.5 is used in 5.6 even though it is not strictly
1504                        consistent with the implicit +0 floor in the U_V()
1505                        inside the #if 1. */
1506                     dleft = Perl_floor(dleft + 0.5);
1507                     use_double = TRUE;
1508                     if (dright_valid)
1509                         dright = Perl_floor(dright + 0.5);
1510                     else
1511                         dright = right;
1512                 }
1513             }
1514         }
1515         sp -= 2;
1516         if (use_double) {
1517             NV dans;
1518
1519             if (!dright)
1520                 DIE(aTHX_ "Illegal modulus zero");
1521
1522             dans = Perl_fmod(dleft, dright);
1523             if ((left_neg != right_neg) && dans)
1524                 dans = dright - dans;
1525             if (right_neg)
1526                 dans = -dans;
1527             sv_setnv(TARG, dans);
1528         }
1529         else {
1530             UV ans;
1531
1532             if (!right)
1533                 DIE(aTHX_ "Illegal modulus zero");
1534
1535             ans = left % right;
1536             if ((left_neg != right_neg) && ans)
1537                 ans = right - ans;
1538             if (right_neg) {
1539                 /* XXX may warn: unary minus operator applied to unsigned type */
1540                 /* could change -foo to be (~foo)+1 instead     */
1541                 if (ans <= ~((UV)IV_MAX)+1)
1542                     sv_setiv(TARG, ~ans+1);
1543                 else
1544                     sv_setnv(TARG, -(NV)ans);
1545             }
1546             else
1547                 sv_setuv(TARG, ans);
1548         }
1549         PUSHTARG;
1550         RETURN;
1551     }
1552 }
1553
1554 PP(pp_repeat)
1555 {
1556     dVAR; dSP; dATARGET;
1557     IV count;
1558     SV *sv;
1559
1560     if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1561         /* TODO: think of some way of doing list-repeat overloading ??? */
1562         sv = POPs;
1563         SvGETMAGIC(sv);
1564     }
1565     else {
1566         tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1567         sv = POPs;
1568     }
1569
1570     if (SvIOKp(sv)) {
1571          if (SvUOK(sv)) {
1572               const UV uv = SvUV_nomg(sv);
1573               if (uv > IV_MAX)
1574                    count = IV_MAX; /* The best we can do? */
1575               else
1576                    count = uv;
1577          } else {
1578               const IV iv = SvIV_nomg(sv);
1579               if (iv < 0)
1580                    count = 0;
1581               else
1582                    count = iv;
1583          }
1584     }
1585     else if (SvNOKp(sv)) {
1586          const NV nv = SvNV_nomg(sv);
1587          if (nv < 0.0)
1588               count = 0;
1589          else
1590               count = (IV)nv;
1591     }
1592     else
1593          count = SvIV_nomg(sv);
1594
1595     if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1596         dMARK;
1597         static const char oom_list_extend[] = "Out of memory during list extend";
1598         const I32 items = SP - MARK;
1599         const I32 max = items * count;
1600
1601         MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1602         /* Did the max computation overflow? */
1603         if (items > 0 && max > 0 && (max < items || max < count))
1604            Perl_croak(aTHX_ oom_list_extend);
1605         MEXTEND(MARK, max);
1606         if (count > 1) {
1607             while (SP > MARK) {
1608 #if 0
1609               /* This code was intended to fix 20010809.028:
1610
1611                  $x = 'abcd';
1612                  for (($x =~ /./g) x 2) {
1613                      print chop; # "abcdabcd" expected as output.
1614                  }
1615
1616                * but that change (#11635) broke this code:
1617
1618                $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1619
1620                * I can't think of a better fix that doesn't introduce
1621                * an efficiency hit by copying the SVs. The stack isn't
1622                * refcounted, and mortalisation obviously doesn't
1623                * Do The Right Thing when the stack has more than
1624                * one pointer to the same mortal value.
1625                * .robin.
1626                */
1627                 if (*SP) {
1628                     *SP = sv_2mortal(newSVsv(*SP));
1629                     SvREADONLY_on(*SP);
1630                 }
1631 #else
1632                if (*SP)
1633                    SvTEMP_off((*SP));
1634 #endif
1635                 SP--;
1636             }
1637             MARK++;
1638             repeatcpy((char*)(MARK + items), (char*)MARK,
1639                 items * sizeof(const SV *), count - 1);
1640             SP += max;
1641         }
1642         else if (count <= 0)
1643             SP -= items;
1644     }
1645     else {      /* Note: mark already snarfed by pp_list */
1646         SV * const tmpstr = POPs;
1647         STRLEN len;
1648         bool isutf;
1649         static const char oom_string_extend[] =
1650           "Out of memory during string extend";
1651
1652         if (TARG != tmpstr)
1653             sv_setsv_nomg(TARG, tmpstr);
1654         SvPV_force_nomg(TARG, len);
1655         isutf = DO_UTF8(TARG);
1656         if (count != 1) {
1657             if (count < 1)
1658                 SvCUR_set(TARG, 0);
1659             else {
1660                 const STRLEN max = (UV)count * len;
1661                 if (len > MEM_SIZE_MAX / count)
1662                      Perl_croak(aTHX_ oom_string_extend);
1663                 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1664                 SvGROW(TARG, max + 1);
1665                 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1666                 SvCUR_set(TARG, SvCUR(TARG) * count);
1667             }
1668             *SvEND(TARG) = '\0';
1669         }
1670         if (isutf)
1671             (void)SvPOK_only_UTF8(TARG);
1672         else
1673             (void)SvPOK_only(TARG);
1674
1675         if (PL_op->op_private & OPpREPEAT_DOLIST) {
1676             /* The parser saw this as a list repeat, and there
1677                are probably several items on the stack. But we're
1678                in scalar context, and there's no pp_list to save us
1679                now. So drop the rest of the items -- robin@kitsite.com
1680              */
1681             dMARK;
1682             SP = MARK;
1683         }
1684         PUSHTARG;
1685     }
1686     RETURN;
1687 }
1688
1689 PP(pp_subtract)
1690 {
1691     dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
1692     tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1693     svr = TOPs;
1694     svl = TOPm1s;
1695     useleft = USE_LEFT(svl);
1696 #ifdef PERL_PRESERVE_IVUV
1697     /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1698        "bad things" happen if you rely on signed integers wrapping.  */
1699     if (SvIV_please_nomg(svr)) {
1700         /* Unless the left argument is integer in range we are going to have to
1701            use NV maths. Hence only attempt to coerce the right argument if
1702            we know the left is integer.  */
1703         UV auv = 0;
1704         bool auvok = FALSE;
1705         bool a_valid = 0;
1706
1707         if (!useleft) {
1708             auv = 0;
1709             a_valid = auvok = 1;
1710             /* left operand is undef, treat as zero.  */
1711         } else {
1712             /* Left operand is defined, so is it IV? */
1713             if (SvIV_please_nomg(svl)) {
1714                 if ((auvok = SvUOK(svl)))
1715                     auv = SvUVX(svl);
1716                 else {
1717                     const IV aiv = SvIVX(svl);
1718                     if (aiv >= 0) {
1719                         auv = aiv;
1720                         auvok = 1;      /* Now acting as a sign flag.  */
1721                     } else { /* 2s complement assumption for IV_MIN */
1722                         auv = (UV)-aiv;
1723                     }
1724                 }
1725                 a_valid = 1;
1726             }
1727         }
1728         if (a_valid) {
1729             bool result_good = 0;
1730             UV result;
1731             UV buv;
1732             bool buvok = SvUOK(svr);
1733
1734             if (buvok)
1735                 buv = SvUVX(svr);
1736             else {
1737                 const IV biv = SvIVX(svr);
1738                 if (biv >= 0) {
1739                     buv = biv;
1740                     buvok = 1;
1741                 } else
1742                     buv = (UV)-biv;
1743             }
1744             /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1745                else "IV" now, independent of how it came in.
1746                if a, b represents positive, A, B negative, a maps to -A etc
1747                a - b =>  (a - b)
1748                A - b => -(a + b)
1749                a - B =>  (a + b)
1750                A - B => -(a - b)
1751                all UV maths. negate result if A negative.
1752                subtract if signs same, add if signs differ. */
1753
1754             if (auvok ^ buvok) {
1755                 /* Signs differ.  */
1756                 result = auv + buv;
1757                 if (result >= auv)
1758                     result_good = 1;
1759             } else {
1760                 /* Signs same */
1761                 if (auv >= buv) {
1762                     result = auv - buv;
1763                     /* Must get smaller */
1764                     if (result <= auv)
1765                         result_good = 1;
1766                 } else {
1767                     result = buv - auv;
1768                     if (result <= buv) {
1769                         /* result really should be -(auv-buv). as its negation
1770                            of true value, need to swap our result flag  */
1771                         auvok = !auvok;
1772                         result_good = 1;
1773                     }
1774                 }
1775             }
1776             if (result_good) {
1777                 SP--;
1778                 if (auvok)
1779                     SETu( result );
1780                 else {
1781                     /* Negate result */
1782                     if (result <= (UV)IV_MIN)
1783                         SETi( -(IV)result );
1784                     else {
1785                         /* result valid, but out of range for IV.  */
1786                         SETn( -(NV)result );
1787                     }
1788                 }
1789                 RETURN;
1790             } /* Overflow, drop through to NVs.  */
1791         }
1792     }
1793 #endif
1794     {
1795         NV value = SvNV_nomg(svr);
1796         (void)POPs;
1797
1798         if (!useleft) {
1799             /* left operand is undef, treat as zero - value */
1800             SETn(-value);
1801             RETURN;
1802         }
1803         SETn( SvNV_nomg(svl) - value );
1804         RETURN;
1805     }
1806 }
1807
1808 PP(pp_left_shift)
1809 {
1810     dVAR; dSP; dATARGET; SV *svl, *svr;
1811     tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
1812     svr = POPs;
1813     svl = TOPs;
1814     {
1815       const IV shift = SvIV_nomg(svr);
1816       if (PL_op->op_private & HINT_INTEGER) {
1817         const IV i = SvIV_nomg(svl);
1818         SETi(i << shift);
1819       }
1820       else {
1821         const UV u = SvUV_nomg(svl);
1822         SETu(u << shift);
1823       }
1824       RETURN;
1825     }
1826 }
1827
1828 PP(pp_right_shift)
1829 {
1830     dVAR; dSP; dATARGET; SV *svl, *svr;
1831     tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
1832     svr = POPs;
1833     svl = TOPs;
1834     {
1835       const IV shift = SvIV_nomg(svr);
1836       if (PL_op->op_private & HINT_INTEGER) {
1837         const IV i = SvIV_nomg(svl);
1838         SETi(i >> shift);
1839       }
1840       else {
1841         const UV u = SvUV_nomg(svl);
1842         SETu(u >> shift);
1843       }
1844       RETURN;
1845     }
1846 }
1847
1848 PP(pp_lt)
1849 {
1850     dVAR; dSP;
1851     SV *left, *right;
1852
1853     tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
1854     right = POPs;
1855     left  = TOPs;
1856     SETs(boolSV(
1857         (SvIOK_notUV(left) && SvIOK_notUV(right))
1858         ? (SvIVX(left) < SvIVX(right))
1859         : (do_ncmp(left, right) == -1)
1860     ));
1861     RETURN;
1862 }
1863
1864 PP(pp_gt)
1865 {
1866     dVAR; dSP;
1867     SV *left, *right;
1868
1869     tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
1870     right = POPs;
1871     left  = TOPs;
1872     SETs(boolSV(
1873         (SvIOK_notUV(left) && SvIOK_notUV(right))
1874         ? (SvIVX(left) > SvIVX(right))
1875         : (do_ncmp(left, right) == 1)
1876     ));
1877     RETURN;
1878 }
1879
1880 PP(pp_le)
1881 {
1882     dVAR; dSP;
1883     SV *left, *right;
1884
1885     tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
1886     right = POPs;
1887     left  = TOPs;
1888     SETs(boolSV(
1889         (SvIOK_notUV(left) && SvIOK_notUV(right))
1890         ? (SvIVX(left) <= SvIVX(right))
1891         : (do_ncmp(left, right) <= 0)
1892     ));
1893     RETURN;
1894 }
1895
1896 PP(pp_ge)
1897 {
1898     dVAR; dSP;
1899     SV *left, *right;
1900
1901     tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
1902     right = POPs;
1903     left  = TOPs;
1904     SETs(boolSV(
1905         (SvIOK_notUV(left) && SvIOK_notUV(right))
1906         ? (SvIVX(left) >= SvIVX(right))
1907         : ( (do_ncmp(left, right) & 2) == 0)
1908     ));
1909     RETURN;
1910 }
1911
1912 PP(pp_ne)
1913 {
1914     dVAR; dSP;
1915     SV *left, *right;
1916
1917     tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
1918     right = POPs;
1919     left  = TOPs;
1920     SETs(boolSV(
1921         (SvIOK_notUV(left) && SvIOK_notUV(right))
1922         ? (SvIVX(left) != SvIVX(right))
1923         : (do_ncmp(left, right) != 0)
1924     ));
1925     RETURN;
1926 }
1927
1928 /* compare left and right SVs. Returns:
1929  * -1: <
1930  *  0: ==
1931  *  1: >
1932  *  2: left or right was a NaN
1933  */
1934 I32
1935 Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
1936 {
1937     dVAR;
1938
1939     PERL_ARGS_ASSERT_DO_NCMP;
1940 #ifdef PERL_PRESERVE_IVUV
1941     /* Fortunately it seems NaN isn't IOK */
1942     if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
1943             if (!SvUOK(left)) {
1944                 const IV leftiv = SvIVX(left);
1945                 if (!SvUOK(right)) {
1946                     /* ## IV <=> IV ## */
1947                     const IV rightiv = SvIVX(right);
1948                     return (leftiv > rightiv) - (leftiv < rightiv);
1949                 }
1950                 /* ## IV <=> UV ## */
1951                 if (leftiv < 0)
1952                     /* As (b) is a UV, it's >=0, so it must be < */
1953                     return -1;
1954                 {
1955                     const UV rightuv = SvUVX(right);
1956                     return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
1957                 }
1958             }
1959
1960             if (SvUOK(right)) {
1961                 /* ## UV <=> UV ## */
1962                 const UV leftuv = SvUVX(left);
1963                 const UV rightuv = SvUVX(right);
1964                 return (leftuv > rightuv) - (leftuv < rightuv);
1965             }
1966             /* ## UV <=> IV ## */
1967             {
1968                 const IV rightiv = SvIVX(right);
1969                 if (rightiv < 0)
1970                     /* As (a) is a UV, it's >=0, so it cannot be < */
1971                     return 1;
1972                 {
1973                     const UV leftuv = SvUVX(left);
1974                     return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
1975                 }
1976             }
1977             assert(0); /* NOTREACHED */
1978     }
1979 #endif
1980     {
1981       NV const rnv = SvNV_nomg(right);
1982       NV const lnv = SvNV_nomg(left);
1983
1984 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1985       if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
1986           return 2;
1987        }
1988       return (lnv > rnv) - (lnv < rnv);
1989 #else
1990       if (lnv < rnv)
1991         return -1;
1992       if (lnv > rnv)
1993         return 1;
1994       if (lnv == rnv)
1995         return 0;
1996       return 2;
1997 #endif
1998     }
1999 }
2000
2001
2002 PP(pp_ncmp)
2003 {
2004     dVAR; dSP;
2005     SV *left, *right;
2006     I32 value;
2007     tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
2008     right = POPs;
2009     left  = TOPs;
2010     value = do_ncmp(left, right);
2011     if (value == 2) {
2012         SETs(&PL_sv_undef);
2013     }
2014     else {
2015         dTARGET;
2016         SETi(value);
2017     }
2018     RETURN;
2019 }
2020
2021 PP(pp_sle)
2022 {
2023     dVAR; dSP;
2024
2025     int amg_type = sle_amg;
2026     int multiplier = 1;
2027     int rhs = 1;
2028
2029     switch (PL_op->op_type) {
2030     case OP_SLT:
2031         amg_type = slt_amg;
2032         /* cmp < 0 */
2033         rhs = 0;
2034         break;
2035     case OP_SGT:
2036         amg_type = sgt_amg;
2037         /* cmp > 0 */
2038         multiplier = -1;
2039         rhs = 0;
2040         break;
2041     case OP_SGE:
2042         amg_type = sge_amg;
2043         /* cmp >= 0 */
2044         multiplier = -1;
2045         break;
2046     }
2047
2048     tryAMAGICbin_MG(amg_type, AMGf_set);
2049     {
2050       dPOPTOPssrl;
2051       const int cmp = (IN_LOCALE_RUNTIME
2052                  ? sv_cmp_locale_flags(left, right, 0)
2053                  : sv_cmp_flags(left, right, 0));
2054       SETs(boolSV(cmp * multiplier < rhs));
2055       RETURN;
2056     }
2057 }
2058
2059 PP(pp_seq)
2060 {
2061     dVAR; dSP;
2062     tryAMAGICbin_MG(seq_amg, AMGf_set);
2063     {
2064       dPOPTOPssrl;
2065       SETs(boolSV(sv_eq_flags(left, right, 0)));
2066       RETURN;
2067     }
2068 }
2069
2070 PP(pp_sne)
2071 {
2072     dVAR; dSP;
2073     tryAMAGICbin_MG(sne_amg, AMGf_set);
2074     {
2075       dPOPTOPssrl;
2076       SETs(boolSV(!sv_eq_flags(left, right, 0)));
2077       RETURN;
2078     }
2079 }
2080
2081 PP(pp_scmp)
2082 {
2083     dVAR; dSP; dTARGET;
2084     tryAMAGICbin_MG(scmp_amg, 0);
2085     {
2086       dPOPTOPssrl;
2087       const int cmp = (IN_LOCALE_RUNTIME
2088                  ? sv_cmp_locale_flags(left, right, 0)
2089                  : sv_cmp_flags(left, right, 0));
2090       SETi( cmp );
2091       RETURN;
2092     }
2093 }
2094
2095 PP(pp_bit_and)
2096 {
2097     dVAR; dSP; dATARGET;
2098     tryAMAGICbin_MG(band_amg, AMGf_assign);
2099     {
2100       dPOPTOPssrl;
2101       if (SvNIOKp(left) || SvNIOKp(right)) {
2102         const bool left_ro_nonnum  = !SvNIOKp(left) && SvREADONLY(left);
2103         const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2104         if (PL_op->op_private & HINT_INTEGER) {
2105           const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2106           SETi(i);
2107         }
2108         else {
2109           const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2110           SETu(u);
2111         }
2112         if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2113         if (right_ro_nonnum) SvNIOK_off(right);
2114       }
2115       else {
2116         do_vop(PL_op->op_type, TARG, left, right);
2117         SETTARG;
2118       }
2119       RETURN;
2120     }
2121 }
2122
2123 PP(pp_bit_or)
2124 {
2125     dVAR; dSP; dATARGET;
2126     const int op_type = PL_op->op_type;
2127
2128     tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2129     {
2130       dPOPTOPssrl;
2131       if (SvNIOKp(left) || SvNIOKp(right)) {
2132         const bool left_ro_nonnum  = !SvNIOKp(left) && SvREADONLY(left);
2133         const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2134         if (PL_op->op_private & HINT_INTEGER) {
2135           const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2136           const IV r = SvIV_nomg(right);
2137           const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2138           SETi(result);
2139         }
2140         else {
2141           const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2142           const UV r = SvUV_nomg(right);
2143           const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2144           SETu(result);
2145         }
2146         if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2147         if (right_ro_nonnum) SvNIOK_off(right);
2148       }
2149       else {
2150         do_vop(op_type, TARG, left, right);
2151         SETTARG;
2152       }
2153       RETURN;
2154     }
2155 }
2156
2157 PERL_STATIC_INLINE bool
2158 S_negate_string(pTHX)
2159 {
2160     dTARGET; dSP;
2161     STRLEN len;
2162     const char *s;
2163     SV * const sv = TOPs;
2164     if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2165         return FALSE;
2166     s = SvPV_nomg_const(sv, len);
2167     if (isIDFIRST(*s)) {
2168         sv_setpvs(TARG, "-");
2169         sv_catsv(TARG, sv);
2170     }
2171     else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2172         sv_setsv_nomg(TARG, sv);
2173         *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2174     }
2175     else return FALSE;
2176     SETTARG; PUTBACK;
2177     return TRUE;
2178 }
2179
2180 PP(pp_negate)
2181 {
2182     dVAR; dSP; dTARGET;
2183     tryAMAGICun_MG(neg_amg, AMGf_numeric);
2184     if (S_negate_string(aTHX)) return NORMAL;
2185     {
2186         SV * const sv = TOPs;
2187
2188         if (SvIOK(sv)) {
2189             /* It's publicly an integer */
2190         oops_its_an_int:
2191             if (SvIsUV(sv)) {
2192                 if (SvIVX(sv) == IV_MIN) {
2193                     /* 2s complement assumption. */
2194                     SETi(SvIVX(sv));    /* special case: -((UV)IV_MAX+1) == IV_MIN */
2195                     RETURN;
2196                 }
2197                 else if (SvUVX(sv) <= IV_MAX) {
2198                     SETi(-SvIVX(sv));
2199                     RETURN;
2200                 }
2201             }
2202             else if (SvIVX(sv) != IV_MIN) {
2203                 SETi(-SvIVX(sv));
2204                 RETURN;
2205             }
2206 #ifdef PERL_PRESERVE_IVUV
2207             else {
2208                 SETu((UV)IV_MIN);
2209                 RETURN;
2210             }
2211 #endif
2212         }
2213         if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
2214             SETn(-SvNV_nomg(sv));
2215         else if (SvPOKp(sv) && SvIV_please_nomg(sv))
2216                   goto oops_its_an_int;
2217         else
2218             SETn(-SvNV_nomg(sv));
2219     }
2220     RETURN;
2221 }
2222
2223 PP(pp_not)
2224 {
2225     dVAR; dSP;
2226     tryAMAGICun_MG(not_amg, AMGf_set);
2227     *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
2228     return NORMAL;
2229 }
2230
2231 PP(pp_complement)
2232 {
2233     dVAR; dSP; dTARGET;
2234     tryAMAGICun_MG(compl_amg, AMGf_numeric);
2235     {
2236       dTOPss;
2237       if (SvNIOKp(sv)) {
2238         if (PL_op->op_private & HINT_INTEGER) {
2239           const IV i = ~SvIV_nomg(sv);
2240           SETi(i);
2241         }
2242         else {
2243           const UV u = ~SvUV_nomg(sv);
2244           SETu(u);
2245         }
2246       }
2247       else {
2248         U8 *tmps;
2249         I32 anum;
2250         STRLEN len;
2251
2252         (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2253         sv_setsv_nomg(TARG, sv);
2254         tmps = (U8*)SvPV_force_nomg(TARG, len);
2255         anum = len;
2256         if (SvUTF8(TARG)) {
2257           /* Calculate exact length, let's not estimate. */
2258           STRLEN targlen = 0;
2259           STRLEN l;
2260           UV nchar = 0;
2261           UV nwide = 0;
2262           U8 * const send = tmps + len;
2263           U8 * const origtmps = tmps;
2264           const UV utf8flags = UTF8_ALLOW_ANYUV;
2265
2266           while (tmps < send) {
2267             const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2268             tmps += l;
2269             targlen += UNISKIP(~c);
2270             nchar++;
2271             if (c > 0xff)
2272                 nwide++;
2273           }
2274
2275           /* Now rewind strings and write them. */
2276           tmps = origtmps;
2277
2278           if (nwide) {
2279               U8 *result;
2280               U8 *p;
2281
2282               Newx(result, targlen + 1, U8);
2283               p = result;
2284               while (tmps < send) {
2285                   const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2286                   tmps += l;
2287                   p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2288               }
2289               *p = '\0';
2290               sv_usepvn_flags(TARG, (char*)result, targlen,
2291                               SV_HAS_TRAILING_NUL);
2292               SvUTF8_on(TARG);
2293           }
2294           else {
2295               U8 *result;
2296               U8 *p;
2297
2298               Newx(result, nchar + 1, U8);
2299               p = result;
2300               while (tmps < send) {
2301                   const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2302                   tmps += l;
2303                   *p++ = ~c;
2304               }
2305               *p = '\0';
2306               sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2307               SvUTF8_off(TARG);
2308           }
2309           SETTARG;
2310           RETURN;
2311         }
2312 #ifdef LIBERAL
2313         {
2314             long *tmpl;
2315             for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2316                 *tmps = ~*tmps;
2317             tmpl = (long*)tmps;
2318             for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2319                 *tmpl = ~*tmpl;
2320             tmps = (U8*)tmpl;
2321         }
2322 #endif
2323         for ( ; anum > 0; anum--, tmps++)
2324             *tmps = ~*tmps;
2325         SETTARG;
2326       }
2327       RETURN;
2328     }
2329 }
2330
2331 /* integer versions of some of the above */
2332
2333 PP(pp_i_multiply)
2334 {
2335     dVAR; dSP; dATARGET;
2336     tryAMAGICbin_MG(mult_amg, AMGf_assign);
2337     {
2338       dPOPTOPiirl_nomg;
2339       SETi( left * right );
2340       RETURN;
2341     }
2342 }
2343
2344 PP(pp_i_divide)
2345 {
2346     IV num;
2347     dVAR; dSP; dATARGET;
2348     tryAMAGICbin_MG(div_amg, AMGf_assign);
2349     {
2350       dPOPTOPssrl;
2351       IV value = SvIV_nomg(right);
2352       if (value == 0)
2353           DIE(aTHX_ "Illegal division by zero");
2354       num = SvIV_nomg(left);
2355
2356       /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2357       if (value == -1)
2358           value = - num;
2359       else
2360           value = num / value;
2361       SETi(value);
2362       RETURN;
2363     }
2364 }
2365
2366 #if defined(__GLIBC__) && IVSIZE == 8
2367 STATIC
2368 PP(pp_i_modulo_0)
2369 #else
2370 PP(pp_i_modulo)
2371 #endif
2372 {
2373      /* This is the vanilla old i_modulo. */
2374      dVAR; dSP; dATARGET;
2375      tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2376      {
2377           dPOPTOPiirl_nomg;
2378           if (!right)
2379                DIE(aTHX_ "Illegal modulus zero");
2380           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2381           if (right == -1)
2382               SETi( 0 );
2383           else
2384               SETi( left % right );
2385           RETURN;
2386      }
2387 }
2388
2389 #if defined(__GLIBC__) && IVSIZE == 8
2390 STATIC
2391 PP(pp_i_modulo_1)
2392
2393 {
2394      /* This is the i_modulo with the workaround for the _moddi3 bug
2395       * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2396       * See below for pp_i_modulo. */
2397      dVAR; dSP; dATARGET;
2398      tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2399      {
2400           dPOPTOPiirl_nomg;
2401           if (!right)
2402                DIE(aTHX_ "Illegal modulus zero");
2403           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2404           if (right == -1)
2405               SETi( 0 );
2406           else
2407               SETi( left % PERL_ABS(right) );
2408           RETURN;
2409      }
2410 }
2411
2412 PP(pp_i_modulo)
2413 {
2414      dVAR; dSP; dATARGET;
2415      tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2416      {
2417           dPOPTOPiirl_nomg;
2418           if (!right)
2419                DIE(aTHX_ "Illegal modulus zero");
2420           /* The assumption is to use hereafter the old vanilla version... */
2421           PL_op->op_ppaddr =
2422                PL_ppaddr[OP_I_MODULO] =
2423                    Perl_pp_i_modulo_0;
2424           /* .. but if we have glibc, we might have a buggy _moddi3
2425            * (at least glicb 2.2.5 is known to have this bug), in other
2426            * words our integer modulus with negative quad as the second
2427            * argument might be broken.  Test for this and re-patch the
2428            * opcode dispatch table if that is the case, remembering to
2429            * also apply the workaround so that this first round works
2430            * right, too.  See [perl #9402] for more information. */
2431           {
2432                IV l =   3;
2433                IV r = -10;
2434                /* Cannot do this check with inlined IV constants since
2435                 * that seems to work correctly even with the buggy glibc. */
2436                if (l % r == -3) {
2437                     /* Yikes, we have the bug.
2438                      * Patch in the workaround version. */
2439                     PL_op->op_ppaddr =
2440                          PL_ppaddr[OP_I_MODULO] =
2441                              &Perl_pp_i_modulo_1;
2442                     /* Make certain we work right this time, too. */
2443                     right = PERL_ABS(right);
2444                }
2445           }
2446           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2447           if (right == -1)
2448               SETi( 0 );
2449           else
2450               SETi( left % right );
2451           RETURN;
2452      }
2453 }
2454 #endif
2455
2456 PP(pp_i_add)
2457 {
2458     dVAR; dSP; dATARGET;
2459     tryAMAGICbin_MG(add_amg, AMGf_assign);
2460     {
2461       dPOPTOPiirl_ul_nomg;
2462       SETi( left + right );
2463       RETURN;
2464     }
2465 }
2466
2467 PP(pp_i_subtract)
2468 {
2469     dVAR; dSP; dATARGET;
2470     tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2471     {
2472       dPOPTOPiirl_ul_nomg;
2473       SETi( left - right );
2474       RETURN;
2475     }
2476 }
2477
2478 PP(pp_i_lt)
2479 {
2480     dVAR; dSP;
2481     tryAMAGICbin_MG(lt_amg, AMGf_set);
2482     {
2483       dPOPTOPiirl_nomg;
2484       SETs(boolSV(left < right));
2485       RETURN;
2486     }
2487 }
2488
2489 PP(pp_i_gt)
2490 {
2491     dVAR; dSP;
2492     tryAMAGICbin_MG(gt_amg, AMGf_set);
2493     {
2494       dPOPTOPiirl_nomg;
2495       SETs(boolSV(left > right));
2496       RETURN;
2497     }
2498 }
2499
2500 PP(pp_i_le)
2501 {
2502     dVAR; dSP;
2503     tryAMAGICbin_MG(le_amg, AMGf_set);
2504     {
2505       dPOPTOPiirl_nomg;
2506       SETs(boolSV(left <= right));
2507       RETURN;
2508     }
2509 }
2510
2511 PP(pp_i_ge)
2512 {
2513     dVAR; dSP;
2514     tryAMAGICbin_MG(ge_amg, AMGf_set);
2515     {
2516       dPOPTOPiirl_nomg;
2517       SETs(boolSV(left >= right));
2518       RETURN;
2519     }
2520 }
2521
2522 PP(pp_i_eq)
2523 {
2524     dVAR; dSP;
2525     tryAMAGICbin_MG(eq_amg, AMGf_set);
2526     {
2527       dPOPTOPiirl_nomg;
2528       SETs(boolSV(left == right));
2529       RETURN;
2530     }
2531 }
2532
2533 PP(pp_i_ne)
2534 {
2535     dVAR; dSP;
2536     tryAMAGICbin_MG(ne_amg, AMGf_set);
2537     {
2538       dPOPTOPiirl_nomg;
2539       SETs(boolSV(left != right));
2540       RETURN;
2541     }
2542 }
2543
2544 PP(pp_i_ncmp)
2545 {
2546     dVAR; dSP; dTARGET;
2547     tryAMAGICbin_MG(ncmp_amg, 0);
2548     {
2549       dPOPTOPiirl_nomg;
2550       I32 value;
2551
2552       if (left > right)
2553         value = 1;
2554       else if (left < right)
2555         value = -1;
2556       else
2557         value = 0;
2558       SETi(value);
2559       RETURN;
2560     }
2561 }
2562
2563 PP(pp_i_negate)
2564 {
2565     dVAR; dSP; dTARGET;
2566     tryAMAGICun_MG(neg_amg, 0);
2567     if (S_negate_string(aTHX)) return NORMAL;
2568     {
2569         SV * const sv = TOPs;
2570         IV const i = SvIV_nomg(sv);
2571         SETi(-i);
2572         RETURN;
2573     }
2574 }
2575
2576 /* High falutin' math. */
2577
2578 PP(pp_atan2)
2579 {
2580     dVAR; dSP; dTARGET;
2581     tryAMAGICbin_MG(atan2_amg, 0);
2582     {
2583       dPOPTOPnnrl_nomg;
2584       SETn(Perl_atan2(left, right));
2585       RETURN;
2586     }
2587 }
2588
2589 PP(pp_sin)
2590 {
2591     dVAR; dSP; dTARGET;
2592     int amg_type = sin_amg;
2593     const char *neg_report = NULL;
2594     NV (*func)(NV) = Perl_sin;
2595     const int op_type = PL_op->op_type;
2596
2597     switch (op_type) {
2598     case OP_COS:
2599         amg_type = cos_amg;
2600         func = Perl_cos;
2601         break;
2602     case OP_EXP:
2603         amg_type = exp_amg;
2604         func = Perl_exp;
2605         break;
2606     case OP_LOG:
2607         amg_type = log_amg;
2608         func = Perl_log;
2609         neg_report = "log";
2610         break;
2611     case OP_SQRT:
2612         amg_type = sqrt_amg;
2613         func = Perl_sqrt;
2614         neg_report = "sqrt";
2615         break;
2616     }
2617
2618
2619     tryAMAGICun_MG(amg_type, 0);
2620     {
2621       SV * const arg = POPs;
2622       const NV value = SvNV_nomg(arg);
2623       if (neg_report) {
2624           if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2625               SET_NUMERIC_STANDARD();
2626               /* diag_listed_as: Can't take log of %g */
2627               DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2628           }
2629       }
2630       XPUSHn(func(value));
2631       RETURN;
2632     }
2633 }
2634
2635 /* Support Configure command-line overrides for rand() functions.
2636    After 5.005, perhaps we should replace this by Configure support
2637    for drand48(), random(), or rand().  For 5.005, though, maintain
2638    compatibility by calling rand() but allow the user to override it.
2639    See INSTALL for details.  --Andy Dougherty  15 July 1998
2640 */
2641 /* Now it's after 5.005, and Configure supports drand48() and random(),
2642    in addition to rand().  So the overrides should not be needed any more.
2643    --Jarkko Hietaniemi  27 September 1998
2644  */
2645
2646 #ifndef HAS_DRAND48_PROTO
2647 extern double drand48 (void);
2648 #endif
2649
2650 PP(pp_rand)
2651 {
2652     dVAR; dSP; dTARGET;
2653     NV value;
2654     if (MAXARG < 1)
2655         value = 1.0;
2656     else if (!TOPs) {
2657         value = 1.0; (void)POPs;
2658     }
2659     else
2660         value = POPn;
2661     if (value == 0.0)
2662         value = 1.0;
2663     if (!PL_srand_called) {
2664         (void)seedDrand01((Rand_seed_t)seed());
2665         PL_srand_called = TRUE;
2666     }
2667     value *= Drand01();
2668     XPUSHn(value);
2669     RETURN;
2670 }
2671
2672 PP(pp_srand)
2673 {
2674     dVAR; dSP; dTARGET;
2675     UV anum;
2676
2677     if (MAXARG >= 1 && (TOPs || POPs)) {
2678         SV *top;
2679         char *pv;
2680         STRLEN len;
2681         int flags;
2682
2683         top = POPs;
2684         pv = SvPV(top, len);
2685         flags = grok_number(pv, len, &anum);
2686
2687         if (!(flags & IS_NUMBER_IN_UV)) {
2688             Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
2689                              "Integer overflow in srand");
2690             anum = UV_MAX;
2691         }
2692     }
2693     else {
2694         anum = seed();
2695     }
2696
2697     (void)seedDrand01((Rand_seed_t)anum);
2698     PL_srand_called = TRUE;
2699     if (anum)
2700         XPUSHu(anum);
2701     else {
2702         /* Historically srand always returned true. We can avoid breaking
2703            that like this:  */
2704         sv_setpvs(TARG, "0 but true");
2705         XPUSHTARG;
2706     }
2707     RETURN;
2708 }
2709
2710 PP(pp_int)
2711 {
2712     dVAR; dSP; dTARGET;
2713     tryAMAGICun_MG(int_amg, AMGf_numeric);
2714     {
2715       SV * const sv = TOPs;
2716       const IV iv = SvIV_nomg(sv);
2717       /* XXX it's arguable that compiler casting to IV might be subtly
2718          different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2719          else preferring IV has introduced a subtle behaviour change bug. OTOH
2720          relying on floating point to be accurate is a bug.  */
2721
2722       if (!SvOK(sv)) {
2723         SETu(0);
2724       }
2725       else if (SvIOK(sv)) {
2726         if (SvIsUV(sv))
2727             SETu(SvUV_nomg(sv));
2728         else
2729             SETi(iv);
2730       }
2731       else {
2732           const NV value = SvNV_nomg(sv);
2733           if (value >= 0.0) {
2734               if (value < (NV)UV_MAX + 0.5) {
2735                   SETu(U_V(value));
2736               } else {
2737                   SETn(Perl_floor(value));
2738               }
2739           }
2740           else {
2741               if (value > (NV)IV_MIN - 0.5) {
2742                   SETi(I_V(value));
2743               } else {
2744                   SETn(Perl_ceil(value));
2745               }
2746           }
2747       }
2748     }
2749     RETURN;
2750 }
2751
2752 PP(pp_abs)
2753 {
2754     dVAR; dSP; dTARGET;
2755     tryAMAGICun_MG(abs_amg, AMGf_numeric);
2756     {
2757       SV * const sv = TOPs;
2758       /* This will cache the NV value if string isn't actually integer  */
2759       const IV iv = SvIV_nomg(sv);
2760
2761       if (!SvOK(sv)) {
2762         SETu(0);
2763       }
2764       else if (SvIOK(sv)) {
2765         /* IVX is precise  */
2766         if (SvIsUV(sv)) {
2767           SETu(SvUV_nomg(sv));  /* force it to be numeric only */
2768         } else {
2769           if (iv >= 0) {
2770             SETi(iv);
2771           } else {
2772             if (iv != IV_MIN) {
2773               SETi(-iv);
2774             } else {
2775               /* 2s complement assumption. Also, not really needed as
2776                  IV_MIN and -IV_MIN should both be %100...00 and NV-able  */
2777               SETu(IV_MIN);
2778             }
2779           }
2780         }
2781       } else{
2782         const NV value = SvNV_nomg(sv);
2783         if (value < 0.0)
2784           SETn(-value);
2785         else
2786           SETn(value);
2787       }
2788     }
2789     RETURN;
2790 }
2791
2792 PP(pp_oct)
2793 {
2794     dVAR; dSP; dTARGET;
2795     const char *tmps;
2796     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2797     STRLEN len;
2798     NV result_nv;
2799     UV result_uv;
2800     SV* const sv = POPs;
2801
2802     tmps = (SvPV_const(sv, len));
2803     if (DO_UTF8(sv)) {
2804          /* If Unicode, try to downgrade
2805           * If not possible, croak. */
2806          SV* const tsv = sv_2mortal(newSVsv(sv));
2807
2808          SvUTF8_on(tsv);
2809          sv_utf8_downgrade(tsv, FALSE);
2810          tmps = SvPV_const(tsv, len);
2811     }
2812     if (PL_op->op_type == OP_HEX)
2813         goto hex;
2814
2815     while (*tmps && len && isSPACE(*tmps))
2816         tmps++, len--;
2817     if (*tmps == '0')
2818         tmps++, len--;
2819     if (*tmps == 'x' || *tmps == 'X') {
2820     hex:
2821         result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2822     }
2823     else if (*tmps == 'b' || *tmps == 'B')
2824         result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2825     else
2826         result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2827
2828     if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2829         XPUSHn(result_nv);
2830     }
2831     else {
2832         XPUSHu(result_uv);
2833     }
2834     RETURN;
2835 }
2836
2837 /* String stuff. */
2838
2839 PP(pp_length)
2840 {
2841     dVAR; dSP; dTARGET;
2842     SV * const sv = TOPs;
2843
2844     if (SvGAMAGIC(sv)) {
2845         /* For an overloaded or magic scalar, we can't know in advance if
2846            it's going to be UTF-8 or not. Also, we can't call sv_len_utf8 as
2847            it likes to cache the length. Maybe that should be a documented
2848            feature of it.
2849         */
2850         STRLEN len;
2851         const char *const p
2852             = sv_2pv_flags(sv, &len,
2853                            SV_UNDEF_RETURNS_NULL|SV_CONST_RETURN|SV_GMAGIC);
2854
2855         if (!p) {
2856             if (!SvPADTMP(TARG)) {
2857                 sv_setsv(TARG, &PL_sv_undef);
2858                 SETTARG;
2859             }
2860             SETs(&PL_sv_undef);
2861         }
2862         else if (DO_UTF8(sv)) {
2863             SETi(utf8_length((U8*)p, (U8*)p + len));
2864         }
2865         else
2866             SETi(len);
2867     } else if (SvOK(sv)) {
2868         /* Neither magic nor overloaded.  */
2869         if (DO_UTF8(sv))
2870             SETi(sv_len_utf8(sv));
2871         else
2872             SETi(sv_len(sv));
2873     } else {
2874         if (!SvPADTMP(TARG)) {
2875             sv_setsv_nomg(TARG, &PL_sv_undef);
2876             SETTARG;
2877         }
2878         SETs(&PL_sv_undef);
2879     }
2880     RETURN;
2881 }
2882
2883 /* Returns false if substring is completely outside original string.
2884    No length is indicated by len_iv = 0 and len_is_uv = 0.  len_is_uv must
2885    always be true for an explicit 0.
2886 */
2887 bool
2888 Perl_translate_substr_offsets(pTHX_ STRLEN curlen, IV pos1_iv,
2889                                     bool pos1_is_uv, IV len_iv,
2890                                     bool len_is_uv, STRLEN *posp,
2891                                     STRLEN *lenp)
2892 {
2893     IV pos2_iv;
2894     int    pos2_is_uv;
2895
2896     PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
2897
2898     if (!pos1_is_uv && pos1_iv < 0 && curlen) {
2899         pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
2900         pos1_iv += curlen;
2901     }
2902     if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
2903         return FALSE;
2904
2905     if (len_iv || len_is_uv) {
2906         if (!len_is_uv && len_iv < 0) {
2907             pos2_iv = curlen + len_iv;
2908             if (curlen)
2909                 pos2_is_uv = curlen-1 > ~(UV)len_iv;
2910             else
2911                 pos2_is_uv = 0;
2912         } else {  /* len_iv >= 0 */
2913             if (!pos1_is_uv && pos1_iv < 0) {
2914                 pos2_iv = pos1_iv + len_iv;
2915                 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
2916             } else {
2917                 if ((UV)len_iv > curlen-(UV)pos1_iv)
2918                     pos2_iv = curlen;
2919                 else
2920                     pos2_iv = pos1_iv+len_iv;
2921                 pos2_is_uv = 1;
2922             }
2923         }
2924     }
2925     else {
2926         pos2_iv = curlen;
2927         pos2_is_uv = 1;
2928     }
2929
2930     if (!pos2_is_uv && pos2_iv < 0) {
2931         if (!pos1_is_uv && pos1_iv < 0)
2932             return FALSE;
2933         pos2_iv = 0;
2934     }
2935     else if (!pos1_is_uv && pos1_iv < 0)
2936         pos1_iv = 0;
2937
2938     if ((UV)pos2_iv < (UV)pos1_iv)
2939         pos2_iv = pos1_iv;
2940     if ((UV)pos2_iv > curlen)
2941         pos2_iv = curlen;
2942
2943     /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
2944     *posp = (STRLEN)( (UV)pos1_iv );
2945     *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
2946
2947     return TRUE;
2948 }
2949
2950 PP(pp_substr)
2951 {
2952     dVAR; dSP; dTARGET;
2953     SV *sv;
2954     STRLEN curlen;
2955     STRLEN utf8_curlen;
2956     SV *   pos_sv;
2957     IV     pos1_iv;
2958     int    pos1_is_uv;
2959     SV *   len_sv;
2960     IV     len_iv = 0;
2961     int    len_is_uv = 0;
2962     I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2963     const bool rvalue = (GIMME_V != G_VOID);
2964     const char *tmps;
2965     SV *repl_sv = NULL;
2966     const char *repl = NULL;
2967     STRLEN repl_len;
2968     int num_args = PL_op->op_private & 7;
2969     bool repl_need_utf8_upgrade = FALSE;
2970     bool repl_is_utf8 = FALSE;
2971
2972     if (num_args > 2) {
2973         if (num_args > 3) {
2974           if(!(repl_sv = POPs)) num_args--;
2975         }
2976         if ((len_sv = POPs)) {
2977             len_iv    = SvIV(len_sv);
2978             len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
2979         }
2980         else num_args--;
2981     }
2982     pos_sv     = POPs;
2983     pos1_iv    = SvIV(pos_sv);
2984     pos1_is_uv = SvIOK_UV(pos_sv);
2985     sv = POPs;
2986     if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
2987         assert(!repl_sv);
2988         repl_sv = POPs;
2989     }
2990     PUTBACK;
2991     if (repl_sv) {
2992         repl = SvPV_const(repl_sv, repl_len);
2993         repl_is_utf8 = DO_UTF8(repl_sv) && repl_len;
2994         if (repl_is_utf8) {
2995             if (!DO_UTF8(sv))
2996                 sv_utf8_upgrade(sv);
2997         }
2998         else if (DO_UTF8(sv))
2999             repl_need_utf8_upgrade = TRUE;
3000     }
3001     else if (lvalue) {
3002         SV * ret;
3003         ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
3004         sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3005         LvTYPE(ret) = 'x';
3006         LvTARG(ret) = SvREFCNT_inc_simple(sv);
3007         LvTARGOFF(ret) =
3008             pos1_is_uv || pos1_iv >= 0
3009                 ? (STRLEN)(UV)pos1_iv
3010                 : (LvFLAGS(ret) |= 1, (STRLEN)(UV)-pos1_iv);
3011         LvTARGLEN(ret) =
3012             len_is_uv || len_iv > 0
3013                 ? (STRLEN)(UV)len_iv
3014                 : (LvFLAGS(ret) |= 2, (STRLEN)(UV)-len_iv);
3015
3016         SPAGAIN;
3017         PUSHs(ret);    /* avoid SvSETMAGIC here */
3018         RETURN;
3019     }
3020     tmps = SvPV_const(sv, curlen);
3021     if (DO_UTF8(sv)) {
3022         utf8_curlen = sv_len_utf8(sv);
3023         if (utf8_curlen == curlen)
3024             utf8_curlen = 0;
3025         else
3026             curlen = utf8_curlen;
3027     }
3028     else
3029         utf8_curlen = 0;
3030
3031     {
3032         STRLEN pos, len, byte_len, byte_pos;
3033
3034         if (!translate_substr_offsets(
3035                 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3036         )) goto bound_fail;
3037
3038         byte_len = len;
3039         byte_pos = utf8_curlen
3040             ? sv_pos_u2b_flags(sv, pos, &byte_len, SV_CONST_RETURN) : pos;
3041
3042         tmps += byte_pos;
3043
3044         if (rvalue) {
3045             SvTAINTED_off(TARG);                        /* decontaminate */
3046             SvUTF8_off(TARG);                   /* decontaminate */
3047             sv_setpvn(TARG, tmps, byte_len);
3048 #ifdef USE_LOCALE_COLLATE
3049             sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3050 #endif
3051             if (utf8_curlen)
3052                 SvUTF8_on(TARG);
3053         }
3054
3055         if (repl) {
3056             SV* repl_sv_copy = NULL;
3057
3058             if (repl_need_utf8_upgrade) {
3059                 repl_sv_copy = newSVsv(repl_sv);
3060                 sv_utf8_upgrade(repl_sv_copy);
3061                 repl = SvPV_const(repl_sv_copy, repl_len);
3062                 repl_is_utf8 = DO_UTF8(repl_sv_copy) && repl_len;
3063             }
3064             if (SvROK(sv))
3065                 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3066                             "Attempt to use reference as lvalue in substr"
3067                 );
3068             if (!SvOK(sv))
3069                 sv_setpvs(sv, "");
3070             sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3071             if (repl_is_utf8)
3072                 SvUTF8_on(sv);
3073             SvREFCNT_dec(repl_sv_copy);
3074         }
3075     }
3076     SPAGAIN;
3077     if (rvalue) {
3078         SvSETMAGIC(TARG);
3079         PUSHs(TARG);
3080     }
3081     RETURN;
3082
3083 bound_fail:
3084     if (repl)
3085         Perl_croak(aTHX_ "substr outside of string");
3086     Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3087     RETPUSHUNDEF;
3088 }
3089
3090 PP(pp_vec)
3091 {
3092     dVAR; dSP;
3093     const IV size   = POPi;
3094     const IV offset = POPi;
3095     SV * const src = POPs;
3096     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3097     SV * ret;
3098
3099     if (lvalue) {                       /* it's an lvalue! */
3100         ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
3101         sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3102         LvTYPE(ret) = 'v';
3103         LvTARG(ret) = SvREFCNT_inc_simple(src);
3104         LvTARGOFF(ret) = offset;
3105         LvTARGLEN(ret) = size;
3106     }
3107     else {
3108         dTARGET;
3109         SvTAINTED_off(TARG);            /* decontaminate */
3110         ret = TARG;
3111     }
3112
3113     sv_setuv(ret, do_vecget(src, offset, size));
3114     PUSHs(ret);
3115     RETURN;
3116 }
3117
3118 PP(pp_index)
3119 {
3120     dVAR; dSP; dTARGET;
3121     SV *big;
3122     SV *little;
3123     SV *temp = NULL;
3124     STRLEN biglen;
3125     STRLEN llen = 0;
3126     I32 offset;
3127     I32 retval;
3128     const char *big_p;
3129     const char *little_p;
3130     bool big_utf8;
3131     bool little_utf8;
3132     const bool is_index = PL_op->op_type == OP_INDEX;
3133     const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
3134
3135     if (threeargs)
3136         offset = POPi;
3137     little = POPs;
3138     big = POPs;
3139     big_p = SvPV_const(big, biglen);
3140     little_p = SvPV_const(little, llen);
3141
3142     big_utf8 = DO_UTF8(big);
3143     little_utf8 = DO_UTF8(little);
3144     if (big_utf8 ^ little_utf8) {
3145         /* One needs to be upgraded.  */
3146         if (little_utf8 && !PL_encoding) {
3147             /* Well, maybe instead we might be able to downgrade the small
3148                string?  */
3149             char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3150                                                      &little_utf8);
3151             if (little_utf8) {
3152                 /* If the large string is ISO-8859-1, and it's not possible to
3153                    convert the small string to ISO-8859-1, then there is no
3154                    way that it could be found anywhere by index.  */
3155                 retval = -1;
3156                 goto fail;
3157             }
3158
3159             /* At this point, pv is a malloc()ed string. So donate it to temp
3160                to ensure it will get free()d  */
3161             little = temp = newSV(0);
3162             sv_usepvn(temp, pv, llen);
3163             little_p = SvPVX(little);
3164         } else {
3165             temp = little_utf8
3166                 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3167
3168             if (PL_encoding) {
3169                 sv_recode_to_utf8(temp, PL_encoding);
3170             } else {
3171                 sv_utf8_upgrade(temp);
3172             }
3173             if (little_utf8) {
3174                 big = temp;
3175                 big_utf8 = TRUE;
3176                 big_p = SvPV_const(big, biglen);
3177             } else {
3178                 little = temp;
3179                 little_p = SvPV_const(little, llen);
3180             }
3181         }
3182     }
3183     if (SvGAMAGIC(big)) {
3184         /* Life just becomes a lot easier if I use a temporary here.
3185            Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3186            will trigger magic and overloading again, as will fbm_instr()
3187         */
3188         big = newSVpvn_flags(big_p, biglen,
3189                              SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3190         big_p = SvPVX(big);
3191     }
3192     if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3193         /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3194            warn on undef, and we've already triggered a warning with the
3195            SvPV_const some lines above. We can't remove that, as we need to
3196            call some SvPV to trigger overloading early and find out if the
3197            string is UTF-8.
3198            This is all getting to messy. The API isn't quite clean enough,
3199            because data access has side effects.
3200         */
3201         little = newSVpvn_flags(little_p, llen,
3202                                 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3203         little_p = SvPVX(little);
3204     }
3205
3206     if (!threeargs)
3207         offset = is_index ? 0 : biglen;
3208     else {
3209         if (big_utf8 && offset > 0)
3210             sv_pos_u2b(big, &offset, 0);
3211         if (!is_index)
3212             offset += llen;
3213     }
3214     if (offset < 0)
3215         offset = 0;
3216     else if (offset > (I32)biglen)
3217         offset = biglen;
3218     if (!(little_p = is_index
3219           ? fbm_instr((unsigned char*)big_p + offset,
3220                       (unsigned char*)big_p + biglen, little, 0)
3221           : rninstr(big_p,  big_p  + offset,
3222                     little_p, little_p + llen)))
3223         retval = -1;
3224     else {
3225         retval = little_p - big_p;
3226         if (retval > 0 && big_utf8)
3227             sv_pos_b2u(big, &retval);
3228     }
3229     SvREFCNT_dec(temp);
3230  fail:
3231     PUSHi(retval);
3232     RETURN;
3233 }
3234
3235 PP(pp_sprintf)
3236 {
3237     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3238     SvTAINTED_off(TARG);
3239     do_sprintf(TARG, SP-MARK, MARK+1);
3240     TAINT_IF(SvTAINTED(TARG));
3241     SP = ORIGMARK;
3242     PUSHTARG;
3243     RETURN;
3244 }
3245
3246 PP(pp_ord)
3247 {
3248     dVAR; dSP; dTARGET;
3249
3250     SV *argsv = POPs;
3251     STRLEN len;
3252     const U8 *s = (U8*)SvPV_const(argsv, len);
3253
3254     if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3255         SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3256         s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3257         argsv = tmpsv;
3258     }
3259
3260     XPUSHu(DO_UTF8(argsv) ?
3261            utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3262            (UV)(*s & 0xff));
3263
3264     RETURN;
3265 }
3266
3267 PP(pp_chr)
3268 {
3269     dVAR; dSP; dTARGET;
3270     char *tmps;
3271     UV value;
3272     SV *top = POPs;
3273
3274     SvGETMAGIC(top);
3275     if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3276      && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3277          ||
3278          ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3279           && SvNV_nomg(top) < 0.0))) {
3280             if (ckWARN(WARN_UTF8)) {
3281                 if (SvGMAGICAL(top)) {
3282                     SV *top2 = sv_newmortal();
3283                     sv_setsv_nomg(top2, top);
3284                     top = top2;
3285                 }
3286                 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3287                            "Invalid negative number (%"SVf") in chr", top);
3288             }
3289             value = UNICODE_REPLACEMENT;
3290     } else {
3291         value = SvUV_nomg(top);
3292     }
3293
3294     SvUPGRADE(TARG,SVt_PV);
3295
3296     if (value > 255 && !IN_BYTES) {
3297         SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3298         tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3299         SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3300         *tmps = '\0';
3301         (void)SvPOK_only(TARG);
3302         SvUTF8_on(TARG);
3303         XPUSHs(TARG);
3304         RETURN;
3305     }
3306
3307     SvGROW(TARG,2);
3308     SvCUR_set(TARG, 1);
3309     tmps = SvPVX(TARG);
3310     *tmps++ = (char)value;
3311     *tmps = '\0';
3312     (void)SvPOK_only(TARG);
3313
3314     if (PL_encoding && !IN_BYTES) {
3315         sv_recode_to_utf8(TARG, PL_encoding);
3316         tmps = SvPVX(TARG);
3317         if (SvCUR(TARG) == 0
3318             || ! is_utf8_string((U8*)tmps, SvCUR(TARG))
3319             || UTF8_IS_REPLACEMENT((U8*) tmps, (U8*) tmps + SvCUR(TARG)))
3320         {
3321             SvGROW(TARG, 2);
3322             tmps = SvPVX(TARG);
3323             SvCUR_set(TARG, 1);
3324             *tmps++ = (char)value;
3325             *tmps = '\0';
3326             SvUTF8_off(TARG);
3327         }
3328     }
3329
3330     XPUSHs(TARG);
3331     RETURN;
3332 }
3333
3334 PP(pp_crypt)
3335 {
3336 #ifdef HAS_CRYPT
3337     dVAR; dSP; dTARGET;
3338     dPOPTOPssrl;
3339     STRLEN len;
3340     const char *tmps = SvPV_const(left, len);
3341
3342     if (DO_UTF8(left)) {
3343          /* If Unicode, try to downgrade.
3344           * If not possible, croak.
3345           * Yes, we made this up.  */
3346          SV* const tsv = sv_2mortal(newSVsv(left));
3347
3348          SvUTF8_on(tsv);
3349          sv_utf8_downgrade(tsv, FALSE);
3350          tmps = SvPV_const(tsv, len);
3351     }
3352 #   ifdef USE_ITHREADS
3353 #     ifdef HAS_CRYPT_R
3354     if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3355       /* This should be threadsafe because in ithreads there is only
3356        * one thread per interpreter.  If this would not be true,
3357        * we would need a mutex to protect this malloc. */
3358         PL_reentrant_buffer->_crypt_struct_buffer =
3359           (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3360 #if defined(__GLIBC__) || defined(__EMX__)
3361         if (PL_reentrant_buffer->_crypt_struct_buffer) {
3362             PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3363             /* work around glibc-2.2.5 bug */
3364             PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3365         }
3366 #endif
3367     }
3368 #     endif /* HAS_CRYPT_R */
3369 #   endif /* USE_ITHREADS */
3370 #   ifdef FCRYPT
3371     sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3372 #   else
3373     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3374 #   endif
3375     SETTARG;
3376     RETURN;
3377 #else
3378     DIE(aTHX_
3379       "The crypt() function is unimplemented due to excessive paranoia.");
3380 #endif
3381 }
3382
3383 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level.  So
3384  * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3385
3386 /* Generates code to store a unicode codepoint c that is known to occupy
3387  * exactly two UTF-8 and UTF-EBCDIC bytes; it is stored into p and p+1,
3388  * and p is advanced to point to the next available byte after the two bytes */
3389 #define CAT_UNI_TO_UTF8_TWO_BYTE(p, c)                                      \
3390     STMT_START {                                                            \
3391         *(p)++ = UTF8_TWO_BYTE_HI(c);                                       \
3392         *((p)++) = UTF8_TWO_BYTE_LO(c);                                     \
3393     } STMT_END
3394
3395 PP(pp_ucfirst)
3396 {
3397     /* Actually is both lcfirst() and ucfirst().  Only the first character
3398      * changes.  This means that possibly we can change in-place, ie., just
3399      * take the source and change that one character and store it back, but not
3400      * if read-only etc, or if the length changes */
3401
3402     dVAR;
3403     dSP;
3404     SV *source = TOPs;
3405     STRLEN slen; /* slen is the byte length of the whole SV. */
3406     STRLEN need;
3407     SV *dest;
3408     bool inplace;   /* ? Convert first char only, in-place */
3409     bool doing_utf8 = FALSE;               /* ? using utf8 */
3410     bool convert_source_to_utf8 = FALSE;   /* ? need to convert */
3411     const int op_type = PL_op->op_type;
3412     const U8 *s;
3413     U8 *d;
3414     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3415     STRLEN ulen;    /* ulen is the byte length of the original Unicode character
3416                      * stored as UTF-8 at s. */
3417     STRLEN tculen;  /* tculen is the byte length of the freshly titlecased (or
3418                      * lowercased) character stored in tmpbuf.  May be either
3419                      * UTF-8 or not, but in either case is the number of bytes */
3420     bool tainted = FALSE;
3421
3422     SvGETMAGIC(source);
3423     if (SvOK(source)) {
3424         s = (const U8*)SvPV_nomg_const(source, slen);
3425     } else {
3426         if (ckWARN(WARN_UNINITIALIZED))
3427             report_uninit(source);
3428         s = (const U8*)"";
3429         slen = 0;
3430     }
3431
3432     /* We may be able to get away with changing only the first character, in
3433      * place, but not if read-only, etc.  Later we may discover more reasons to
3434      * not convert in-place. */
3435     inplace = SvPADTMP(source) && !SvREADONLY(source) && SvTEMP(source);
3436
3437     /* First calculate what the changed first character should be.  This affects
3438      * whether we can just swap it out, leaving the rest of the string unchanged,
3439      * or even if have to convert the dest to UTF-8 when the source isn't */
3440
3441     if (! slen) {   /* If empty */
3442         need = 1; /* still need a trailing NUL */
3443         ulen = 0;
3444     }
3445     else if (DO_UTF8(source)) { /* Is the source utf8? */
3446         doing_utf8 = TRUE;
3447         ulen = UTF8SKIP(s);
3448         if (op_type == OP_UCFIRST) {
3449             _to_utf8_title_flags(s, tmpbuf, &tculen,
3450                                  cBOOL(IN_LOCALE_RUNTIME), &tainted);
3451         }
3452         else {
3453             _to_utf8_lower_flags(s, tmpbuf, &tculen,
3454                                  cBOOL(IN_LOCALE_RUNTIME), &tainted);
3455         }
3456
3457         /* we can't do in-place if the length changes.  */
3458         if (ulen != tculen) inplace = FALSE;
3459         need = slen + 1 - ulen + tculen;
3460     }
3461     else { /* Non-zero length, non-UTF-8,  Need to consider locale and if
3462             * latin1 is treated as caseless.  Note that a locale takes
3463             * precedence */
3464         ulen = 1;       /* Original character is 1 byte */
3465         tculen = 1;     /* Most characters will require one byte, but this will
3466                          * need to be overridden for the tricky ones */
3467         need = slen + 1;
3468
3469         if (op_type == OP_LCFIRST) {
3470
3471             /* lower case the first letter: no trickiness for any character */
3472             *tmpbuf = (IN_LOCALE_RUNTIME) ? toLOWER_LC(*s) :
3473                         ((IN_UNI_8_BIT) ? toLOWER_LATIN1(*s) : toLOWER(*s));
3474         }
3475         /* is ucfirst() */
3476         else if (IN_LOCALE_RUNTIME) {
3477             *tmpbuf = toUPPER_LC(*s);   /* This would be a bug if any locales
3478                                          * have upper and title case different
3479                                          */
3480         }
3481         else if (! IN_UNI_8_BIT) {
3482             *tmpbuf = toUPPER(*s);      /* Returns caseless for non-ascii, or
3483                                          * on EBCDIC machines whatever the
3484                                          * native function does */
3485         }
3486         else { /* is ucfirst non-UTF-8, not in locale, and cased latin1 */
3487             UV title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3488             if (tculen > 1) {
3489                 assert(tculen == 2);
3490
3491                 /* If the result is an upper Latin1-range character, it can
3492                  * still be represented in one byte, which is its ordinal */
3493                 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3494                     *tmpbuf = (U8) title_ord;
3495                     tculen = 1;
3496                 }
3497                 else {
3498                     /* Otherwise it became more than one ASCII character (in
3499                      * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3500                      * beyond Latin1, so the number of bytes changed, so can't
3501                      * replace just the first character in place. */
3502                     inplace = FALSE;
3503
3504                     /* If the result won't fit in a byte, the entire result will
3505                      * have to be in UTF-8.  Assume worst case sizing in
3506                      * conversion. (all latin1 characters occupy at most two bytes
3507                      * in utf8) */
3508                     if (title_ord > 255) {
3509                         doing_utf8 = TRUE;
3510                         convert_source_to_utf8 = TRUE;
3511                         need = slen * 2 + 1;
3512
3513                         /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3514                          * (both) characters whose title case is above 255 is
3515                          * 2. */
3516                         ulen = 2;
3517                     }
3518                     else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3519                         need = slen + 1 + 1;
3520                     }
3521                 }
3522             }
3523         } /* End of use Unicode (Latin1) semantics */
3524     } /* End of changing the case of the first character */
3525
3526     /* Here, have the first character's changed case stored in tmpbuf.  Ready to
3527      * generate the result */
3528     if (inplace) {
3529
3530         /* We can convert in place.  This means we change just the first
3531          * character without disturbing the rest; no need to grow */
3532         dest = source;
3533         s = d = (U8*)SvPV_force_nomg(source, slen);
3534     } else {
3535         dTARGET;
3536
3537         dest = TARG;
3538
3539         /* Here, we can't convert in place; we earlier calculated how much
3540          * space we will need, so grow to accommodate that */
3541         SvUPGRADE(dest, SVt_PV);
3542         d = (U8*)SvGROW(dest, need);
3543         (void)SvPOK_only(dest);
3544
3545         SETs(dest);
3546     }
3547
3548     if (doing_utf8) {
3549         if (! inplace) {
3550             if (! convert_source_to_utf8) {
3551
3552                 /* Here  both source and dest are in UTF-8, but have to create
3553                  * the entire output.  We initialize the result to be the
3554                  * title/lower cased first character, and then append the rest
3555                  * of the string. */
3556                 sv_setpvn(dest, (char*)tmpbuf, tculen);
3557                 if (slen > ulen) {
3558                     sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3559                 }
3560             }
3561             else {
3562                 const U8 *const send = s + slen;
3563
3564                 /* Here the dest needs to be in UTF-8, but the source isn't,
3565                  * except we earlier UTF-8'd the first character of the source
3566                  * into tmpbuf.  First put that into dest, and then append the
3567                  * rest of the source, converting it to UTF-8 as we go. */
3568
3569                 /* Assert tculen is 2 here because the only two characters that
3570                  * get to this part of the code have 2-byte UTF-8 equivalents */
3571                 *d++ = *tmpbuf;
3572                 *d++ = *(tmpbuf + 1);
3573                 s++;    /* We have just processed the 1st char */
3574
3575                 for (; s < send; s++) {
3576                     d = uvchr_to_utf8(d, *s);
3577                 }
3578                 *d = '\0';
3579                 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3580             }
3581             SvUTF8_on(dest);
3582         }
3583         else {   /* in-place UTF-8.  Just overwrite the first character */
3584             Copy(tmpbuf, d, tculen, U8);
3585             SvCUR_set(dest, need - 1);
3586         }
3587
3588         if (tainted) {
3589             TAINT;
3590             SvTAINTED_on(dest);
3591         }
3592     }
3593     else {  /* Neither source nor dest are in or need to be UTF-8 */
3594         if (slen) {
3595             if (IN_LOCALE_RUNTIME) {
3596                 TAINT;
3597                 SvTAINTED_on(dest);
3598             }
3599             if (inplace) {  /* in-place, only need to change the 1st char */
3600                 *d = *tmpbuf;
3601             }
3602             else {      /* Not in-place */
3603
3604                 /* Copy the case-changed character(s) from tmpbuf */
3605                 Copy(tmpbuf, d, tculen, U8);
3606                 d += tculen - 1; /* Code below expects d to point to final
3607                                   * character stored */
3608             }
3609         }
3610         else {  /* empty source */
3611             /* See bug #39028: Don't taint if empty  */
3612             *d = *s;
3613         }
3614
3615         /* In a "use bytes" we don't treat the source as UTF-8, but, still want
3616          * the destination to retain that flag */
3617         if (SvUTF8(source))
3618             SvUTF8_on(dest);
3619
3620         if (!inplace) { /* Finish the rest of the string, unchanged */
3621             /* This will copy the trailing NUL  */
3622             Copy(s + 1, d + 1, slen, U8);
3623             SvCUR_set(dest, need - 1);
3624         }
3625     }
3626     if (dest != source && SvTAINTED(source))
3627         SvTAINT(dest);
3628     SvSETMAGIC(dest);
3629     RETURN;
3630 }
3631
3632 /* There's so much setup/teardown code common between uc and lc, I wonder if
3633    it would be worth merging the two, and just having a switch outside each
3634    of the three tight loops.  There is less and less commonality though */
3635 PP(pp_uc)
3636 {
3637     dVAR;
3638     dSP;
3639     SV *source = TOPs;
3640     STRLEN len;
3641     STRLEN min;
3642     SV *dest;
3643     const U8 *s;
3644     U8 *d;
3645
3646     SvGETMAGIC(source);
3647
3648     if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3649         && SvTEMP(source) && !DO_UTF8(source)
3650         && (IN_LOCALE_RUNTIME || ! IN_UNI_8_BIT)) {
3651
3652         /* We can convert in place.  The reason we can't if in UNI_8_BIT is to
3653          * make the loop tight, so we overwrite the source with the dest before
3654          * looking at it, and we need to look at the original source
3655          * afterwards.  There would also need to be code added to handle
3656          * switching to not in-place in midstream if we run into characters
3657          * that change the length.
3658          */
3659         dest = source;
3660         s = d = (U8*)SvPV_force_nomg(source, len);
3661         min = len + 1;
3662     } else {
3663         dTARGET;
3664
3665         dest = TARG;
3666
3667         /* The old implementation would copy source into TARG at this point.
3668            This had the side effect that if source was undef, TARG was now
3669            an undefined SV with PADTMP set, and they don't warn inside
3670            sv_2pv_flags(). However, we're now getting the PV direct from
3671            source, which doesn't have PADTMP set, so it would warn. Hence the
3672            little games.  */
3673
3674         if (SvOK(source)) {
3675             s = (const U8*)SvPV_nomg_const(source, len);
3676         } else {
3677             if (ckWARN(WARN_UNINITIALIZED))
3678                 report_uninit(source);
3679             s = (const U8*)"";
3680             len = 0;
3681         }
3682         min = len + 1;
3683
3684         SvUPGRADE(dest, SVt_PV);
3685         d = (U8*)SvGROW(dest, min);
3686         (void)SvPOK_only(dest);
3687
3688         SETs(dest);
3689     }
3690
3691     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3692        to check DO_UTF8 again here.  */
3693
3694     if (DO_UTF8(source)) {
3695         const U8 *const send = s + len;
3696         U8 tmpbuf[UTF8_MAXBYTES+1];
3697         bool tainted = FALSE;
3698
3699         /* All occurrences of these are to be moved to follow any other marks.
3700          * This is context-dependent.  We may not be passed enough context to
3701          * move the iota subscript beyond all of them, but we do the best we can
3702          * with what we're given.  The result is always better than if we
3703          * hadn't done this.  And, the problem would only arise if we are
3704          * passed a character without all its combining marks, which would be
3705          * the caller's mistake.  The information this is based on comes from a
3706          * comment in Unicode SpecialCasing.txt, (and the Standard's text
3707          * itself) and so can't be checked properly to see if it ever gets
3708          * revised.  But the likelihood of it changing is remote */
3709         bool in_iota_subscript = FALSE;
3710
3711         while (s < send) {
3712             STRLEN u;
3713             STRLEN ulen;
3714             UV uv;
3715             if (in_iota_subscript && ! is_utf8_mark(s)) {
3716
3717                 /* A non-mark.  Time to output the iota subscript */
3718 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
3719 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
3720
3721                 CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
3722                 in_iota_subscript = FALSE;
3723             }
3724
3725             /* Then handle the current character.  Get the changed case value
3726              * and copy it to the output buffer */
3727
3728             u = UTF8SKIP(s);
3729             uv = _to_utf8_upper_flags(s, tmpbuf, &ulen,
3730                                       cBOOL(IN_LOCALE_RUNTIME), &tainted);
3731             if (uv == GREEK_CAPITAL_LETTER_IOTA
3732                 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
3733             {
3734                 in_iota_subscript = TRUE;
3735             }
3736             else {
3737                 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3738                     /* If the eventually required minimum size outgrows the
3739                      * available space, we need to grow. */
3740                     const UV o = d - (U8*)SvPVX_const(dest);
3741
3742                     /* If someone uppercases one million U+03B0s we SvGROW()
3743                      * one million times.  Or we could try guessing how much to
3744                      * allocate without allocating too much.  Such is life.
3745                      * See corresponding comment in lc code for another option
3746                      * */
3747                     SvGROW(dest, min);
3748                     d = (U8*)SvPVX(dest) + o;
3749                 }
3750                 Copy(tmpbuf, d, ulen, U8);
3751                 d += ulen;
3752             }
3753             s += u;
3754         }
3755         if (in_iota_subscript) {
3756             CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
3757         }
3758         SvUTF8_on(dest);
3759         *d = '\0';
3760
3761         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3762         if (tainted) {
3763             TAINT;
3764             SvTAINTED_on(dest);
3765         }
3766     }
3767     else {      /* Not UTF-8 */
3768         if (len) {
3769             const U8 *const send = s + len;
3770
3771             /* Use locale casing if in locale; regular style if not treating
3772              * latin1 as having case; otherwise the latin1 casing.  Do the
3773              * whole thing in a tight loop, for speed, */
3774             if (IN_LOCALE_RUNTIME) {
3775                 TAINT;
3776                 SvTAINTED_on(dest);
3777                 for (; s < send; d++, s++)
3778                     *d = toUPPER_LC(*s);
3779             }
3780             else if (! IN_UNI_8_BIT) {
3781                 for (; s < send; d++, s++) {
3782                     *d = toUPPER(*s);
3783                 }
3784             }
3785             else {
3786                 for (; s < send; d++, s++) {
3787                     *d = toUPPER_LATIN1_MOD(*s);
3788                     if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) continue;
3789
3790                     /* The mainstream case is the tight loop above.  To avoid
3791                      * extra tests in that, all three characters that require
3792                      * special handling are mapped by the MOD to the one tested
3793                      * just above.
3794                      * Use the source to distinguish between the three cases */
3795
3796                     if (*s == LATIN_SMALL_LETTER_SHARP_S) {
3797
3798                         /* uc() of this requires 2 characters, but they are
3799                          * ASCII.  If not enough room, grow the string */
3800                         if (SvLEN(dest) < ++min) {
3801                             const UV o = d - (U8*)SvPVX_const(dest);
3802                             SvGROW(dest, min);
3803                             d = (U8*)SvPVX(dest) + o;
3804                         }
3805                         *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
3806                         continue;   /* Back to the tight loop; still in ASCII */
3807                     }
3808
3809                     /* The other two special handling characters have their
3810                      * upper cases outside the latin1 range, hence need to be
3811                      * in UTF-8, so the whole result needs to be in UTF-8.  So,
3812                      * here we are somewhere in the middle of processing a
3813                      * non-UTF-8 string, and realize that we will have to convert
3814                      * the whole thing to UTF-8.  What to do?  There are
3815                      * several possibilities.  The simplest to code is to
3816                      * convert what we have so far, set a flag, and continue on
3817                      * in the loop.  The flag would be tested each time through
3818                      * the loop, and if set, the next character would be
3819                      * converted to UTF-8 and stored.  But, I (khw) didn't want
3820                      * to slow down the mainstream case at all for this fairly
3821                      * rare case, so I didn't want to add a test that didn't
3822                      * absolutely have to be there in the loop, besides the
3823                      * possibility that it would get too complicated for
3824                      * optimizers to deal with.  Another possibility is to just
3825                      * give up, convert the source to UTF-8, and restart the
3826                      * function that way.  Another possibility is to convert
3827                      * both what has already been processed and what is yet to
3828                      * come separately to UTF-8, then jump into the loop that
3829                      * handles UTF-8.  But the most efficient time-wise of the
3830                      * ones I could think of is what follows, and turned out to
3831                      * not require much extra code.  */
3832
3833                     /* Convert what we have so far into UTF-8, telling the
3834                      * function that we know it should be converted, and to
3835                      * allow extra space for what we haven't processed yet.
3836                      * Assume the worst case space requirements for converting
3837                      * what we haven't processed so far: that it will require
3838                      * two bytes for each remaining source character, plus the
3839                      * NUL at the end.  This may cause the string pointer to
3840                      * move, so re-find it. */
3841
3842                     len = d - (U8*)SvPVX_const(dest);
3843                     SvCUR_set(dest, len);
3844                     len = sv_utf8_upgrade_flags_grow(dest,
3845                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3846                                                 (send -s) * 2 + 1);
3847                     d = (U8*)SvPVX(dest) + len;
3848
3849                     /* Now process the remainder of the source, converting to
3850                      * upper and UTF-8.  If a resulting byte is invariant in
3851                      * UTF-8, output it as-is, otherwise convert to UTF-8 and
3852                      * append it to the output. */
3853                     for (; s < send; s++) {
3854                         (void) _to_upper_title_latin1(*s, d, &len, 'S');
3855                         d += len;
3856                     }
3857
3858                     /* Here have processed the whole source; no need to continue
3859                      * with the outer loop.  Each character has been converted
3860                      * to upper case and converted to UTF-8 */
3861
3862                     break;
3863                 } /* End of processing all latin1-style chars */
3864             } /* End of processing all chars */
3865         } /* End of source is not empty */
3866
3867         if (source != dest) {
3868             *d = '\0';  /* Here d points to 1 after last char, add NUL */
3869             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3870         }
3871     } /* End of isn't utf8 */
3872     if (dest != source && SvTAINTED(source))
3873         SvTAINT(dest);
3874     SvSETMAGIC(dest);
3875     RETURN;
3876 }
3877
3878 PP(pp_lc)
3879 {
3880     dVAR;
3881     dSP;
3882     SV *source = TOPs;
3883     STRLEN len;
3884     STRLEN min;
3885     SV *dest;
3886     const U8 *s;
3887     U8 *d;
3888
3889     SvGETMAGIC(source);
3890
3891     if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3892         && SvTEMP(source) && !DO_UTF8(source)) {
3893
3894         /* We can convert in place, as lowercasing anything in the latin1 range
3895          * (or else DO_UTF8 would have been on) doesn't lengthen it */
3896         dest = source;
3897         s = d = (U8*)SvPV_force_nomg(source, len);
3898         min = len + 1;
3899     } else {
3900         dTARGET;
3901
3902         dest = TARG;
3903
3904         /* The old implementation would copy source into TARG at this point.
3905            This had the side effect that if source was undef, TARG was now
3906            an undefined SV with PADTMP set, and they don't warn inside
3907            sv_2pv_flags(). However, we're now getting the PV direct from
3908            source, which doesn't have PADTMP set, so it would warn. Hence the
3909            little games.  */
3910
3911         if (SvOK(source)) {
3912             s = (const U8*)SvPV_nomg_const(source, len);
3913         } else {
3914             if (ckWARN(WARN_UNINITIALIZED))
3915                 report_uninit(source);
3916             s = (const U8*)"";
3917             len = 0;
3918         }
3919         min = len + 1;
3920
3921         SvUPGRADE(dest, SVt_PV);
3922         d = (U8*)SvGROW(dest, min);
3923         (void)SvPOK_only(dest);
3924
3925         SETs(dest);
3926     }
3927
3928     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3929        to check DO_UTF8 again here.  */
3930
3931     if (DO_UTF8(source)) {
3932         const U8 *const send = s + len;
3933         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3934         bool tainted = FALSE;
3935
3936         while (s < send) {
3937             const STRLEN u = UTF8SKIP(s);
3938             STRLEN ulen;
3939
3940             _to_utf8_lower_flags(s, tmpbuf, &ulen,
3941                                  cBOOL(IN_LOCALE_RUNTIME), &tainted);
3942
3943             /* Here is where we would do context-sensitive actions.  See the
3944              * commit message for this comment for why there isn't any */
3945
3946             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3947
3948                 /* If the eventually required minimum size outgrows the
3949                  * available space, we need to grow. */
3950                 const UV o = d - (U8*)SvPVX_const(dest);
3951
3952                 /* If someone lowercases one million U+0130s we SvGROW() one
3953                  * million times.  Or we could try guessing how much to
3954                  * allocate without allocating too much.  Such is life.
3955                  * Another option would be to grow an extra byte or two more
3956                  * each time we need to grow, which would cut down the million
3957                  * to 500K, with little waste */
3958                 SvGROW(dest, min);
3959                 d = (U8*)SvPVX(dest) + o;
3960             }
3961
3962             /* Copy the newly lowercased letter to the output buffer we're
3963              * building */
3964             Copy(tmpbuf, d, ulen, U8);
3965             d += ulen;
3966             s += u;
3967         }   /* End of looping through the source string */
3968         SvUTF8_on(dest);
3969         *d = '\0';
3970         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3971         if (tainted) {
3972             TAINT;
3973             SvTAINTED_on(dest);
3974         }
3975     } else {    /* Not utf8 */
3976         if (len) {
3977             const U8 *const send = s + len;
3978
3979             /* Use locale casing if in locale; regular style if not treating
3980              * latin1 as having case; otherwise the latin1 casing.  Do the
3981              * whole thing in a tight loop, for speed, */
3982             if (IN_LOCALE_RUNTIME) {
3983                 TAINT;
3984                 SvTAINTED_on(dest);
3985                 for (; s < send; d++, s++)
3986                     *d = toLOWER_LC(*s);
3987             }
3988             else if (! IN_UNI_8_BIT) {
3989                 for (; s < send; d++, s++) {
3990                     *d = toLOWER(*s);
3991                 }
3992             }
3993             else {
3994                 for (; s < send; d++, s++) {
3995                     *d = toLOWER_LATIN1(*s);
3996                 }
3997             }
3998         }
3999         if (source != dest) {
4000             *d = '\0';
4001             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4002         }
4003     }
4004     if (dest != source && SvTAINTED(source))
4005         SvTAINT(dest);
4006     SvSETMAGIC(dest);
4007     RETURN;
4008 }
4009
4010 PP(pp_quotemeta)
4011 {
4012     dVAR; dSP; dTARGET;
4013     SV * const sv = TOPs;
4014     STRLEN len;
4015     const char *s = SvPV_const(sv,len);
4016
4017     SvUTF8_off(TARG);                           /* decontaminate */
4018     if (len) {
4019         char *d;
4020         SvUPGRADE(TARG, SVt_PV);
4021         SvGROW(TARG, (len * 2) + 1);
4022         d = SvPVX(TARG);
4023         if (DO_UTF8(sv)) {
4024             while (len) {
4025                 STRLEN ulen = UTF8SKIP(s);
4026                 bool to_quote = FALSE;
4027
4028                 if (UTF8_IS_INVARIANT(*s)) {
4029                     if (_isQUOTEMETA(*s)) {
4030                         to_quote = TRUE;
4031                     }
4032                 }
4033                 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4034
4035                     /* In locale, we quote all non-ASCII Latin1 chars.
4036                      * Otherwise use the quoting rules */
4037                     if (IN_LOCALE_RUNTIME
4038                         || _isQUOTEMETA(TWO_BYTE_UTF8_TO_UNI(*s, *(s + 1))))
4039                     {
4040                         to_quote = TRUE;
4041                     }
4042                 }
4043                 else if (_is_utf8_quotemeta((U8 *) s)) {
4044                     to_quote = TRUE;
4045                 }
4046
4047                 if (to_quote) {
4048                     *d++ = '\\';
4049                 }
4050                 if (ulen > len)
4051                     ulen = len;
4052                 len -= ulen;
4053                 while (ulen--)
4054                     *d++ = *s++;
4055             }
4056             SvUTF8_on(TARG);
4057         }
4058         else if (IN_UNI_8_BIT) {
4059             while (len--) {
4060                 if (_isQUOTEMETA(*s))
4061                     *d++ = '\\';
4062                 *d++ = *s++;
4063             }
4064         }
4065         else {
4066             /* For non UNI_8_BIT (and hence in locale) just quote all \W
4067              * including everything above ASCII */
4068             while (len--) {
4069                 if (!isWORDCHAR_A(*s))
4070                     *d++ = '\\';
4071                 *d++ = *s++;
4072             }
4073         }
4074         *d = '\0';
4075         SvCUR_set(TARG, d - SvPVX_const(TARG));
4076         (void)SvPOK_only_UTF8(TARG);
4077     }
4078     else
4079         sv_setpvn(TARG, s, len);
4080     SETTARG;
4081     RETURN;
4082 }
4083
4084 PP(pp_fc)
4085 {
4086     dVAR;
4087     dTARGET;
4088     dSP;
4089     SV *source = TOPs;
4090     STRLEN len;
4091     STRLEN min;
4092     SV *dest;
4093     const U8 *s;
4094     const U8 *send;
4095     U8 *d;
4096     U8 tmpbuf[UTF8_MAXBYTES * UTF8_MAX_FOLD_CHAR_EXPAND + 1];
4097     const bool full_folding = TRUE;
4098     const U8 flags = ( full_folding      ? FOLD_FLAGS_FULL   : 0 )
4099                    | ( IN_LOCALE_RUNTIME ? FOLD_FLAGS_LOCALE : 0 );
4100
4101     /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4102      * You are welcome(?) -Hugmeir
4103      */
4104
4105     SvGETMAGIC(source);
4106
4107     dest = TARG;
4108
4109     if (SvOK(source)) {
4110         s = (const U8*)SvPV_nomg_const(source, len);
4111     } else {
4112         if (ckWARN(WARN_UNINITIALIZED))
4113             report_uninit(source);
4114         s = (const U8*)"";
4115         len = 0;
4116     }
4117
4118     min = len + 1;
4119
4120     SvUPGRADE(dest, SVt_PV);
4121     d = (U8*)SvGROW(dest, min);
4122     (void)SvPOK_only(dest);
4123
4124     SETs(dest);
4125
4126     send = s + len;
4127     if (DO_UTF8(source)) { /* UTF-8 flagged string. */
4128         bool tainted = FALSE;
4129         while (s < send) {
4130             const STRLEN u = UTF8SKIP(s);
4131             STRLEN ulen;
4132
4133             _to_utf8_fold_flags(s, tmpbuf, &ulen, flags, &tainted);
4134
4135             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4136                 const UV o = d - (U8*)SvPVX_const(dest);
4137                 SvGROW(dest, min);
4138                 d = (U8*)SvPVX(dest) + o;
4139             }
4140
4141             Copy(tmpbuf, d, ulen, U8);
4142             d += ulen;
4143             s += u;
4144         }
4145         SvUTF8_on(dest);
4146         if (tainted) {
4147             TAINT;
4148             SvTAINTED_on(dest);
4149         }
4150     } /* Unflagged string */
4151     else if (len) {
4152         /* For locale, bytes, and nothing, the behavior is supposed to be the
4153          * same as lc().
4154          */
4155         if ( IN_LOCALE_RUNTIME ) { /* Under locale */
4156             TAINT;
4157             SvTAINTED_on(dest);
4158             for (; s < send; d++, s++)
4159                 *d = toLOWER_LC(*s);
4160         }
4161         else if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
4162             for (; s < send; d++, s++)
4163                 *d = toLOWER(*s);
4164         }
4165         else {
4166             /* For ASCII and the Latin-1 range, there's only two troublesome folds,
4167             * \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full casefolding
4168             * becomes 'ss', and \x{B5} (\N{MICRO SIGN}), which under any fold becomes
4169             * \x{3BC} (\N{GREEK SMALL LETTER MU}) -- For the rest, the casefold is
4170             * their lowercase.
4171             */
4172             for (; s < send; d++, s++) {
4173                 if (*s == MICRO_SIGN) {
4174                     /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU}, which
4175                     * is outside of the latin-1 range. There's a couple of ways to
4176                     * deal with this -- khw discusses them in pp_lc/uc, so go there :)
4177                     * What we do here is upgrade what we had already casefolded,
4178                     * then enter an inner loop that appends the rest of the characters
4179                     * as UTF-8.
4180                     */
4181                     len = d - (U8*)SvPVX_const(dest);
4182                     SvCUR_set(dest, len);
4183                     len = sv_utf8_upgrade_flags_grow(dest,
4184                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4185                                                 /* The max expansion for latin1
4186                                                  * chars is 1 byte becomes 2 */
4187                                                 (send -s) * 2 + 1);
4188                     d = (U8*)SvPVX(dest) + len;
4189
4190                     CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_SMALL_LETTER_MU);
4191                     s++;
4192                     for (; s < send; s++) {
4193                         STRLEN ulen;
4194                         UV fc = _to_uni_fold_flags(*s, tmpbuf, &ulen, flags);
4195                         if UNI_IS_INVARIANT(fc) {
4196                             if ( full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) {
4197                                 *d++ = 's';
4198                                 *d++ = 's';
4199                             }
4200                             else
4201                                 *d++ = (U8)fc;
4202                         }
4203                         else {
4204                             Copy(tmpbuf, d, ulen, U8);
4205                             d += ulen;
4206                         }
4207                     }
4208                     break;
4209                 }
4210                 else if (full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) {
4211                     /* Under full casefolding, LATIN SMALL LETTER SHARP S becomes "ss",
4212                     * which may require growing the SV.
4213                     */
4214                     if (SvLEN(dest) < ++min) {
4215                         const UV o = d - (U8*)SvPVX_const(dest);
4216                         SvGROW(dest, min);
4217                         d = (U8*)SvPVX(dest) + o;
4218                      }
4219                     *(d)++ = 's';
4220                     *d = 's';
4221                 }
4222                 else { /* If it's not one of those two, the fold is their lower case */
4223                     *d = toLOWER_LATIN1(*s);
4224                 }
4225              }
4226         }
4227     }
4228     *d = '\0';
4229     SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4230
4231     if (SvTAINTED(source))
4232         SvTAINT(dest);
4233     SvSETMAGIC(dest);
4234     RETURN;
4235 }
4236
4237 /* Arrays. */
4238
4239 PP(pp_aslice)
4240 {
4241     dVAR; dSP; dMARK; dORIGMARK;
4242     AV *const av = MUTABLE_AV(POPs);
4243     const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4244
4245     if (SvTYPE(av) == SVt_PVAV) {
4246         const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4247         bool can_preserve = FALSE;
4248
4249         if (localizing) {
4250             MAGIC *mg;
4251             HV *stash;
4252
4253             can_preserve = SvCANEXISTDELETE(av);
4254         }
4255
4256         if (lval && localizing) {
4257             SV **svp;
4258             I32 max = -1;
4259             for (svp = MARK + 1; svp <= SP; svp++) {
4260                 const I32 elem = SvIV(*svp);
4261                 if (elem > max)
4262                     max = elem;
4263             }
4264             if (max > AvMAX(av))
4265                 av_extend(av, max);
4266         }
4267
4268         while (++MARK <= SP) {
4269             SV **svp;
4270             I32 elem = SvIV(*MARK);
4271             bool preeminent = TRUE;
4272
4273             if (localizing && can_preserve) {
4274                 /* If we can determine whether the element exist,
4275                  * Try to preserve the existenceness of a tied array
4276                  * element by using EXISTS and DELETE if possible.
4277                  * Fallback to FETCH and STORE otherwise. */
4278                 preeminent = av_exists(av, elem);
4279             }
4280
4281             svp = av_fetch(av, elem, lval);
4282             if (lval) {
4283                 if (!svp || *svp == &PL_sv_undef)
4284                     DIE(aTHX_ PL_no_aelem, elem);
4285                 if (localizing) {
4286                     if (preeminent)
4287                         save_aelem(av, elem, svp);
4288                     else
4289                         SAVEADELETE(av, elem);
4290                 }
4291             }
4292             *MARK = svp ? *svp : &PL_sv_undef;
4293         }
4294     }
4295     if (GIMME != G_ARRAY) {
4296         MARK = ORIGMARK;
4297         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4298         SP = MARK;
4299     }
4300     RETURN;
4301 }
4302
4303 /* Smart dereferencing for keys, values and each */
4304 PP(pp_rkeys)
4305 {
4306     dVAR;
4307     dSP;
4308     dPOPss;
4309
4310     SvGETMAGIC(sv);
4311
4312     if (
4313          !SvROK(sv)
4314       || (sv = SvRV(sv),
4315             (SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVAV)
4316           || SvOBJECT(sv)
4317          )
4318     ) {
4319         DIE(aTHX_
4320            "Type of argument to %s must be unblessed hashref or arrayref",
4321             PL_op_desc[PL_op->op_type] );
4322     }
4323
4324     if (PL_op->op_flags & OPf_SPECIAL && SvTYPE(sv) == SVt_PVAV)
4325         DIE(aTHX_
4326            "Can't modify %s in %s",
4327             PL_op_desc[PL_op->op_type], PL_op_desc[PL_op->op_next->op_type]
4328         );
4329
4330     /* Delegate to correct function for op type */
4331     PUSHs(sv);
4332     if (PL_op->op_type == OP_RKEYS || PL_op->op_type == OP_RVALUES) {
4333         return (SvTYPE(sv) == SVt_PVHV) ? Perl_do_kv(aTHX) : Perl_pp_akeys(aTHX);
4334     }
4335     else {
4336         return (SvTYPE(sv) == SVt_PVHV) ? Perl_pp_each(aTHX) : Perl_pp_aeach(aTHX);
4337     }
4338 }
4339
4340 PP(pp_aeach)
4341 {
4342     dVAR;
4343     dSP;
4344     AV *array = MUTABLE_AV(POPs);
4345     const I32 gimme = GIMME_V;
4346     IV *iterp = Perl_av_iter_p(aTHX_ array);
4347     const IV current = (*iterp)++;
4348
4349     if (current > av_len(array)) {
4350         *iterp = 0;
4351         if (gimme == G_SCALAR)
4352             RETPUSHUNDEF;
4353         else
4354             RETURN;
4355     }
4356
4357     EXTEND(SP, 2);
4358     mPUSHi(current);
4359     if (gimme == G_ARRAY) {
4360         SV **const element = av_fetch(array, current, 0);
4361         PUSHs(element ? *element : &PL_sv_undef);
4362     }
4363     RETURN;
4364 }
4365
4366 PP(pp_akeys)
4367 {
4368     dVAR;
4369     dSP;
4370     AV *array = MUTABLE_AV(POPs);
4371     const I32 gimme = GIMME_V;
4372
4373     *Perl_av_iter_p(aTHX_ array) = 0;
4374
4375     if (gimme == G_SCALAR) {
4376         dTARGET;
4377         PUSHi(av_len(array) + 1);
4378     }
4379     else if (gimme == G_ARRAY) {
4380         IV n = Perl_av_len(aTHX_ array);
4381         IV i;
4382
4383         EXTEND(SP, n + 1);
4384
4385         if (PL_op->op_type == OP_AKEYS || PL_op->op_type == OP_RKEYS) {
4386             for (i = 0;  i <= n;  i++) {
4387                 mPUSHi(i);
4388             }
4389         }
4390         else {
4391             for (i = 0;  i <= n;  i++) {
4392                 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4393                 PUSHs(elem ? *elem : &PL_sv_undef);
4394             }
4395         }
4396     }
4397     RETURN;
4398 }
4399
4400 /* Associative arrays. */
4401
4402 PP(pp_each)
4403 {
4404     dVAR;
4405     dSP;
4406     HV * hash = MUTABLE_HV(POPs);
4407     HE *entry;
4408     const I32 gimme = GIMME_V;
4409
4410     PUTBACK;
4411     /* might clobber stack_sp */
4412     entry = hv_iternext(hash);
4413     SPAGAIN;
4414
4415     EXTEND(SP, 2);
4416     if (entry) {
4417         SV* const sv = hv_iterkeysv(entry);
4418         PUSHs(sv);      /* won't clobber stack_sp */
4419         if (gimme == G_ARRAY) {
4420             SV *val;
4421             PUTBACK;
4422             /* might clobber stack_sp */
4423             val = hv_iterval(hash, entry);
4424             SPAGAIN;
4425             PUSHs(val);
4426         }
4427     }
4428     else if (gimme == G_SCALAR)
4429         RETPUSHUNDEF;
4430
4431     RETURN;
4432 }
4433
4434 STATIC OP *
4435 S_do_delete_local(pTHX)
4436 {
4437     dVAR;
4438     dSP;
4439     const I32 gimme = GIMME_V;
4440     const MAGIC *mg;
4441     HV *stash;
4442     const bool sliced = !!(PL_op->op_private & OPpSLICE);
4443     SV *unsliced_keysv = sliced ? NULL : POPs;
4444     SV * const osv = POPs;
4445     SV **mark = sliced ? PL_stack_base + POPMARK : &unsliced_keysv-1;
4446     dORIGMARK;
4447     const bool tied = SvRMAGICAL(osv)
4448                             && mg_find((const SV *)osv, PERL_MAGIC_tied);
4449     const bool can_preserve = SvCANEXISTDELETE(osv);
4450     const U32 type = SvTYPE(osv);
4451     SV ** const end = sliced ? SP : &unsliced_keysv;
4452
4453     if (type == SVt_PVHV) {                     /* hash element */
4454             HV * const hv = MUTABLE_HV(osv);
4455             while (++MARK <= end) {
4456                 SV * const keysv = *MARK;
4457                 SV *sv = NULL;
4458                 bool preeminent = TRUE;
4459                 if (can_preserve)
4460                     preeminent = hv_exists_ent(hv, keysv, 0);
4461                 if (tied) {
4462                     HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4463                     if (he)
4464                         sv = HeVAL(he);
4465                     else
4466                         preeminent = FALSE;
4467                 }
4468                 else {
4469                     sv = hv_delete_ent(hv, keysv, 0, 0);
4470                     SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4471                 }
4472                 if (preeminent) {
4473                     if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4474                     save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4475                     if (tied) {
4476                         *MARK = sv_mortalcopy(sv);
4477                         mg_clear(sv);
4478                     } else
4479                         *MARK = sv;
4480                 }
4481                 else {
4482                     SAVEHDELETE(hv, keysv);
4483                     *MARK = &PL_sv_undef;
4484                 }
4485             }
4486     }
4487     else if (type == SVt_PVAV) {                  /* array element */
4488             if (PL_op->op_flags & OPf_SPECIAL) {
4489                 AV * const av = MUTABLE_AV(osv);
4490                 while (++MARK <= end) {
4491                     I32 idx = SvIV(*MARK);
4492                     SV *sv = NULL;
4493                     bool preeminent = TRUE;
4494                     if (can_preserve)
4495                         preeminent = av_exists(av, idx);
4496                     if (tied) {
4497                         SV **svp = av_fetch(av, idx, 1);
4498                         if (svp)
4499                             sv = *svp;
4500                         else
4501                             preeminent = FALSE;
4502                     }
4503                     else {
4504                         sv = av_delete(av, idx, 0);
4505                         SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4506                     }
4507                     if (preeminent) {
4508                         save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4509                         if (tied) {
4510                             *MARK = sv_mortalcopy(sv);
4511                             mg_clear(sv);
4512                         } else
4513                             *MARK = sv;
4514                     }
4515                     else {
4516                         SAVEADELETE(av, idx);
4517                         *MARK = &PL_sv_undef;
4518                     }
4519                 }
4520             }
4521             else
4522                 DIE(aTHX_ "panic: avhv_delete no longer supported");
4523     }
4524     else
4525             DIE(aTHX_ "Not a HASH reference");
4526     if (sliced) {
4527         if (gimme == G_VOID)
4528             SP = ORIGMARK;
4529         else if (gimme == G_SCALAR) {
4530             MARK = ORIGMARK;
4531             if (SP > MARK)
4532                 *++MARK = *SP;
4533             else
4534                 *++MARK = &PL_sv_undef;
4535             SP = MARK;
4536         }
4537     }
4538     else if (gimme != G_VOID)
4539         PUSHs(unsliced_keysv);
4540
4541     RETURN;
4542 }
4543
4544 PP(pp_delete)
4545 {
4546     dVAR;
4547     dSP;
4548     I32 gimme;
4549     I32 discard;
4550
4551     if (PL_op->op_private & OPpLVAL_INTRO)
4552         return do_delete_local();
4553
4554     gimme = GIMME_V;
4555     discard = (gimme == G_VOID) ? G_DISCARD : 0;
4556
4557     if (PL_op->op_private & OPpSLICE) {
4558         dMARK; dORIGMARK;
4559         HV * const hv = MUTABLE_HV(POPs);
4560         const U32 hvtype = SvTYPE(hv);
4561         if (hvtype == SVt_PVHV) {                       /* hash element */
4562             while (++MARK <= SP) {
4563                 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
4564                 *MARK = sv ? sv : &PL_sv_undef;
4565             }
4566         }
4567         else if (hvtype == SVt_PVAV) {                  /* array element */
4568             if (PL_op->op_flags & OPf_SPECIAL) {
4569                 while (++MARK <= SP) {
4570                     SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
4571                     *MARK = sv ? sv : &PL_sv_undef;
4572                 }
4573             }
4574         }
4575         else
4576             DIE(aTHX_ "Not a HASH reference");
4577         if (discard)
4578             SP = ORIGMARK;
4579         else if (gimme == G_SCALAR) {
4580             MARK = ORIGMARK;
4581             if (SP > MARK)
4582                 *++MARK = *SP;
4583             else
4584                 *++MARK = &PL_sv_undef;
4585             SP = MARK;
4586         }
4587     }
4588     else {
4589         SV *keysv = POPs;
4590         HV * const hv = MUTABLE_HV(POPs);
4591         SV *sv = NULL;
4592         if (SvTYPE(hv) == SVt_PVHV)
4593             sv = hv_delete_ent(hv, keysv, discard, 0);
4594         else if (SvTYPE(hv) == SVt_PVAV) {
4595             if (PL_op->op_flags & OPf_SPECIAL)
4596                 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
4597             else
4598                 DIE(aTHX_ "panic: avhv_delete no longer supported");
4599         }
4600         else
4601             DIE(aTHX_ "Not a HASH reference");
4602         if (!sv)
4603             sv = &PL_sv_undef;
4604         if (!discard)
4605             PUSHs(sv);
4606     }
4607     RETURN;
4608 }
4609
4610 PP(pp_exists)
4611 {
4612     dVAR;
4613     dSP;
4614     SV *tmpsv;
4615     HV *hv;
4616
4617     if (PL_op->op_private & OPpEXISTS_SUB) {
4618         GV *gv;
4619         SV * const sv = POPs;
4620         CV * const cv = sv_2cv(sv, &hv, &gv, 0);
4621         if (cv)
4622             RETPUSHYES;
4623         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4624             RETPUSHYES;
4625         RETPUSHNO;
4626     }
4627     tmpsv = POPs;
4628     hv = MUTABLE_HV(POPs);
4629     if (SvTYPE(hv) == SVt_PVHV) {
4630         if (hv_exists_ent(hv, tmpsv, 0))
4631             RETPUSHYES;
4632     }
4633     else if (SvTYPE(hv) == SVt_PVAV) {
4634         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
4635             if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
4636                 RETPUSHYES;
4637         }
4638     }
4639     else {
4640         DIE(aTHX_ "Not a HASH reference");
4641     }
4642     RETPUSHNO;
4643 }
4644
4645 PP(pp_hslice)
4646 {
4647     dVAR; dSP; dMARK; dORIGMARK;
4648     HV * const hv = MUTABLE_HV(POPs);
4649     const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4650     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4651     bool can_preserve = FALSE;
4652
4653     if (localizing) {
4654         MAGIC *mg;
4655         HV *stash;
4656
4657         if (SvCANEXISTDELETE(hv))
4658             can_preserve = TRUE;
4659     }
4660
4661     while (++MARK <= SP) {
4662         SV * const keysv = *MARK;
4663         SV **svp;
4664         HE *he;
4665         bool preeminent = TRUE;
4666
4667         if (localizing && can_preserve) {
4668             /* If we can determine whether the element exist,
4669              * try to preserve the existenceness of a tied hash
4670              * element by using EXISTS and DELETE if possible.
4671              * Fallback to FETCH and STORE otherwise. */
4672             preeminent = hv_exists_ent(hv, keysv, 0);
4673         }
4674
4675         he = hv_fetch_ent(hv, keysv, lval, 0);
4676         svp = he ? &HeVAL(he) : NULL;
4677
4678         if (lval) {
4679             if (!svp || !*svp || *svp == &PL_sv_undef) {
4680                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4681             }
4682             if (localizing) {
4683                 if (HvNAME_get(hv) && isGV(*svp))
4684                     save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
4685                 else if (preeminent)
4686                     save_helem_flags(hv, keysv, svp,
4687                          (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
4688                 else
4689                     SAVEHDELETE(hv, keysv);
4690             }
4691         }
4692         *MARK = svp && *svp ? *svp : &PL_sv_undef;
4693     }
4694     if (GIMME != G_ARRAY) {
4695         MARK = ORIGMARK;
4696         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4697         SP = MARK;
4698     }
4699     RETURN;
4700 }
4701
4702 /* List operators. */
4703
4704 PP(pp_list)
4705 {
4706     dVAR; dSP; dMARK;
4707     if (GIMME != G_ARRAY) {
4708         if (++MARK <= SP)
4709             *MARK = *SP;                /* unwanted list, return last item */
4710         else
4711             *MARK = &PL_sv_undef;
4712         SP = MARK;
4713     }
4714     RETURN;
4715 }
4716
4717 PP(pp_lslice)
4718 {
4719     dVAR;
4720     dSP;
4721     SV ** const lastrelem = PL_stack_sp;
4722     SV ** const lastlelem = PL_stack_base + POPMARK;
4723     SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4724     SV ** const firstrelem = lastlelem + 1;
4725     I32 is_something_there = FALSE;
4726
4727     const I32 max = lastrelem - lastlelem;
4728     SV **lelem;
4729
4730     if (GIMME != G_ARRAY) {
4731         I32 ix = SvIV(*lastlelem);
4732         if (ix < 0)
4733             ix += max;
4734         if (ix < 0 || ix >= max)
4735             *firstlelem = &PL_sv_undef;
4736         else
4737             *firstlelem = firstrelem[ix];
4738         SP = firstlelem;
4739         RETURN;
4740     }
4741
4742     if (max == 0) {
4743         SP = firstlelem - 1;
4744         RETURN;
4745     }
4746
4747     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4748         I32 ix = SvIV(*lelem);
4749         if (ix < 0)
4750             ix += max;
4751         if (ix < 0 || ix >= max)
4752             *lelem = &PL_sv_undef;
4753         else {
4754             is_something_there = TRUE;
4755             if (!(*lelem = firstrelem[ix]))
4756                 *lelem = &PL_sv_undef;
4757         }
4758     }
4759     if (is_something_there)
4760         SP = lastlelem;
4761     else
4762         SP = firstlelem - 1;
4763     RETURN;
4764 }
4765
4766 PP(pp_anonlist)
4767 {
4768     dVAR; dSP; dMARK; dORIGMARK;
4769     const I32 items = SP - MARK;
4770     SV * const av = MUTABLE_SV(av_make(items, MARK+1));
4771     SP = ORIGMARK;              /* av_make() might realloc stack_sp */
4772     mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
4773             ? newRV_noinc(av) : av);
4774     RETURN;
4775 }
4776
4777 PP(pp_anonhash)
4778 {
4779     dVAR; dSP; dMARK; dORIGMARK;
4780     HV* const hv = newHV();
4781
4782     while (MARK < SP) {
4783         SV * const key = *++MARK;
4784         SV * const val = newSV(0);
4785         if (MARK < SP)
4786             sv_setsv(val, *++MARK);
4787         else
4788             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4789         (void)hv_store_ent(hv,key,val,0);
4790     }
4791     SP = ORIGMARK;
4792     mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
4793             ? newRV_noinc(MUTABLE_SV(hv)) : MUTABLE_SV(hv));
4794     RETURN;
4795 }
4796
4797 static AV *
4798 S_deref_plain_array(pTHX_ AV *ary)
4799 {
4800     if (SvTYPE(ary) == SVt_PVAV) return ary;
4801     SvGETMAGIC((SV *)ary);
4802     if (!SvROK(ary) || SvTYPE(SvRV(ary)) != SVt_PVAV)
4803         Perl_die(aTHX_ "Not an ARRAY reference");
4804     else if (SvOBJECT(SvRV(ary)))
4805         Perl_die(aTHX_ "Not an unblessed ARRAY reference");
4806     return (AV *)SvRV(ary);
4807 }
4808
4809 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
4810 # define DEREF_PLAIN_ARRAY(ary)       \
4811    ({                                  \
4812      AV *aRrRay = ary;                  \
4813      SvTYPE(aRrRay) == SVt_PVAV          \
4814       ? aRrRay                            \
4815       : S_deref_plain_array(aTHX_ aRrRay); \
4816    })
4817 #else
4818 # define DEREF_PLAIN_ARRAY(ary)            \
4819    (                                        \
4820      PL_Sv = (SV *)(ary),                    \
4821      SvTYPE(PL_Sv) == SVt_PVAV                \
4822       ? (AV *)PL_Sv                            \
4823       : S_deref_plain_array(aTHX_ (AV *)PL_Sv)  \
4824    )
4825 #endif
4826
4827 PP(pp_splice)
4828 {
4829     dVAR; dSP; dMARK; dORIGMARK;
4830     int num_args = (SP - MARK);
4831     AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
4832     SV **src;
4833     SV **dst;
4834     I32 i;
4835     I32 offset;
4836     I32 length;
4837     I32 newlen;
4838     I32 after;
4839     I32 diff;
4840     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
4841
4842     if (mg) {
4843         return Perl_tied_method(aTHX_ "SPLICE", mark - 1, MUTABLE_SV(ary), mg,
4844                                     GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
4845                                     sp - mark);
4846     }
4847
4848     SP++;
4849
4850     if (++MARK < SP) {
4851         offset = i = SvIV(*MARK);
4852         if (offset < 0)
4853             offset += AvFILLp(ary) + 1;
4854         if (offset < 0)
4855             DIE(aTHX_ PL_no_aelem, i);
4856         if (++MARK < SP) {
4857             length = SvIVx(*MARK++);
4858             if (length < 0) {
4859                 length += AvFILLp(ary) - offset + 1;
4860                 if (length < 0)
4861                     length = 0;
4862             }
4863         }
4864         else
4865             length = AvMAX(ary) + 1;            /* close enough to infinity */
4866     }
4867     else {
4868         offset = 0;
4869         length = AvMAX(ary) + 1;
4870     }
4871     if (offset > AvFILLp(ary) + 1) {
4872         if (num_args > 2)
4873             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4874         offset = AvFILLp(ary) + 1;
4875     }
4876     after = AvFILLp(ary) + 1 - (offset + length);
4877     if (after < 0) {                            /* not that much array */
4878         length += after;                        /* offset+length now in array */
4879         after = 0;
4880         if (!AvALLOC(ary))
4881             av_extend(ary, 0);
4882     }
4883
4884     /* At this point, MARK .. SP-1 is our new LIST */
4885
4886     newlen = SP - MARK;
4887     diff = newlen - length;
4888     if (newlen && !AvREAL(ary) && AvREIFY(ary))
4889         av_reify(ary);
4890
4891     /* make new elements SVs now: avoid problems if they're from the array */
4892     for (dst = MARK, i = newlen; i; i--) {
4893         SV * const h = *dst;
4894         *dst++ = newSVsv(h);
4895     }
4896
4897     if (diff < 0) {                             /* shrinking the area */
4898         SV **tmparyval = NULL;
4899         if (newlen) {
4900             Newx(tmparyval, newlen, SV*);       /* so remember insertion */
4901             Copy(MARK, tmparyval, newlen, SV*);
4902         }
4903
4904         MARK = ORIGMARK + 1;
4905         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4906             MEXTEND(MARK, length);
4907             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4908             if (AvREAL(ary)) {
4909                 EXTEND_MORTAL(length);
4910                 for (i = length, dst = MARK; i; i--) {
4911                     sv_2mortal(*dst);   /* free them eventually */
4912                     dst++;
4913                 }
4914             }
4915             MARK += length - 1;
4916         }
4917         else {
4918             *MARK = AvARRAY(ary)[offset+length-1];
4919             if (AvREAL(ary)) {
4920                 sv_2mortal(*MARK);
4921                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4922                     SvREFCNT_dec(*dst++);       /* free them now */
4923             }
4924         }
4925         AvFILLp(ary) += diff;
4926
4927         /* pull up or down? */
4928
4929         if (offset < after) {                   /* easier to pull up */
4930             if (offset) {                       /* esp. if nothing to pull */
4931                 src = &AvARRAY(ary)[offset-1];
4932                 dst = src - diff;               /* diff is negative */
4933                 for (i = offset; i > 0; i--)    /* can't trust Copy */
4934                     *dst-- = *src--;
4935             }
4936             dst = AvARRAY(ary);
4937             AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
4938             AvMAX(ary) += diff;
4939         }
4940         else {
4941             if (after) {                        /* anything to pull down? */
4942                 src = AvARRAY(ary) + offset + length;
4943                 dst = src + diff;               /* diff is negative */
4944                 Move(src, dst, after, SV*);
4945             }
4946             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4947                                                 /* avoid later double free */
4948         }
4949         i = -diff;
4950         while (i)
4951             dst[--i] = &PL_sv_undef;
4952
4953         if (newlen) {
4954             Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4955             Safefree(tmparyval);
4956         }
4957     }
4958     else {                                      /* no, expanding (or same) */
4959         SV** tmparyval = NULL;
4960         if (length) {
4961             Newx(tmparyval, length, SV*);       /* so remember deletion */
4962             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4963         }
4964
4965         if (diff > 0) {                         /* expanding */
4966             /* push up or down? */
4967             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4968                 if (offset) {
4969                     src = AvARRAY(ary);
4970                     dst = src - diff;
4971                     Move(src, dst, offset, SV*);
4972                 }
4973                 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
4974                 AvMAX(ary) += diff;
4975                 AvFILLp(ary) += diff;
4976             }
4977             else {
4978                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
4979                     av_extend(ary, AvFILLp(ary) + diff);
4980                 AvFILLp(ary) += diff;
4981
4982                 if (after) {
4983                     dst = AvARRAY(ary) + AvFILLp(ary);
4984                     src = dst - diff;
4985                     for (i = after; i; i--) {
4986                         *dst-- = *src--;
4987                     }
4988                 }
4989             }
4990         }
4991
4992         if (newlen) {
4993             Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4994         }
4995
4996         MARK = ORIGMARK + 1;
4997         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
4998             if (length) {
4999                 Copy(tmparyval, MARK, length, SV*);
5000                 if (AvREAL(ary)) {
5001                     EXTEND_MORTAL(length);
5002                     for (i = length, dst = MARK; i; i--) {
5003                         sv_2mortal(*dst);       /* free them eventually */
5004                         dst++;
5005                     }
5006                 }
5007             }
5008             MARK += length - 1;
5009         }
5010         else if (length--) {
5011             *MARK = tmparyval[length];
5012             if (AvREAL(ary)) {
5013                 sv_2mortal(*MARK);
5014                 while (length-- > 0)
5015                     SvREFCNT_dec(tmparyval[length]);
5016             }
5017         }
5018         else
5019             *MARK = &PL_sv_undef;
5020         Safefree(tmparyval);
5021     }
5022
5023     if (SvMAGICAL(ary))
5024         mg_set(MUTABLE_SV(ary));
5025
5026     SP = MARK;
5027     RETURN;
5028 }
5029
5030 PP(pp_push)
5031 {
5032     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5033     AV * const ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5034     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5035
5036     if (mg) {
5037         *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5038         PUSHMARK(MARK);
5039         PUTBACK;
5040         ENTER_with_name("call_PUSH");
5041         call_method("PUSH",G_SCALAR|G_DISCARD);
5042         LEAVE_with_name("call_PUSH");
5043         SPAGAIN;
5044     }
5045     else {
5046         PL_delaymagic = DM_DELAY;
5047         for (++MARK; MARK <= SP; MARK++) {
5048             SV * const sv = newSV(0);
5049             if (*MARK)
5050                 sv_setsv(sv, *MARK);
5051             av_store(ary, AvFILLp(ary)+1, sv);
5052         }
5053         if (PL_delaymagic & DM_ARRAY_ISA)
5054             mg_set(MUTABLE_SV(ary));
5055
5056         PL_delaymagic = 0;
5057     }
5058     SP = ORIGMARK;
5059     if (OP_GIMME(PL_op, 0) != G_VOID) {
5060         PUSHi( AvFILL(ary) + 1 );
5061     }
5062     RETURN;
5063 }
5064
5065 PP(pp_shift)
5066 {
5067     dVAR;
5068     dSP;
5069     AV * const av = PL_op->op_flags & OPf_SPECIAL
5070         ? MUTABLE_AV(GvAV(PL_defgv)) : DEREF_PLAIN_ARRAY(MUTABLE_AV(POPs));
5071     SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5072     EXTEND(SP, 1);
5073     assert (sv);
5074     if (AvREAL(av))
5075         (void)sv_2mortal(sv);
5076     PUSHs(sv);
5077     RETURN;
5078 }
5079
5080 PP(pp_unshift)
5081 {
5082     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5083     AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5084     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5085
5086     if (mg) {
5087         *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5088         PUSHMARK(MARK);
5089         PUTBACK;
5090         ENTER_with_name("call_UNSHIFT");
5091         call_method("UNSHIFT",G_SCALAR|G_DISCARD);
5092         LEAVE_with_name("call_UNSHIFT");
5093         SPAGAIN;
5094     }
5095     else {
5096         I32 i = 0;
5097         av_unshift(ary, SP - MARK);
5098         while (MARK < SP) {
5099             SV * const sv = newSVsv(*++MARK);
5100             (void)av_store(ary, i++, sv);
5101         }
5102     }
5103     SP = ORIGMARK;
5104     if (OP_GIMME(PL_op, 0) != G_VOID) {
5105         PUSHi( AvFILL(ary) + 1 );
5106     }
5107     RETURN;
5108 }
5109
5110 PP(pp_reverse)
5111 {
5112     dVAR; dSP; dMARK;
5113
5114     if (GIMME == G_ARRAY) {
5115         if (PL_op->op_private & OPpREVERSE_INPLACE) {
5116             AV *av;
5117
5118             /* See pp_sort() */
5119             assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5120             (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5121             av = MUTABLE_AV((*SP));
5122             /* In-place reversing only happens in void context for the array
5123              * assignment. We don't need to push anything on the stack. */
5124             SP = MARK;
5125
5126             if (SvMAGICAL(av)) {
5127                 I32 i, j;
5128                 SV *tmp = sv_newmortal();
5129                 /* For SvCANEXISTDELETE */
5130                 HV *stash;
5131                 const MAGIC *mg;
5132                 bool can_preserve = SvCANEXISTDELETE(av);
5133
5134                 for (i = 0, j = av_len(av); i < j; ++i, --j) {
5135                     SV *begin, *end;
5136
5137                     if (can_preserve) {
5138                         if (!av_exists(av, i)) {
5139                             if (av_exists(av, j)) {
5140                                 SV *sv = av_delete(av, j, 0);
5141                                 begin = *av_fetch(av, i, TRUE);
5142                                 sv_setsv_mg(begin, sv);
5143                             }
5144                             continue;
5145                         }
5146                         else if (!av_exists(av, j)) {
5147                             SV *sv = av_delete(av, i, 0);
5148                             end = *av_fetch(av, j, TRUE);
5149                             sv_setsv_mg(end, sv);
5150                             continue;
5151                         }
5152                     }
5153
5154                     begin = *av_fetch(av, i, TRUE);
5155                     end   = *av_fetch(av, j, TRUE);
5156                     sv_setsv(tmp,      begin);
5157                     sv_setsv_mg(begin, end);
5158                     sv_setsv_mg(end,   tmp);
5159                 }
5160             }
5161             else {
5162                 SV **begin = AvARRAY(av);
5163
5164                 if (begin) {
5165                     SV **end   = begin + AvFILLp(av);
5166
5167                     while (begin < end) {
5168                         SV * const tmp = *begin;
5169                         *begin++ = *end;
5170                         *end--   = tmp;
5171                     }
5172                 }
5173             }
5174         }
5175         else {
5176             SV **oldsp = SP;
5177             MARK++;
5178             while (MARK < SP) {
5179                 SV * const tmp = *MARK;
5180                 *MARK++ = *SP;
5181                 *SP--   = tmp;
5182             }
5183             /* safe as long as stack cannot get extended in the above */
5184             SP = oldsp;
5185         }
5186     }
5187     else {
5188         char *up;
5189         char *down;
5190         I32 tmp;
5191         dTARGET;
5192         STRLEN len;
5193
5194         SvUTF8_off(TARG);                               /* decontaminate */
5195         if (SP - MARK > 1)
5196             do_join(TARG, &PL_sv_no, MARK, SP);
5197         else {
5198             sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv());
5199             if (! SvOK(TARG) && ckWARN(WARN_UNINITIALIZED))
5200                 report_uninit(TARG);
5201         }
5202
5203         up = SvPV_force(TARG, len);
5204         if (len > 1) {
5205             if (DO_UTF8(TARG)) {        /* first reverse each character */
5206                 U8* s = (U8*)SvPVX(TARG);
5207                 const U8* send = (U8*)(s + len);
5208                 while (s < send) {
5209                     if (UTF8_IS_INVARIANT(*s)) {
5210                         s++;
5211                         continue;
5212                     }
5213                     else {
5214                         if (!utf8_to_uvchr_buf(s, send, 0))
5215                             break;
5216                         up = (char*)s;
5217                         s += UTF8SKIP(s);
5218                         down = (char*)(s - 1);
5219                         /* reverse this character */
5220                         while (down > up) {
5221                             tmp = *up;
5222                             *up++ = *down;
5223                             *down-- = (char)tmp;
5224                         }
5225                     }
5226                 }
5227                 up = SvPVX(TARG);
5228             }
5229             down = SvPVX(TARG) + len - 1;
5230             while (down > up) {
5231                 tmp = *up;
5232                 *up++ = *down;
5233                 *down-- = (char)tmp;
5234             }
5235             (void)SvPOK_only_UTF8(TARG);
5236         }
5237         SP = MARK + 1;
5238         SETTARG;
5239     }
5240     RETURN;
5241 }
5242
5243 PP(pp_split)
5244 {
5245     dVAR; dSP; dTARG;
5246     AV *ary;
5247     IV limit = POPi;                    /* note, negative is forever */
5248     SV * const sv = POPs;
5249     STRLEN len;
5250     const char *s = SvPV_const(sv, len);
5251     const bool do_utf8 = DO_UTF8(sv);
5252     const char *strend = s + len;
5253     PMOP *pm;
5254     REGEXP *rx;
5255     SV *dstr;
5256     const char *m;
5257     I32 iters = 0;
5258     const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
5259     I32 maxiters = slen + 10;
5260     I32 trailing_empty = 0;
5261     const char *orig;
5262     const I32 origlimit = limit;
5263     I32 realarray = 0;
5264     I32 base;
5265     const I32 gimme = GIMME_V;
5266     bool gimme_scalar;
5267     const I32 oldsave = PL_savestack_ix;
5268     U32 make_mortal = SVs_TEMP;
5269     bool multiline = 0;
5270     MAGIC *mg = NULL;
5271
5272 #ifdef DEBUGGING
5273     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5274 #else
5275     pm = (PMOP*)POPs;
5276 #endif
5277     if (!pm || !s)
5278         DIE(aTHX_ "panic: pp_split, pm=%p, s=%p", pm, s);
5279     rx = PM_GETRE(pm);
5280
5281     TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
5282              (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
5283
5284     RX_MATCH_UTF8_set(rx, do_utf8);
5285
5286 #ifdef USE_ITHREADS
5287     if (pm->op_pmreplrootu.op_pmtargetoff) {
5288         ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
5289     }
5290 #else
5291     if (pm->op_pmreplrootu.op_pmtargetgv) {
5292         ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
5293     }
5294 #endif
5295     else
5296         ary = NULL;
5297     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5298         realarray = 1;
5299         PUTBACK;
5300         av_extend(ary,0);
5301         av_clear(ary);
5302         SPAGAIN;
5303         if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
5304             PUSHMARK(SP);
5305             XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
5306         }
5307         else {
5308             if (!AvREAL(ary)) {
5309                 I32 i;
5310                 AvREAL_on(ary);
5311                 AvREIFY_off(ary);
5312                 for (i = AvFILLp(ary); i >= 0; i--)
5313                     AvARRAY(ary)[i] = &PL_sv_undef;     /* don't free mere refs */
5314             }
5315             /* temporarily switch stacks */
5316             SAVESWITCHSTACK(PL_curstack, ary);
5317             make_mortal = 0;
5318         }
5319     }
5320     base = SP - PL_stack_base;
5321     orig = s;
5322     if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
5323         if (do_utf8) {
5324             while (*s == ' ' || is_utf8_space((U8*)s))
5325                 s += UTF8SKIP(s);
5326         }
5327         else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5328             while (isSPACE_LC(*s))
5329                 s++;
5330         }
5331         else {
5332             while (isSPACE(*s))
5333                 s++;
5334         }
5335     }
5336     if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
5337         multiline = 1;
5338     }
5339
5340     gimme_scalar = gimme == G_SCALAR && !ary;
5341
5342     if (!limit)
5343         limit = maxiters + 2;
5344     if (RX_EXTFLAGS(rx) & RXf_WHITE) {
5345         while (--limit) {
5346             m = s;
5347             /* this one uses 'm' and is a negative test */
5348             if (do_utf8) {
5349                 while (m < strend && !( *m == ' ' || is_utf8_space((U8*)m) )) {
5350                     const int t = UTF8SKIP(m);
5351                     /* is_utf8_space returns FALSE for malform utf8 */
5352                     if (strend - m < t)
5353                         m = strend;
5354                     else
5355                         m += t;
5356                 }
5357             }
5358             else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5359                 while (m < strend && !isSPACE_LC(*m))
5360                     ++m;
5361             } else {
5362                 while (m < strend && !isSPACE(*m))
5363                     ++m;
5364             }
5365             if (m >= strend)
5366                 break;
5367
5368             if (gimme_scalar) {
5369                 iters++;
5370                 if (m-s == 0)
5371                     trailing_empty++;
5372                 else
5373                     trailing_empty = 0;
5374             } else {
5375                 dstr = newSVpvn_flags(s, m-s,
5376                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5377                 XPUSHs(dstr);
5378             }
5379
5380             /* skip the whitespace found last */
5381             if (do_utf8)
5382                 s = m + UTF8SKIP(m);
5383             else
5384                 s = m + 1;
5385
5386             /* this one uses 's' and is a positive test */
5387             if (do_utf8) {
5388                 while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) ))
5389                     s +=  UTF8SKIP(s);
5390             }
5391             else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5392                 while (s < strend && isSPACE_LC(*s))
5393                     ++s;
5394             } else {
5395                 while (s < strend && isSPACE(*s))
5396                     ++s;
5397             }
5398         }
5399     }
5400     else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5401         while (--limit) {
5402             for (m = s; m < strend && *m != '\n'; m++)
5403                 ;
5404             m++;
5405             if (m >= strend)
5406                 break;
5407
5408             if (gimme_scalar) {
5409                 iters++;
5410                 if (m-s == 0)
5411                     trailing_empty++;
5412                 else
5413                     trailing_empty = 0;
5414             } else {
5415                 dstr = newSVpvn_flags(s, m-s,
5416                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5417                 XPUSHs(dstr);
5418             }
5419             s = m;
5420         }
5421     }
5422     else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
5423         /*
5424           Pre-extend the stack, either the number of bytes or
5425           characters in the string or a limited amount, triggered by:
5426
5427           my ($x, $y) = split //, $str;
5428             or
5429           split //, $str, $i;
5430         */
5431         if (!gimme_scalar) {
5432             const U32 items = limit - 1;
5433             if (items < slen)
5434                 EXTEND(SP, items);
5435             else
5436                 EXTEND(SP, slen);
5437         }
5438
5439         if (do_utf8) {
5440             while (--limit) {
5441                 /* keep track of how many bytes we skip over */
5442                 m = s;
5443                 s += UTF8SKIP(s);
5444                 if (gimme_scalar) {
5445                     iters++;
5446                     if (s-m == 0)
5447                         trailing_empty++;
5448                     else
5449                         trailing_empty = 0;
5450                 } else {
5451                     dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
5452
5453                     PUSHs(dstr);
5454                 }
5455
5456                 if (s >= strend)
5457                     break;
5458             }
5459         } else {
5460             while (--limit) {
5461                 if (gimme_scalar) {
5462                     iters++;
5463                 } else {
5464                     dstr = newSVpvn(s, 1);
5465
5466
5467                     if (make_mortal)
5468                         sv_2mortal(dstr);
5469
5470                     PUSHs(dstr);
5471                 }
5472
5473                 s++;
5474
5475                 if (s >= strend)
5476                     break;
5477             }
5478         }
5479     }
5480     else if (do_utf8 == (RX_UTF8(rx) != 0) &&
5481              (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5482              && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5483              && !(RX_EXTFLAGS(rx) & RXf_ANCH)) {
5484         const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
5485         SV * const csv = CALLREG_INTUIT_STRING(rx);
5486
5487         len = RX_MINLENRET(rx);
5488         if (len == 1 && !RX_UTF8(rx) && !tail) {
5489             const char c = *SvPV_nolen_const(csv);
5490             while (--limit) {
5491                 for (m = s; m < strend && *m != c; m++)
5492                     ;
5493                 if (m >= strend)
5494                     break;
5495                 if (gimme_scalar) {
5496                     iters++;
5497                     if (m-s == 0)
5498                         trailing_empty++;
5499                     else
5500                         trailing_empty = 0;
5501                 } else {
5502                     dstr = newSVpvn_flags(s, m-s,
5503                                           (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5504                     XPUSHs(dstr);
5505                 }
5506                 /* The rx->minlen is in characters but we want to step
5507                  * s ahead by bytes. */
5508                 if (do_utf8)
5509                     s = (char*)utf8_hop((U8*)m, len);
5510                 else
5511                     s = m + len; /* Fake \n at the end */
5512             }
5513         }
5514         else {
5515             while (s < strend && --limit &&
5516               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5517                              csv, multiline ? FBMrf_MULTILINE : 0)) )
5518             {
5519                 if (gimme_scalar) {
5520                     iters++;
5521                     if (m-s == 0)
5522                         trailing_empty++;
5523                     else
5524                         trailing_empty = 0;
5525                 } else {
5526                     dstr = newSVpvn_flags(s, m-s,
5527                                           (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5528                     XPUSHs(dstr);
5529                 }
5530                 /* The rx->minlen is in characters but we want to step
5531                  * s ahead by bytes. */
5532                 if (do_utf8)
5533                     s = (char*)utf8_hop((U8*)m, len);
5534                 else
5535                     s = m + len; /* Fake \n at the end */
5536             }
5537         }
5538     }
5539     else {
5540         maxiters += slen * RX_NPARENS(rx);
5541         while (s < strend && --limit)
5542         {
5543             I32 rex_return;
5544             PUTBACK;
5545             rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
5546                                      sv, NULL, 0);
5547             SPAGAIN;
5548             if (rex_return == 0)
5549                 break;
5550             TAINT_IF(RX_MATCH_TAINTED(rx));
5551             if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
5552                 m = s;
5553                 s = orig;
5554                 orig = RX_SUBBEG(rx);
5555                 s = orig + (m - s);
5556                 strend = s + (strend - m);
5557             }
5558             m = RX_OFFS(rx)[0].start + orig;
5559
5560             if (gimme_scalar) {
5561                 iters++;
5562                 if (m-s == 0)
5563                     trailing_empty++;
5564                 else
5565                     trailing_empty = 0;
5566             } else {
5567                 dstr = newSVpvn_flags(s, m-s,
5568                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5569                 XPUSHs(dstr);
5570             }
5571             if (RX_NPARENS(rx)) {
5572                 I32 i;
5573                 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
5574                     s = RX_OFFS(rx)[i].start + orig;
5575                     m = RX_OFFS(rx)[i].end + orig;
5576
5577                     /* japhy (07/27/01) -- the (m && s) test doesn't catch
5578                        parens that didn't match -- they should be set to
5579                        undef, not the empty string */
5580                     if (gimme_scalar) {
5581                         iters++;
5582                         if (m-s == 0)
5583                             trailing_empty++;
5584                         else
5585                             trailing_empty = 0;
5586                     } else {
5587                         if (m >= orig && s >= orig) {
5588                             dstr = newSVpvn_flags(s, m-s,
5589                                                  (do_utf8 ? SVf_UTF8 : 0)
5590                                                   | make_mortal);
5591                         }
5592                         else
5593                             dstr = &PL_sv_undef;  /* undef, not "" */
5594                         XPUSHs(dstr);
5595                     }
5596
5597                 }
5598             }
5599             s = RX_OFFS(rx)[0].end + orig;
5600         }
5601     }
5602
5603     if (!gimme_scalar) {
5604         iters = (SP - PL_stack_base) - base;
5605     }
5606     if (iters > maxiters)
5607         DIE(aTHX_ "Split loop");
5608
5609     /* keep field after final delim? */
5610     if (s < strend || (iters && origlimit)) {
5611         if (!gimme_scalar) {
5612             const STRLEN l = strend - s;
5613             dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5614             XPUSHs(dstr);
5615         }
5616         iters++;
5617     }
5618     else if (!origlimit) {
5619         if (gimme_scalar) {
5620             iters -= trailing_empty;
5621         } else {
5622             while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
5623                 if (TOPs && !make_mortal)
5624                     sv_2mortal(TOPs);
5625                 *SP-- = &PL_sv_undef;
5626                 iters--;
5627             }
5628         }
5629     }
5630
5631     PUTBACK;
5632     LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
5633     SPAGAIN;
5634     if (realarray) {
5635         if (!mg) {
5636             if (SvSMAGICAL(ary)) {
5637                 PUTBACK;
5638                 mg_set(MUTABLE_SV(ary));
5639                 SPAGAIN;
5640             }
5641             if (gimme == G_ARRAY) {
5642                 EXTEND(SP, iters);
5643                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5644                 SP += iters;
5645                 RETURN;
5646             }
5647         }
5648         else {
5649             PUTBACK;
5650             ENTER_with_name("call_PUSH");
5651             call_method("PUSH",G_SCALAR|G_DISCARD);
5652             LEAVE_with_name("call_PUSH");
5653             SPAGAIN;
5654             if (gimme == G_ARRAY) {
5655                 I32 i;
5656                 /* EXTEND should not be needed - we just popped them */
5657                 EXTEND(SP, iters);
5658                 for (i=0; i < iters; i++) {
5659                     SV **svp = av_fetch(ary, i, FALSE);
5660                     PUSHs((svp) ? *svp : &PL_sv_undef);
5661                 }
5662                 RETURN;
5663             }
5664         }
5665     }
5666     else {
5667         if (gimme == G_ARRAY)
5668             RETURN;
5669     }
5670
5671     GETTARGET;
5672     PUSHi(iters);
5673     RETURN;
5674 }
5675
5676 PP(pp_once)
5677 {
5678     dSP;
5679     SV *const sv = PAD_SVl(PL_op->op_targ);
5680
5681     if (SvPADSTALE(sv)) {
5682         /* First time. */
5683         SvPADSTALE_off(sv);
5684         RETURNOP(cLOGOP->op_other);
5685     }
5686     RETURNOP(cLOGOP->op_next);
5687 }
5688
5689 PP(pp_lock)
5690 {
5691     dVAR;
5692     dSP;
5693     dTOPss;
5694     SV *retsv = sv;
5695     SvLOCK(sv);
5696     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5697      || SvTYPE(retsv) == SVt_PVCV) {
5698         retsv = refto(retsv);
5699     }
5700     SETs(retsv);
5701     RETURN;
5702 }
5703
5704
5705 PP(unimplemented_op)
5706 {
5707     dVAR;
5708     const Optype op_type = PL_op->op_type;
5709     /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
5710        with out of range op numbers - it only "special" cases op_custom.
5711        Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
5712        if we get here for a custom op then that means that the custom op didn't
5713        have an implementation. Given that OP_NAME() looks up the custom op
5714        by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
5715        registers &PL_unimplemented_op as the address of their custom op.
5716        NULL doesn't generate a useful error message. "custom" does. */
5717     const char *const name = op_type >= OP_max
5718         ? "[out of range]" : PL_op_name[PL_op->op_type];
5719     if(OP_IS_SOCKET(op_type))
5720         DIE(aTHX_ PL_no_sock_func, name);
5721     DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name,  op_type);
5722 }
5723
5724 PP(pp_boolkeys)
5725 {
5726     dVAR;
5727     dSP;
5728     dTARGET;
5729     HV * const hv = (HV*)TOPs;
5730
5731     if (SvTYPE(hv) != SVt_PVHV) RETSETNO;
5732
5733     if (SvRMAGICAL(hv)) {
5734         MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_tied);
5735         if (mg) {
5736             SETs(magic_scalarpack(hv, mg));
5737             RETURN;
5738         }
5739     }
5740
5741     if (HvUSEDKEYS(hv) != 0) RETSETYES;
5742     else SETi(0); /* for $ret = %hash && foo() */
5743     RETURN;
5744 }
5745
5746 /* For sorting out arguments passed to a &CORE:: subroutine */
5747 PP(pp_coreargs)
5748 {
5749     dSP;
5750     int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
5751     int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0;
5752     AV * const at_ = GvAV(PL_defgv);
5753     SV **svp = at_ ? AvARRAY(at_) : NULL;
5754     I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
5755     I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
5756     bool seen_question = 0;
5757     const char *err = NULL;
5758     const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
5759
5760     /* Count how many args there are first, to get some idea how far to
5761        extend the stack. */
5762     while (oa) {
5763         if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
5764         maxargs++;
5765         if (oa & OA_OPTIONAL) seen_question = 1;
5766         if (!seen_question) minargs++;
5767         oa >>= 4;
5768     }
5769
5770     if(numargs < minargs) err = "Not enough";
5771     else if(numargs > maxargs) err = "Too many";
5772     if (err)
5773         /* diag_listed_as: Too many arguments for %s */
5774         Perl_croak(aTHX_
5775           "%s arguments for %s", err,
5776            opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv)
5777         );
5778
5779     /* Reset the stack pointer.  Without this, we end up returning our own
5780        arguments in list context, in addition to the values we are supposed
5781        to return.  nextstate usually does this on sub entry, but we need
5782        to run the next op with the caller's hints, so we cannot have a
5783        nextstate. */
5784     SP = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
5785
5786     if(!maxargs) RETURN;
5787
5788     /* We do this here, rather than with a separate pushmark op, as it has
5789        to come in between two things this function does (stack reset and
5790        arg pushing).  This seems the easiest way to do it. */
5791     if (pushmark) {
5792         PUTBACK;
5793         (void)Perl_pp_pushmark(aTHX);
5794     }
5795
5796     EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
5797     PUTBACK; /* The code below can die in various places. */
5798
5799     oa = PL_opargs[opnum] >> OASHIFT;
5800     for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
5801         whicharg++;
5802         switch (oa & 7) {
5803         case OA_SCALAR:
5804           try_defsv:
5805             if (!numargs && defgv && whicharg == minargs + 1) {
5806                 PUSHs(find_rundefsv2(
5807                     find_runcv_where(FIND_RUNCV_level_eq, 1, NULL),
5808                     cxstack[cxstack_ix].blk_oldcop->cop_seq
5809                 ));
5810             }
5811             else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
5812             break;
5813         case OA_LIST:
5814             while (numargs--) {
5815                 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
5816                 svp++;
5817             }
5818             RETURN;
5819         case OA_HVREF:
5820             if (!svp || !*svp || !SvROK(*svp)
5821              || SvTYPE(SvRV(*svp)) != SVt_PVHV)
5822                 DIE(aTHX_
5823                 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
5824                  "Type of arg %d to &CORE::%s must be hash reference",
5825                   whicharg, OP_DESC(PL_op->op_next)
5826                 );
5827             PUSHs(SvRV(*svp));
5828             break;
5829         case OA_FILEREF:
5830             if (!numargs) PUSHs(NULL);
5831             else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
5832                 /* no magic here, as the prototype will have added an extra
5833                    refgen and we just want what was there before that */
5834                 PUSHs(SvRV(*svp));
5835             else {
5836                 const bool constr = PL_op->op_private & whicharg;
5837                 PUSHs(S_rv2gv(aTHX_
5838                     svp && *svp ? *svp : &PL_sv_undef,
5839                     constr, CopHINTS_get(PL_curcop) & HINT_STRICT_REFS,
5840                     !constr
5841                 ));
5842             }
5843             break;
5844         case OA_SCALARREF:
5845           if (!numargs) goto try_defsv;
5846           else {
5847             const bool wantscalar =
5848                 PL_op->op_private & OPpCOREARGS_SCALARMOD;
5849             if (!svp || !*svp || !SvROK(*svp)
5850                 /* We have to permit globrefs even for the \$ proto, as
5851                    *foo is indistinguishable from ${\*foo}, and the proto-
5852                    type permits the latter. */
5853              || SvTYPE(SvRV(*svp)) > (
5854                      wantscalar       ? SVt_PVLV
5855                    : opnum == OP_LOCK || opnum == OP_UNDEF
5856                                       ? SVt_PVCV
5857                    :                    SVt_PVHV
5858                 )
5859                )
5860                 DIE(aTHX_
5861                 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
5862                  "Type of arg %d to &CORE::%s must be %s",
5863                   whicharg, PL_op_name[opnum],
5864                   wantscalar
5865                     ? "scalar reference"
5866                     : opnum == OP_LOCK || opnum == OP_UNDEF
5867                        ? "reference to one of [$@%&*]"
5868                        : "reference to one of [$@%*]"
5869                 );
5870             PUSHs(SvRV(*svp));
5871             if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv
5872              && cxstack[cxstack_ix].cx_type & CXp_HASARGS) {
5873                 /* Undo @_ localisation, so that sub exit does not undo
5874                    part of our undeffing. */
5875                 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
5876                 POP_SAVEARRAY();
5877                 cx->cx_type &= ~ CXp_HASARGS;
5878                 assert(!AvREAL(cx->blk_sub.argarray));
5879             }
5880           }
5881           break;
5882         default:
5883             DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
5884         }
5885         oa = oa >> 4;
5886     }
5887
5888     RETURN;
5889 }
5890
5891 PP(pp_runcv)
5892 {
5893     dSP;
5894     CV *cv;
5895     if (PL_op->op_private & OPpOFFBYONE) {
5896         cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL);
5897     }
5898     else cv = find_runcv(NULL);
5899     XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
5900     RETURN;
5901 }
5902
5903
5904 /*
5905  * Local variables:
5906  * c-indentation-style: bsd
5907  * c-basic-offset: 4
5908  * indent-tabs-mode: nil
5909  * End:
5910  *
5911  * ex: set ts=8 sts=4 sw=4 et:
5912  */