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