pp.c

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