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