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