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