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