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