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