pp.c

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