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