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